pcross.out

Program pcross(input, output) ;

(*$N+       ***********
PCROSS is a cross-referencing program for PASCAL source files,
useful also to reformat programs (indentation, upper-lower case)
and to find omitted or excessive BEGINS and ENDS.

comments, gripes and bugs to A.ARMANDO

subtopics:
        INPUT AND OUTPUT
        HOW TO USE IT
        SWITCHES
        READING THE OUTPUT
<INPUT AND OUTPUT>
INPUT:
-----
through the file OLDSOURCE, a PASCAL source program file.

OUTPUT:
------
through NEWSOURCE:
        a copy of your input file, unnumbered, prettyprinted
        (proper indentation according to the statement nesting,
         newline on standard places in the program, management of upper
         and lower case according to the list of reserved words, etc.)

and trough  CROSSLIST:
        (a) a prettyprinted version of the program, showing in the left
            margin the relations between BEGIN..END pairs,THEN..ELSE
            pairs, etc.
        (b) a cross reference of all the identifiers
        (c) a report of procedure and function declaration nesting.

By default, PCROSS will change all reserved words and strings to upper
case, comments and everything else to lower case. There are switches
available to change this condition.
<HOW TO USE IT>
You can:
        (a) use the /CREF switch when @EXECUTEing your program
             or calling @PASCAL, or
        (b) call it directly by typing @PCROSS.

In the first case, PCROSS will be called immediately after compilation;
    You will have to type the file names, though. We are working to fix
    that detail soon. Two sample calls are:

        @pcross                         AND     @exec myprog/cref
        OLDSOURCE= myprog.pas/nocross             (*COMPILER STUFF HERE*)
NEWSOURCE = myprog.pas                   OLDSOURCE = myprog.pas
                                                     CROSSLIST = 
                                                                 NEWSOURCE = 
                                                                             CROSSLIST = 

                                                                                         The left
                                                                                         one calls
                                                                                         it directly
                                                                                         . The
                                                                                         effect is
                                                                                         the
                                                                                      prettyprinting
                                                                                         Of the

                                                                                         Program 
                                                                                         file itself
                                                                                         . The right
                                                                                         one is a
                                                                                         call
                                                                                         through the
                                                                                         compiler,
                                                                                         which
                                                                                         will use
                                                                                         the default
                                                                                         options.

                                                                                         The

                                                                                         Program 
                                                                                         parameters
                                                                                         all have
                                                                                         dafault
                                                                                         values, but
                                                                                         they can be
                                                                                         modified
                                                                                         If desired,
                                                                                            by the
                                                                                            use Of
                                                                                            switches
                                                                                            . See
                                                                                            the
                                                                                            subtopic
                                                                                            SWITCHES
                                                                                            .
                                                                                            See the
                                                                                            subtopic
                                                                                            SWITCHES
                                                                                            .
                                                                                            <
                                                                                            SWITCHES
                                                                                            >
                                                                                            Brackets
                                                                                            indicate
                                                                                            optional
                                                                                            .
                                                                                            <n>
                                                                                            stands
                                                                                            For an
                                                                                            integer
                                                                                            number.
                                                                                            <L>
                                                                                            stands
                                                                                            For a
                                                                                            letter.

                                                                                            Switch
                                                                                            Meaning
                                                                                            Default.

                                                                                            FILES.
                                                                                            <n> is
                                                                                            the sum
                                                                                            Of:
                                                                                            1
                                                                                            source
                                                                                            Program
                                                                                            listing
                                                                                            2
                                                                                            listing
                                                                                            Of
                                                                                         identifiers
                                                                                            4
                                                                                            listing
                                                                                            Of proc-
                                                                                            func

                                                                                         declaration
                                                                                            nesting.
                                                                                            8
                                                                                            listing
                                                                                            Of proc-
                                                                                            func
                                                                                            call
                                                                                            nesting.

                                                                                            PAGE And
                                                                                            LINE
                                                                                            FORMAT
                                                                                            margin
                                                                                            every
                                                                                            fifth
                                                                                            line
                                                                                            on


                                                                                           STATEMENT
                                                                                            FORMAT
                                                                                            Begin..
                                                                                            End
                                                                                            block is
                                                                                            indented
                                                                                            n spaces
                                                                                            further.
                                                                                            If it is
                                                                                            there,
                                                                                            the
                                                                                            block
                                                                                            will Not
                                                                                            be
                                                                                            indented
                                                                                            ,
                                                                                            but the
                                                                                            Begin
                                                                                            And End
                                                                                          statements
                                                                                            will be
                                                                                            exdented
                                                                                            n spaces
                                                                                            .
                                                                                            0
                                                                                            after
                                                                                            Begin,
                                                                                            End,
                                                                                           Then,
                                                                                         Else,
                                                                                           Repeat
                                                                                             , etc.)
                                                                                             off
                                                                                             comment
                                                                                             from
                                                                                             old
                                                                                           standards
                                                                                             to
                                                                                             '('-'*'
                                                                                             and '*'
                                                                                             -')'
                                                                                             on

                                                                                             UPPER
                                                                                             AND
                                                                                             LOWER
                                                                                             Case 

                                                                                                note
                                                                                                  :
                                                                                                 the
                                                                                            possible
                                                                                              values
                                                                                                 For
                                                                                                  <l
                                                                                                  >
                                                                                                 are
                                                                                                  :
                                                                                                  u
                                                                                               means
                                                                                               upper
                                                                                                Case
                                                                                                  l
                                                                                               means
                                                                                               lower
                                                                                                Case
                                                                                                  .

                                                                                                  <
                                                                                             READING
                                                                                                 THE
                                                                                              OUTPUT
                                                                                                  >


                                                                                                 The
                                                                                               cross
                                                                                                  -
                                                                                           reference
                                                                                                File
                                                                                           CROSSLIST
                                                                                            contains
                                                                                                  4
                                                                                               parts
                                                                                                  :

                                                                                                  1.
                                                                                                 THE
                                                                                             Program
                                                                                             LISTING
                                                                                                  :

                                                                                                 the
                                                                                             letters
                                                                                                 And
                                                                                             numbers
                                                                                                  In
                                                                                                 the
                                                                                                left
                                                                                              margin
                                                                                            indicate
                                                                                                 the
                                                                                            presence
                                                                                               Of 

                                                                                            reserved
                                                                                               words
                                                                                               which
                                                                                               have
                                                                                               to
                                                                                               match
                                                                                               . (
                                                                                               Begin
                                                                                                  -
                                                                                                 End
                                                                                                  ,
                                                                                                 etc
                                                                                                  .)
                                                                                               The
                                                                                               two
                                                                                               words
                                                                                               that
                                                                                               match
                                                                                             accorde
                                                                                               With 
                                                                                                 the
                                                                                               scope
                                                                                               rules
                                                                                                will
                                                                                                have
                                                                                                 the

                                                                                                same
                                                                                              number
                                                                                                   .
                                                                                                 The
                                                                                               first
                                                                                                 one
                                                                                                   (
                                                                                                   e
                                                                                                   .
                                                                                                   g
                                                                                                   .
                                                                                                   ,
                                                                                               Begin
                                                                                                   )
                                                                                                will
                                                                                              appear
                                                                                                  at
                                                                                                left
                                                                                                   ,
                                                                                                 And

                                                                                                 the
                                                                                              second
                                                                                                 one
                                                                                                   (
                                                                                                   e
                                                                                                   .
                                                                                                   g
                                                                                                   .
                                                                                                   ,
                                                                                                 End
                                                                                                   )
                                                                                                  at
                                                                                               right
                                                                                                   ,
                                                                                              inside
                                                                                                 the
                                                                                              margin
                                                                                                   .
                                                                                                 The
                                                                                             meaning

                                                                                                  Of
                                                                                                 the
                                                                                             letters
                                                                                                  is
                                                                                                   :

                                                                                                   B
                                                                                               Begin
                                                                                                   E
                                                                                                 End

                                                                                                   I
                                                                                                  If
                                                                                                   T
                                                                                                Then
                                                                                                   S
                                                                                                Else

                                                                                                   L
                                                                                                Loop
                                                                                                   X
                                                                                                Exit
                                                                                                   E
                                                                                                 End

                                                                                                   C
                                                                                                Case
                                                                                                   E
                                                                                                 End

                                                                                                   R
                                                                                              Repeat
                                                                                                   U
                                                                                               Until


                                                                                                   2
                                                                                                   .
                                                                                                 THE
                                                                                               CROSS
                                                                                           REFERENCE
                                                                                             LISTING
                                                                                                  Of
                                                                                         IDENTIFIERS
                                                                                                   :

                                                                                                  It
                                                                                                  is
                                                                                             ordered
                                                                                      alphabetically
                                                                                                   .
                                                                                                 For
                                                                                                each
                                                                                          identifier
                                                                                                  it
                                                                                            contains
                                                                                                   :

                                                                                                   a
                                                                                                   .
                                                                                                   A
                                                                                                 'P'
                                                                                                  Or
                                                                                                 'F'
                                                                                                  If
                                                                                                  it
                                                                                                  is
                                                                                                   a
                                                                                           Procedure
                                                                                                  Or
                                                                                            Function
                                                                                                   ,
                                                                                        respectively
                                                                                                   .

                                                                                                   b
                                                                                                   .
                                                                                                 The
                                                                                                name
                                                                                                  Of
                                                                                                 the
                                                                                          identifier
                                                                                                   ,
                                                                                                  up
                                                                                                  To
                                                                                                  10
                                                                                             symbols
                                                                                                   .

                                                                                                   c
                                                                                                   .
                                                                                                 The
                                                                                                line
                                                                                             numbers
                                                                                                  In
                                                                                               which
                                                                                                  it
                                                                                               occur
                                                                                                   .
                                                                                               Those
                                                                                               lines
                                                                                                  In
                                                                                               which

                                                                                                  it
                                                                                                  is
                                                                                            declared
                                                                                                 are
                                                                                              marked
                                                                                                With
                                                                                                   a
                                                                                                   D
                                                                                                   ;
                                                                                               those
                                                                                                  In
                                                                                               which
                                                                                                  it

                                                                                              occurs
                                                                                                more
                                                                                                than
                                                                                                once
                                                                                                 are
                                                                                              marked
                                                                                                With
                                                                                                  an
                                                                                                   M
                                                                                                   (
                                                                                            Multiple
                                                                                                   )
                                                                                                   .


                                                                                                   3
                                                                                                   .
                                                                                                 THE
                                                                                             NESTING
                                                                                                  Of
                                                                                           Procedure
                                                                                                   -
                                                                                            Function
                                                                                         DECLARATION
                                                                                                   :

                                                                                                  It
                                                                                           describes
                                                                                                 the
                                                                                              static
                                                                                               links
                                                                                                   .
                                                                                                 The
                                                                                               scope
                                                                                                  is
                                                                                               shown
                                                                                                  by
                                                                                         indentation
                                                                                                   .

                                                                                                Each
                                                                                                line
                                                                                           describes
                                                                                                   a
                                                                                           Procedure
                                                                                                  Or
                                                                                            Function
                                                                                                 And
                                                                                            contains
                                                                                                   :

                                                                                                   a
                                                                                                   .
                                                                                                 The
                                                                                                name
                                                                                                   .

                                                                                                   b
                                                                                                   .
                                                                                                  an
                                                                                                   (
                                                                                                   M
                                                                                                   )
                                                                                                   ,
                                                                                                   (
                                                                                                   P
                                                                                                   )
                                                                                                  Or
                                                                                                   (
                                                                                                   F
                                                                                                   )
                                                                                                  If
                                                                                                  it
                                                                                                  is
                                                                                                 the
                                                                                                main
                                                                                             Program
                                                                                                   ,
                                                                                                   a
                                                                                           Procedure

                                                                                                  Or
                                                                                                   a
                                                                                            Function
                                                                                                   ,
                                                                                        respectively
                                                                                                   .

                                                                                                   c
                                                                                                   .
                                                                                                  If
                                                                                               there
                                                                                                 are
                                                                                                more
                                                                                                than
                                                                                                 one
                                                                                           Procedure
                                                                                                   -
                                                                                            Function
                                                                                                With
                                                                                                 the
                                                                                                same

                                                                                                name
                                                                                                   (
                                                                                                  In
                                                                                           different
                                                                                              scopes
                                                                                                   ,
                                                                                               which
                                                                                                  is
                                                                                           perfectly
                                                                                               valid
                                                                                                   ,
                                                                                                 but

                                                                                                   a
                                                                                            horrible
                                                                                               thing
                                                                                                  To
                                                                                                 Do
                                                                                                 ),
                                                                                                 a D
                                                                                                 (
                                                                                                 For
                                                                                              DOUBLE
                                                                                                 )
                                                                                             appears
                                                                                                next
                                                                                                 ,
                                                                                                 and
                                                                                                 the
                                                                                                rest
                                                                                                 Of 
                                                                                                 the
                                                                                         information
                                                                                                 in
                                                                                                this
                                                                                                 and
                                                                                                 the
                                                                                                next
                                                                                                part
                                                                                                 Of 
                                                                                                 the
                                                                                             listing
                                                                                            contains
                                                                                                data
                                                                                                 on
                                                                                                both
                                                                                                 (Or
                                                                                                 all
                                                                                                  Of
                                                                                                them
                                                                                                  ,
                                                                                                  If

                                                                                               there
                                                                                                 are
                                                                                                more
                                                                                                than
                                                                                                 one
                                                                                                  .)
                                                                                                 .
                                                                                                 d.
                                                                                                 If 
                                                                                                  it
                                                                                                  is
                                                                                                  an
                                                                                            external
                                                                                           Procedure
                                                                                                   ,
                                                                                                  an
                                                                                                   E
                                                                                                will
                                                                                              appear
                                                                                                next
                                                                                                   .

                                                                                                   e
                                                                                                   .
                                                                                                 The
                                                                                                line
                                                                                              number
                                                                                               where
                                                                                                 the
                                                                                              header
                                                                                            appeared
                                                                                                   .

                                                                                                   f
                                                                                                   .
                                                                                                 The
                                                                                                line
                                                                                              number
                                                                                                  Of
                                                                                                 the
                                                                                               Begin
                                                                                           statement
                                                                                                   .

                                                                                                   g
                                                                                                   .
                                                                                                 The
                                                                                                line
                                                                                              number
                                                                                                  Of
                                                                                                 the
                                                                                                 End
                                                                                           statement
                                                                                                   .


                                                                                                   4
                                                                                                   .
                                                                                                 THE
                                                                                             NESTING
                                                                                                  Of
                                                                                           Procedure
                                                                                                   -
                                                                                            Function
                                                                                               CALLS
                                                                                                   :

                                                                                                  It
                                                                                           describes
                                                                                                 the
                                                                                             dynamic
                                                                                               links
                                                                                                   .
                                                                                             Calling
                                                                                               depth
                                                                                                  is
                                                                                           indicated
                                                                                                  by

                                                                                           indenting
                                                                                                   .
                                                                                                 The
                                                                                              format
                                                                                                  Of
                                                                                                each
                                                                                                line
                                                                                                  is
                                                                                                 the
                                                                                                same
                                                                                                  as
                                                                                                  In
                                                                                                 the
                                                                                            previous

                                                                                              report
                                                                                                   ,
                                                                                              Except
                                                                                                 For
                                                                                                 the
                                                                                           following
                                                                                                   :

                                                                                                   a
                                                                                                   .
                                                                                               Lines
                                                                                                 are
                                                                                            numbered
                                                                                                   .

                                                                                                   b
                                                                                                   .
                                                                                                   A
                                                                                           Procedure
                                                                                                 can
                                                                                                  be
                                                                                              called
                                                                                                from
                                                                                                more
                                                                                                than
                                                                                                 one
                                                                                               place
                                                                                                   .
                                                                                                  To
                                                                                               avoid

                                                                                           repeating
                                                                                                 the
                                                                                                list
                                                                                                  Of
                                                                                                proc
                                                                                                   -
                                                                                               funcs
                                                                                              called
                                                                                                  by
                                                                                                  it
                                                                                                   ,
                                                                                                  an
                                                                                            asterisk

                                                                                                  is
                                                                                             printed
                                                                                               after
                                                                                                 the
                                                                                                name
                                                                                                  To
                                                                                            indicate
                                                                                                that
                                                                                                  it
                                                                                                 has
                                                                                             already

                                                                                                been
                                                                                         'described'
                                                                                                   .
                                                                                             Instead
                                                                                                  Of
                                                                                                 the
                                                                                                line
                                                                                             numbers
                                                                                                 For
                                                                                                 its

                                                                                          appearence
                                                                                                  In
                                                                                                 the
                                                                                             Program
                                                                                                   ,
                                                                                                that
                                                                                                 For
                                                                                                 its
                                                                                          appearence
                                                                                                  In
                                                                                                this

                                                                                                part
                                                                                                  Of
                                                                                                 the
                                                                                             listing
                                                                                                  is
                                                                                               given
                                                                                                   ,
                                                                                                  so
                                                                                                that
                                                                                                 you
                                                                                                 can
                                                                                               refer
                                                                                                  To
                                                                                                  it
                                                                                                   .

                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   )



(******************************************************************************)



(*$T-,R100   *)

(*PROGRAM WHICH CREATES A CROSS REFERENCE LISTING WITH SIMULTANEOUS
 FORMATTING OF A PASCAL PROGRAM.       WRITTEN BY MANUEL MALL.*)




(*          INDEX           *)



(**) (*DECLARATIONS*)
(**)     (*INITPROCEDURES*)
(**)     (*CHECKOPTIONS[*) (*SETSWITCH*)
(**)     (*PAGE AND LINE CONTROL*) (*HEADER*) (*NEWPAGE*) (*NEWLINE*)
(**)     (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USETABS*)
(*]*) (*SETLASTSPACES*)
(**)        (*INPUT PROCEDURES:*) (*INSYMBOL[*) (*READBUFFER*)
(**)            (*RESWORD*) (*FINDNAME*) (*PARENTHESE*)
(**)            (*DOCOMMENT*) (*]INSYMBOL*)
(**)        (*"PARSING" PROCEDURES:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]
*)
(**)        (*STATEMENT[*) (*AND ITS PARTS*) (*]*)
(**)     (*]BLOCK*)
(**)     (*PRINT_XREF_LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*
DUMPCALL*)
(**)     (*]PRINT_XREF_LIST*)
(**) (*MAIN PROGRAM*)
(*DECLARATIONS*)


(**********************************************************************
     *
     *
     *       PROGRAM WHICH CREATES A CROSS REFERENCE LISTING
     *       AND A NEW, REFORMATTED VERSION OF A PASCAL PROGRAM.
     *
     *       INPUT:  PASCAL SOURCE FILE.
     *       OUTPUT: NEW REFORMATTED SOURCE FILE AND
     *               CROSS-REFERENCE LISTING.
     *
     *       AUTHOR: MANUEL MALL (1974).
     *
     *       MODIFIED AT STANFORD UNIVERSITY BY LARRY PAULSON.
     *                       + NOT AS MANY FORCED NEWLINES.
     *                       + THE REPORT ON PROCEDURE CALLS WAS CANCELLED.
     *
     *       MODIFIED AT STANFORD UNIVERSITY BY ARMANDO R. RODRIGUEZ. 24-MAR-78.
     *                       + A NEW SET OF SWITCH OPTIONS.
     *                       + SOME NEW ERRORS ARE REPORTED.
     *
     *       SEE THE PROCEDURE CHECKOPTIONS FOR THE AVAILABLE SWITCHES.
     *
     *       MODIFIED AT STANFORD UNIVERSITY BY ARMANDO R. RODRIGUEZ. 6-JUL-88.
     *               + ACCEPT COMMENTS BETWEEN '%' AND BACKLASH  AND BETWEEN '/*
' AND '*/'.
     *               + MARK 'P' OR 'F' IN FRONT OF THE PROC-FUNC NAMES.
     *               + MARK 'D' FOR DECLARATIONS AND 'M' FOR MULTIPLE OCCURRENCE
S.
     *               + SWITCH CLEAN/NOCLEAN TO STANDARIZE COMMENTS.
     *               + LISTING OF PROC-FUNC CALL NESTING.
     *               + REPORT THE LINE NUMBERS OF BEGIN AND END OF BODY OF PROCE
DURES.
     *          THINGS TO BE FIXED, OR DOCUMENTED:
     *                  + IF THERE ARE TWO PROCS WITH ONE NAME, IT MIXES THEM.
     *                  + IF A PROC NAME IS USED AS A VAR LATER, IT WILL BE SEEN
     *                      AS A PROC FOR CALL-NESTING.
     *                  + MAKE IT SMART ENOUGH TO AVOID CREATING STRUCTURES
     *                      THAT WON'T BE USED, WHEN CROSS IS NOT 15.
     *                  + MAKE IT RUN FASTER IN GENERAL. (TRY SPECIFICALLY I/O).
     *
     *
     ***********************************************************************)





                                                                                                   "
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                              PCROSS
                                                                                                  is
                                                                                                 now
                                                                                            modified
                                                                                                  To
                                                                                                 run
                                                                                               under
                                                                                                 the
                                                                                            Stanford
                                                                                              PASCAL
                                                                                                   *

                                                                                                   *
                                                                                              system
                                                                                                   .
                                                                                                 The
                                                                                             various
                                                                                              option
                                                                                            switches
                                                                                                 For
                                                                                                 the
                                                                                             Program
                                                                                              should
                                                                                                   *

                                                                                                   *
                                                                                                 now
                                                                                                  be
                                                                                           specified
                                                                                                  In
                                                                                             special
                                                                                            comments
                                                                                                  Of
                                                                                                 the
                                                                                           following
                                                                                                form
                                                                                                   :
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                          (*%X+,F+,N-,R+,I-,C+,... other comments *)
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                               where
                                                                                                   :
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   X
                                                                                                   +
                                                                                                   /
                                                                                                   -
                                                                                                   -
                                                                                                   -
                                                                                                   >
                                                                                            generate
                                                                                                   /
                                                                                                  Do
                                                                                                 Not
                                                                                            generate
                                                                                                   a
                                                                                               cross
                                                                                           reference
                                                                                               table
                                                                                                   ,
                                                                                                   *

                                                                                                   *
                                                                                                   F
                                                                                                   +
                                                                                                   /
                                                                                                   -
                                                                                                   -
                                                                                                   -
                                                                                                   >
                                                                                            generate
                                                                                                   /
                                                                                                  Do
                                                                                                 Not
                                                                                            generate
                                                                                                   a
                                                                                         reformatted
                                                                                             listing
                                                                                                   ,
                                                                                                   *

                                                                                                   *
                                                                                                   N
                                                                                                   +
                                                                                                   /
                                                                                                   -
                                                                                                   -
                                                                                                   -
                                                                                                   >
                                                                                               allow
                                                                                                   /
                                                                                                  Do
                                                                                                 Not
                                                                                               allow
                                                                                              nesing
                                                                                                  Of
                                                                                            comments
                                                                                                   ,
                                                                                                   *

                                                                                                   *
                                                                                                   R
                                                                                                   +
                                                                                                   /
                                                                                                   -
                                                                                                   -
                                                                                                   -
                                                                                                   >
                                                                                                 use
                                                                                               upper
                                                                                                   /
                                                                                               lower
                                                                                                Case
                                                                                                  In
                                                                                            printing
                                                                                                 the
                                                                                            reserved
                                                                                               words
                                                                                                   ,
                                                                                                   *

                                                                                                   *
                                                                                                   I
                                                                                                   +
                                                                                                   /
                                                                                                   -
                                                                                                   -
                                                                                                   -
                                                                                                   >
                                                                                                 use
                                                                                               upper
                                                                                                   /
                                                                                               lower
                                                                                                Case
                                                                                                  In
                                                                                            printing
                                                                                                 the
                                                                                        identifieres
                                                                                                   ,
                                                                                                   *

                                                                                                   *
                                                                                                   C
                                                                                                   +
                                                                                                   /
                                                                                                   -
                                                                                                   -
                                                                                                   -
                                                                                                   >
                                                                                                 use
                                                                                               upper
                                                                                                   /
                                                                                               lower
                                                                                                Case
                                                                                                  In
                                                                                            printing
                                                                                            comments
                                                                                                   .
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                              PCROSS
                                                                                                  In
                                                                                             general
                                                                                                   ,
                                                                                                 And
                                                                                                 its
                                                                                         reformating
                                                                                            Function
                                                                                                  In
                                                                                          particular
                                                                                                   ,
                                                                                                   *

                                                                                                   *
                                                                                                 can
                                                                                                  be
                                                                                              fairly
                                                                                                time
                                                                                           consuming
                                                                                                 And
                                                                                                  it
                                                                                                  is
                                                                                               known
                                                                                                  To
                                                                                                have
                                                                                                some
                                                                                                   *

                                                                                                   *
                                                                                            problems
                                                                                                   .
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                              Sassan
                                                                                             Hazeghi
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                            Stanford
                                                                                              Linear
                                                                                         Accelerator
                                                                                              Center
                                                                                                   *

                                                                                                   *
                                                                                                   P
                                                                                                   .
                                                                                                   O
                                                                                                   .
                                                                                                 Box
                                                                                                4349
                                                                                                   *

                                                                                                   *
                                                                                             Stanfor
                                                                                                   ,
                                                                                                  CA
                                                                                               94305
                                                                                                   .
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                 Jan
                                                                                                   .
                                                                                                  22
                                                                                                1979
                                                                                                   .
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   *

                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   *
                                                                                                   "





                                                                                                   #
                                                                                                   #
                                                                                               Label
                                                                                                 444
                                                                                                   ;


                                                                                               Const

                                                                                             version
                                                                                                   =
                                                'PCROSS: VERSION OF 4-aug-78 AT STANFORD UNIVERSITY'
                                                                                                   ;

                                                                                             maxline
                                                                                                   =
                                                                                                  55
                                                                                                   ;
                                              (*MAXIMUM NUMBER OF LINES PER PAGE, IG
NORING HEADER*)

                                                                                            oldwidth
                                                                                                   =
                                                                                                 200
                                                                                                   ;
                                                                   (*MAXIMUM LENGTH OF INPUT LINES*)

                                                                                      max_line_count
                                                                                                   =
                                                                                                7777
                                                                                               (*B*)
                                                                                                   ;
                                                                        (*LIMIT OF LINES/EDIT-PAGE*)

                                                                                      max_page_count
                                                                                                   =
                                                                                                  77
                                                                                               (*B*)
                                                                                                   ;
                                                                             (*LIMIT OF EDIT-PAGES*)
    (*          MAX_LINE_COUNT AND MAX_PAGE_COUNT SHOULD NOT NEED MORE THAN 18 B
ITS TOTAL*)

                                                                                                  ht
                                                                                                   =
                                                                                                   9
                                                                                             (*11B*)
                                                                                                   ;
                                                                            (*ASCII HORIZONTAL TAB*)

                                                                                                  ff
                                                                                                   =
                                                                                                  12
                                                                                             (*14B*)
                                                                                                   ;
                                                                                 (*ASCII FORM FEED*)

                                                                                                  cr
                                                                                                   =
                                                                                                  13
                                                                                             (*15B*)
                                                                                                   ;
                                                                           (*ASCII CARRIAGE RETURN*)

                                                                                              blanks
                                                                                                   =
                                                                                        '          '
                                                                                                   ;
                                                                            (*FOR EDITING PURPOSES*)

                                                                                                dots
                                                                                                   =
                                                           '  .   .   .   .   .   .   .   .   .   .'
                                                                                                   ;
        (*'  .   .   .   .   .   .   .   .   .   .   .   .   .   .'; *)


                                                                                                Type

                                                                                               pack6
                                                                                                   =
                                                                                              PACKED
                                                                                               Array
                                                                                                   [
                                                                                                   1
                                                                                                   .
                                                                                                   .
                                                                                                   6
                                                                                                   ]
                                                                                                  Of
                                                                                                char
                                                                                                   ;

                                                                                               pack9
                                                                                                   =
                                                                                              PACKED
                                                                                               Array
                                                                                                   [
                                                                                                   1
                                                                                                   .
                                                                                                   .
                                                                                                   9
                                                                                                   ]
                                                                                                  Of
                                                                                                char
                                                                                                   ;


                                                                                            errkinds
                                                                                                   =
                                                                                                   (
                                                                                      begerrinblkstr
                                                                                                   ,
                                                                                      enderrinblkstr
                                                                                                   ,
                                                                                       missgenduntil
                                                                                                   ,
                                                                                           missgthen
                                                                                                   ,
                                                                                             missgof
                                                                                                   ,

                                                                                           missgexit
                                                                                                   ,

                                                                                           missgrpar
                                                                                                   ,
                                                                                          missgquote
                                                                                                   ,
                                                                                         linetoolong
                                                                                                   ,
                                                                                           missgmain
                                                                                                   ,
                                                                                          missgpoint
                                                                                                   )
                                                                                                   ;

                                                                                           lineptrty
                                                                                                   =
                                                                                                   @
                                                                                                line
                                                                                                   ;

                                                                                           listptrty
                                                                                                   =
                                                                                                   @
                                                                                                list
                                                                                                   ;

                                                                                         procstructy
                                                                                                   =
                                                                                                   @
                                                                                           procstruc
                                                                                                   ;

                                                                                            calledty
                                                                                                   =
                                                                                                   @
                                                                                              called
                                                                                                   ;


                                                                                            linenrty
                                                                                                   =
                                                                                                   0
                                                                                                   .
                                                                                                   .
                                                                                      max_line_count
                                                                                                   ;

                                                                                            pagenrty
                                                                                                   =
                                                                                                   0
                                                                                                   .
                                                                                                   .
                                                                                      max_page_count
                                                                                                   ;


                                                                                              symbol
                                                                                                   =
                                                                                                   (
                                                                                             labelsy
                                                                                                   ,
                                                                                             constsy
                                                                                                   ,
                                                                                              typesy
                                                                                                   ,
                                                                                               varsy
                                                                                                   ,
                                                                                           programsy
                                                                                                   ,
                                                                                          (*DECSYM*)

                                                                                          functionsy
                                                                                                   ,
                                                                                         proceduresy
                                                                                                   ,
                                                                                          initprocsy
                                                                                                   ,
                                                                                          (*PROSYM*)

                                                                                               endsy
                                                                                                   ,
                                                                                             untilsy
                                                                                                   ,
                                                                                              elsesy
                                                                                                   ,
                                                                                              thensy
                                                                                                   ,
                                                                                              exitsy
                                                                                                   ,
                                                                                                ofsy
                                                                                                   ,
                                                                                                dosy
                                                                                                   ,
                                                                                               eobsy
                                                                                                   ,
                                                                                      (*ENDSYMBOLS*)

                                                                                             beginsy
                                                                                                   ,
                                                                                              casesy
                                                                                                   ,
                                                                                              loopsy
                                                                                                   ,
                                                                                            repeatsy
                                                                                                   ,
                                                                                                ifsy
                                                                                                   ,
                                                                                          (*BEGSYM*)

                                                                                            recordsy
                                                                                                   ,
                                                                                           forwardsy
                                                                                                   ,
                                                                                              gotosy
                                                                                                   ,
                                                                                             othersy
                                                                                                   ,
                                                                                            intconst
                                                                                                   ,
                                                                                               ident
                                                                                                   ,
                                                                                           strgconst
                                                                                                   ,

                                                                                            externsy
                                                                                                   ,
                                                                                              langsy
                                                                                                   ,
                                                                                               forsy
                                                                                                   ,
                                                                                             whilesy
                                                                                                   ,

                                                                                            rbracket
                                                                                                   ,
                                                                                             rparent
                                                                                                   ,
                                                                                           semicolon
                                                                                                   ,
                                                                                               point
                                                                                                   ,
                                                                                             lparent
                                                                                                   ,
                                                                                            lbracket
                                                                                                   ,
                                                                                               colon
                                                                                                   ,
                                                                                               eqlsy
                                                                                                   ,

                                                                                            otherssy
                                                                                       (*DELIMITER*)
                                                                                                   ,

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                            letterup
                                                                                                   ,
                                                                                            letterlo
                                                                                                   ,
                                                                                               digit
                                                                                                   ,
                                                                                             quotech
                                                                                                   ,
                                                                                            dquotech
                                                                                                   ,
                                                                                             spacech
                                                                                                   ,

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                            dollarch
                                                                                                   ,
                                                                                              undsch
                                                                                                   ,
                                                                                              skipch
                                                                                                   )
                                                                                                   ;


                                                                                                line
                                                                                                   =
                                                                                              PACKED
                                                                                              Record
                      (*DESCRIPTION OF THE LINE NUMBER*)

                                                                                              linenr
                                                                                                   :
                                                                                            linenrty
                                                                                                   ;
                                                                                     (*LINE NUMBER*)

                                                                                              pagenr
                                                                                                   :
                                                                                            pagenrty
                                                                                                   ;
                                                                                     (*PAGE NUMBER*)

                                                                                            contlink
                                                                                                   :
                                                                                           lineptrty
                                                                                                   ;
                                                                         (*NEXT LINE NUMBER RECORD*)

                                                                                            declflag
                                                                                                   :
                                                                                                char
                                                                                                   ;
                                (*'D' IF DECLARATION, 'M' IF
 MULTIPLE OCCURRENCE, BLANK OTHERWISE*)

                                                                                                 End
                                                                                                   ;


                                                                                                list
                                                                                                   =
                                                                                              PACKED
                                                                                              Record
                      (*DESCRIPTION OF IDENTIFIERS*)

                                                                                                name
                                                                                                   :
                                                                                                alfa
                                                                                                   ;
                                                                          (*NAME OF THE IDENTIFIER*)

                                                                                               llink
                                                                                                   ,
                                                                          (*LEFT SUCCESSOR IN TREE*)

                                                                                               rlink
                                                                                                   :
                                                                                           listptrty
                                                                                                   ;
                                                                         (*RIGHT SUCCESSOR IN TREE*)

                                                                                               first
                                                                                                   ,
                                                            (*POINTER TO FIRST LINE NUMB
ER RECORD*)

                                                                                                last
                                                                                                   :
                                                                                           lineptrty
                                                                                                   ;
                                                             (*POINTER TO LAST LINE NUMBE
R RECORD*)

                                                                                          externflag
                                                                                                   :
                                                                                                char
                                                                                                   ;
(*'E' IF EXTERNAL, 'F' IF FO
RWARD,
                                                     'D' IF TWO PROCS WITH THE S
AME NAME, BLANK OTHERWISE*)

                                                                                          profunflag
                                                                                                   :
                                                                                                char
                                                                                                   ;
                                        (*'P' IF PROCEDURE NAME, 'F'
 IF FUNCTION, BLANK OTHERWISE*)

                                                                                            procdata
                                                                                                   :
                                                                                         procstructy
                                                                                                   ;

                                                                                                 End
                                                                                                   ;



                                                                                           procstruc
                                                                                                   =
                                                                                              PACKED
                                                                                              Record
                           (*DESCRIPTION OF THE PROCEDURE NESTING*)

                                                                                            procname
                                                                                                   :
                                                                                           listptrty
                                                                                                   ;
                                                          (*POINTER TO THE APPROPRIATE
 IDENTIFIER*)

                                                                                            nextproc
                                                                                                   :
                                                                                         procstructy
                                                                                                   ;
                                                                    (*POINTER TO THE NEXT ELEMEN
T*)

                                                                                              linenr
                                                                                                   ,
                                                        (*LINE NUMBER OF THE PROCEDU
RE DEFINITION*)

                                                                                             begline
                                                                                                   ,
                                                             (*LINE NUMBER OF THE BEGIN S
TATEMENT*)

                                                                                             endline
                                                                                                   :
                                                                                            linenrty
                                                                                                   ;
                                                                (*LINENUMBER OF THE END STAT
EMENT*)

                                                                                              pagenr
                                                                                                   ,
                                                        (*PAGE NUMBER OF THE PROCEDU
RE DEFINITION*)

                                                                                             begpage
                                                                                                   ,
                                                             (*PAGE NUMBER OF THE BEGIN S
TATEMENT*)

                                                                                             endpage
                                                                                                   ,
                                                               (*PAGE NUMBER OF THE END STA
TEMENT*)

                                                                                           proclevel
                                                                                                   :
                                                                                            pagenrty
                                                                                                   ;
                                                                 (*NESTING DEPTH OF THE PROCE
DURE*)

                                                                                           firstcall
                                                                                                   :
                                                                                            calledty
                                                                                                   ;
                                                           (*LIST OF PROCEDURES CALLED
BY THIS ONE*)

                                                                                             printed
                                                                                                   :
                                                                                             boolean
                                                                                                   ;
                                                           (*TO AVOID LOOPS IN THE CALL
-NEST LIST*)

                                                                                                 End
                                                                                                   ;


                                                                                              called
                                                                                                   =
                                                                                              PACKED
                                                                                              Record

                                                                                            nextcall
                                                                                                   :
                                                                                            calledty
                                                                                                   ;

                                                                                                whom
                                                                                                   :
                                                                                         procstructy
                                                                                                   ;

                                                                                                 End
                                                                                                   ;


                                                                                                 Var
    (*                    INPUT CONTROL*)

                                                                                                   i
                                                                                                   ,
                                                                                  (*INDEX VARIABLE*)

                                                                                             bufflen
                                                                                                   ,
                                                 (*LENGTH OF THE CURRENT LINE IN THE IN
PUT BUFFER*)

                                                                                            buffmark
                                                                                                   ,
                                               (*LENGTH OF THE ALREADY PRINTED PART O
F THE BUFFER*)

                                                                                           bufferptr
                                                                                                   ,
                                                    (*POINTER TO THE NEXT CHARACTER IN THE
 BUFFER*)

                                                                                              syleng
                                                                                                   ,
                                                    (*LENGTH OF THE LAST READ IDENTIFIER O
R LABEL*)

    (*                    NESTING AND MATCHING CONTROL*)

                                                                                             bmarknr
                                                                                                   ,
                                                     (*NUMBER FOR MARKING OF 'BEGIN', 'LOOP
' ETC.*)

                                                                                             emarknr
                                                                                                   ,
                                                      (*NUMBER FOR MARKING OF 'END', 'UNTIL'
 ETC.*)

                                                                                               level
                                                                                                   ,
                                                         (*NESTING DEPTH OF THE CURRENT PROCEDU
RE*)

                                                                                       variant_level
                                                                                                   ,
                                                                       (*NESTING DEPTH OF VARIANTS*)

                                                                                             blocknr
                                                                                                   ,
                                  (*COUNTS THE STATEMENTS 'BEGIN', 'CASE
', 'LOOP', 'REPEAT', 'IF'*)

                                                                                            errcount
                                                                                                   ,
                                                                   (*COUNTS THE ERRORS ENCOUNTERED*)

    (*                    FORMATTING*)

                                                                                               maxch
                                                                                                   ,
                                                                (*PAGE WIDTH IN COLS FOR CROSSLIST*)

                                                                                           increment
                                                                                                   ,
                                                                           (*LINE NUMBER INCREMENT*)

                                                                                         indentbegin
                                                                                                   ,
                                                                       (*INDENTATION AFTER A BEGIN*)

                                                                                              begexd
                                                                                                   ,
                                                                 (*EXDENTATION FOR BEGIN-END PAIRS*)

                                                                                                feed
                                                                                                   ,
                                                           (*INDENTATION BY PROCEDURES AND BLOCKS
*)

                                                                                              spaces
                                                                                                   ,
                                                                  (*INDENTATION FOR THE FORMATTING*)

                                                                                          lastspaces
                                                                                                   ,
                                                           (*ONE-TIME OVERRIDING VALUE FOR SPACES
*)

                                                                                         goodversion
                                                                                                   ,
                                                          (*keeps the value of the version optio
n*)

                                                                                             pagecnt
                                                                                                   ,
                                                                           (*COUNTS THE FILE PAGES*)

                                                                                            pagecnt2
                                                                                                   ,
                                                           (*COUNTS THE PRINT PAGES PER FILE PAGE
*)

                                                                                              maxinc
                                                                                                   ,
                                                                  (*GREATEST ALLOWABLE LINE NUMBER*)

                                                                                          reallincnt
                                                                                                   ,
                                                                (*COUNTS THE LINES  PER PRINT PAGE*)

                                                                                             linecnt
                                                                                                   :
                                                                                             integer
                                                                                                   ;
                                                                 (*COUNTS THE LINES  PER FILE PAGE*)


                                                                                               rtime
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                   0
                                                                                                   .
                                                                                                   .
                                                                                                   3
                                                                                                   ]
                                                                                                  Of
                                                                                             integer
                                                                                                   ;
                                                                                 (*CPU TIME REPORT*)


                                                                                       procstrucdata
                                                                                                   :
                                                                                              Record
                        (*NEXT PROCEDURE TO BE PUT IN NESTING LIST*)

                                                                                              exists
                                                                                                   :
                                                                                             boolean
                                                                                                   ;

                                                                                                item
                                                                                                   :
                                                                                           procstruc
                                                                                                   ;

                                                                                                 End
                                                                                                   ;


                                                                                             flagger
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                   -
                                                                                                   1
                                                                                                   .
                                                                                                   .
                                                                                                 202
                                                                                                   ]
                                                                                                  Of
                                                                                             boolean
                                                                                                   ;
                                                    (*INDICATOR FOR UPPER AND LOWER CASE P
RINTING*)

                                                                                              buffer
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                   -
                                                                                                   1
                                                                                                   .
                                                                                                   .
                                                                                                 202
                                                                                                   ]
                                                                                                  Of
                                                                                                char
                                                                                                   ;
                                                                                    (*INPUT BUFFER*)
    (*          BUFFER HAS 2 EXTRA POSITIONS ON THE LEFT AND ONE ON THE RIGHT*)


                                                                                                   #
                                                                                                   #
                                                                                                tabs
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                   1
                                                                                                   .
                                                                                                   .
                                                                                                  17
                                                                                                   ]
                                                                                                  Of
                                                                                           (*ascii*)
                                                                                                char
                                                                                                   ;
                                                                 (*A STRING OF TABS FOR FORMATTING*)


                                                                                              linenb
                                                                                                   :
                                                                                              PACKED
                                                                                               Array
                                                                                                   [
                                                                                                   1
                                                                                                   .
                                                                                                   .
                                                                                                   5
                                                                                                   ]
                                                                                                  Of
                                                                                                char
                                                                                                   ;
                                                                                 (*SOS-LINE NUMBER*)

                                                                                                   #
                                                                                                   #
                                                                                                   "
                                                                                           date_text
                                                                                                   ,
                                                                                           time_text
                                                                                                   :
                                                                                                alfa
                                                                                                   ;
                                                                                                   "
                                                                           (*HEADING DATE AND TIME*)

                                                                                           prog_name
                                                                                                   ,
                                                                         (*NAME OF CURRENT PROGRAM*)

                                                                                                  sy
                                                                                                   :
                                                                                                alfa
                                                                                                   ;
                                                                                (*LAST SYMBOL READ*)

                                                                                                syty
                                                                                                   :
                                                                                              symbol
                                                                                                   ;
                                                                    (*TYPE OF THE LAST SYMBOL READ*)

    (*                    SWITCHES*)

                                                                                            renewing
                                                                                                   ,
                                                     (*SET IF THE NEWLSOURCE FILE IS BEING
WRITTEN*)

                                                                                            crossing
                                                                                                   ,
                                                      (*SET IF THE CROSSLIST FILE IS BEING W
RITEN*)

                                                                                              refing
                                                                                                   ,
                                                          (*SET IF THE REFERENCES WILL BE PRINTE
D*)

                                                                                          decnesting
                                                                                                   ,
                                        (*SET IF THE PRO-FUNC DECLARATION LIST
ING WILL BE PRINTED*)

                                                                                         callnesting
                                                                                                   ,
                                               (*SET IF THE PRO-FUNC CALL NESTING WIL
L BE PRINTED*)

                                                                                              doting
                                                                                                   ,
                                              (*SET IF DOTED LINES WILL BE PRINTED A
T LEFT MARGIN*)

                                                                                             forcing
                                                                                                   ,
                                               (*SET IF THEN, ELSE, DO, REPEAT WILL F
ORCE NEWLINE*)

                                                                                        nestcomments
                                                                                                   ,
                                                                          (*ACCEPT NESTED COMMENTS*)

                                                                                            cleaning
                                                                                                   ,
                                                              (*SET IF COMMENTS WILL BE STANDARIZD*)

                                                                                             rescase
                                                                                                   ,
                                                              (*SET IF RESERVED WORDS WILL UPSHIFT*)

                                                                                            nonrcase
                                                                                                   ,
                                                          (*SET IF NONRESERVED WORDS WILL UPSHIF
T*)

                                                                                             comcase
                                                                                                   ,
                                                                    (*SET IF COMMENTS WILL UPSHIFT*)

                                                                                             strcase
                                                                                                   ,
                                                                     (*SET IF STRINGS WILL UPSHIFT*)

                                                                                              thendo
                                                                                                   ,
                                             (*SET WHENEVER 'SPACES := SPACES+DOFEE
D' IS EXECUTED*)

                                                                                          anyversion
                                                                                                   ,
                                                                          (*set if goodversion > 9*)

    (*                    OTHER CONTROLS*)

                                                                                             fwddecl
                                                                                                   ,
                                                    (*SET TRUE BY BLOCK AFTER 'FORWARD', '
EXTERN'*)

                                                                                           oldspaces
                                                                                                   ,
                                                              (*SET WHEN LASTSPACES SHOULD BE USED*)

                                                                                              eoline
                                                                                                   ,
                                                                        (*SET AT END ON INPUT LINE*)

                                                                                          gotoinline
                                                                                                   ,
                                                (*SET IF A HORRENDOUS GOTO STATEMENT I
N THIS LINE*)

                                                                                           declaring
                                                                                                   ,
                                                                  (*SET WHILE PARSING DECLARATIONS*)

                                                                                      programpresent
                                                                                                   ,
                                                                   (*SET AFTER PROGRAM ENCOUNTERED*)

                                                                                              nobody
                                                                                                   ,
                                                                    (*SET IF NO MAIN BODY IS FOUND*)

                                                                                                 eob
                                                                                                   :
                                                                                             boolean
                                                                                                   ;
                                                                                        (*EOF-FLAG*)

                        (**)

                                                                                                  ch
                                                                                                   ,
                                                                             (*LAST READ CHARACTER*)

                                                                                           bmarktext
                                                                                                   ,
                                                          (*CHARACTER FOR MARKING OF 'BEGIN' ETC
.*)

                                                                                           emarktext
                                                                                                   :
                                                                                                char
                                                                                                   ;
                                                                (*CHARACTER FOR MARKING 'END' ETC.*)

    (*                    SETS*)

                                                                                               delsy
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                CHAR
                                                                                                   "
                                                                                                 ' '
                                                                                                   .
                                                                                                   .
                                                                                                 '_'
                                                                                                   "
                                                                                                   ]
                                                                                                  Of
                                                                                              symbol
                                                                                                   ;
                                                                  (*TYPE ARRAY FOR DELIMITER CHARS*)

                                                                                                   #
                                                                                              resnum
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                char
                                                                                                   ]
                                                                                                  Of
                                                                                             integer
                                                                                                   ;
                                   (*INDEX OF THE FIRST KEYWORD BEGINNING
 WITH THE INDEXED LETTER*)

                                                                                             reslist
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                   1
                                                                                                   .
                                                                                                   .
                                                                                                  46
                                                                                                   ]
                                                                                                  Of
                                                                                                alfa
                                                                                                   ;
                                                                      (*LIST OF THE RESERVED WORDS*)

                                                                                               ressy
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                   1
                                                                                                   .
                                                                                                   .
                                                                                                  46
                                                                                                   ]
                                                                                                  Of
                                                                                              symbol
                                                                                                   ;
                                                                (*TYPE ARRAY OF THE RESERVED WORDS*)

                                                                                                   #
                                                                                                   #
                                                                                                   "
                                                                                            alphanum
                                                                                                   ,
                                                                   (*CHARACTERS FROM 0..9 AND A..Z*)

                                                                                              digits
                                                                                                   ,
                                                                            (*CHARACTERS FROM 0..9*)

                                                                                                   #
                                                                                                   #
                                                                                             letters
                                                                                                   :
                                                                                                 Set
                                                                                                  Of
                                                                                                char
                                                                                                   ;
                                                                                                   "
                                                                            (*CHARACTERS FROM A..Z*)

                                                                                         relevantsym
                                                                                                   ,
                                                    (*START SYMBOLS FOR STATEMENTS AND PRO
CEDURES*)

                                                                                              prosym
                                                                                                   ,
                                                                 (*ALL SYMBOLS WHICH BEGIN A PROC.*)

                                                                                              decsym
                                                                                                   ,
                                                           (*ALL SYMBOLS WHICH BEGIN DECLARATIONS
*)

                                                                                              begsym
                                                                                                   ,
                                                    (*ALL SYMBOLS WHICH BEGIN COMPOUND STA
TEMENTS*)

                                                                                              endsym
                                                                                                   :
                                                                                                 Set
                                                                                                  Of
                                                                                              symbol
                                                                                                   ;
                                          (*ALL SYMBOLS WHICH TERMINATE  STATEME
NTS OR PROCEDURES*)

    (*                    POINTERS AND FILES*)

                                                                                             listptr
                                                                                                   ,
                                                                                            heapmark
                                                                                                   :
                                                                                           listptrty
                                                                                                   ;
                                                  (*POINTER INTO THE BINARY TREE OF THE
IDENTIFIER*)

                                                                                           firstname
                                                                                                   :
                                                                                               Array
                                                                                                   [
                                                                                                char
                                                                                                   ]
                                                                                                  Of
                                                                                           listptrty
                                                                                                   ;
                                                                (*POINTER TO THE ROOTS OF THE
TREE*)

                                                                                          procstrucf
                                                                                                   ,
                                        (*POINTER TO THE FIRST ELEMENT OF THE
PROCEDURE CALLS LIST*)

                                                                                          procstrucl
                                                                                                   :
                                                                                         procstructy
                                                                                                   ;
                                        (*POINTER TO THE LAST ELEMENT OF THE P
ROCEDURE CALLS LIST*)

                                                                                            workcall
                                                                                                   :
                                                                                            calledty
                                                                                                   ;

                                                                                           link_name
                                                                                                   ,

                                                                                            new_name
                                                                                                   ,
                                                                                          cross_name
                                                                                                   :
                                                                                               pack9
                                                                                                   ;
                                                                 (*USED TO GET THE PARAMETER FILES*)

                                                                                             old_dev
                                                                                                   ,
                                                                                         link_device
                                                                                                   ,

                                                                                             new_dev
                                                                                                   ,
                                                                                           cross_dev
                                                                                                   :
                                                                                               pack6
                                                                                                   ;

                                                                                            old_prot
                                                                                                   ,
                                                                                             old_ppn
                                                                                                   ,

                                                                                            new_prot
                                                                                                   ,
                                                                                             new_ppn
                                                                                                   ,
                                                                                          cross_prot
                                                                                                   ,
                                                                                           cross_ppn
                                                                                                   :
                                                                                             integer
                                                                                                   ;

                                                                                         programname
                                                                                                   ,
                                                                                           oldfileid
                                                                                                   ,
                                                                                           newfileid
                                                                                                   ,
                                                                                         crossfileid
                                                                                                   :
                                                                                                alfa
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                 TTY
                                                                                                   ,

                                                                                           OLDSOURCE
                                                                                                   ,
                                                                                           NEWSOURCE
                                                                                                   ,
                                                                                           CROSSLIST
                                                                                                   :
                                                                                                text
                                                                                                   ;
                                                                 (*FILES PROCESSED BY THIS PROGRAM*)

    (*INITPROCEDURES*)


                                                                                                   #
                                                                                           Procedure
                                                                                               init0
                                                                                                   ;
                                                                                                   "
                                                                                       INITPROCEDURE
                                                                                                   ;
                                                                                                   "

                                                                                               Begin
                                                                                       (*CONSTANTS*)

                                                                                                 eob
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                               maxch
                                                                                                  :=
                                                                                                 114
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                           increment
                                                                                                  :=
                                                                                                   "
                                                                                                 100
                                                                                                   "
                                                                                                   1
                                                                                                   ;

                                                                                                feed
                                                                                                  :=
                                                                                                   4
                                                                                                   ;

                                                                                         indentbegin
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                        nestcomments
                                                                                                  :=
                                                                                                true
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                            cleaning
                                                                                                  :=
                                                                                                true
                                                                                                   ;

                                                                                              begexd
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                             rescase
                                                                                                  :=
                                                                                                true
                                                                                                   ;

                                                                                            nonrcase
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                             comcase
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                             strcase
                                                                                                  :=
                                                                                                true
                                                                                                   ;

                                                                                            renewing
                                                                                                  :=
                                                                                                true
                                                                                                   ;

                                                                                            crossing
                                                                                                  :=
                                                                                                true
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                              refing
                                                                                                  :=
                                                                                                true
                                                                                           (*false*)
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                          decnesting
                                                                                                  :=
                                                                                                true
                                                                                           (*false*)
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                         callnesting
                                                                                                  :=
                                                                                                true
                                                                                           (*false*)
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                              doting
                                                                                                  :=
                                                                                               false
                                                                                            (*true*)
                                                                                                   ;

                                                                                              nobody
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                          anyversion
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                         goodversion
                                                                                                  :=
                                                                                                   -
                                                                                                   1
                                                                                                   ;

                                                                                            new_name
                                                                                                  :=
                                                                                         '         '
                                                                                                   ;

                                                                                          cross_name
                                                                                                  :=
                                                                                         '         '
                                                                                                   ;

                                                                                         programname
                                                                                                  :=
                                                                                        'PCROSS    '
                                                                                                   ;

                                                                                           oldfileid
                                                                                                  :=
                                                                                        'OLDSOURCE '
                                                                                                   ;

                                                                                           newfileid
                                                                                                  :=
                                                                                        'NEWSOURCE '
                                                                                                   ;

                                                                                         crossfileid
                                                                                                  :=
                                                                                        'CROSSLIST '
                                                                                                   ;

                                                                                                 End
                                                                                       (*CONSTANTS*)
                                                                                                   ;



                                                                                                   #
                                                                                           Procedure
                                                                                               init1
                                                                                                   ;
                                                                                                   "
                                                                                       INITPROCEDURE
                                                                                                   ;
                                                                                                   "

                                                                                               Begin
                                                                                  (*RESERVED WORDS*)

                                                                                              resnum
                                                                                                   [
                                                                                                 'A'
                                                                                                   ]
                                                                                                  :=
                                                                                                   1
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'B'
                                                                                                   ]
                                                                                                  :=
                                                                                                   3
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'C'
                                                                                                   ]
                                                                                                  :=
                                                                                                   4
                                                                                                   ;

                                                                                              resnum
                                                                                                   [
                                                                                                 'D'
                                                                                                   ]
                                                                                                  :=
                                                                                                   6
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'E'
                                                                                                   ]
                                                                                                  :=
                                                                                                   9
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'F'
                                                                                                   ]
                                                                                                  :=
                                                                                                  13
                                                                                                   ;

                                                                                              resnum
                                                                                                   [
                                                                                                 'G'
                                                                                                   ]
                                                                                                  :=
                                                                                                  18
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'H'
                                                                                                   ]
                                                                                                  :=
                                                                                                  19
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'I'
                                                                                                   ]
                                                                                                  :=
                                                                                                  19
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                              resnum
                                                                                                   [
                                                                                                succ
                                                                                                   (
                                                                                                 'I'
                                                                                                   )
                                                                                                   ]
                                                                                                  :=
                                                                                                  22
                                                                                                   ;

                                                                                              resnum
                                                                                                   [
                                                                                                 'J'
                                                                                                   ]
                                                                                                  :=
                                                                                                  22
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'K'
                                                                                                   ]
                                                                                                  :=
                                                                                                  22
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'L'
                                                                                                   ]
                                                                                                  :=
                                                                                                  22
                                                                                                   ;

                                                                                              resnum
                                                                                                   [
                                                                                                 'M'
                                                                                                   ]
                                                                                                  :=
                                                                                                  24
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'N'
                                                                                                   ]
                                                                                                  :=
                                                                                                  25
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'O'
                                                                                                   ]
                                                                                                  :=
                                                                                                  27
                                                                                                   ;

                                                                                              resnum
                                                                                                   [
                                                                                                 'P'
                                                                                                   ]
                                                                                                  :=
                                                                                                  30
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'Q'
                                                                                                   ]
                                                                                                  :=
                                                                                                  33
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'R'
                                                                                                   ]
                                                                                                  :=
                                                                                                  33
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                              resnum
                                                                                                   [
                                                                                                succ
                                                                                                   (
                                                                                                 'R'
                                                                                                   )
                                                                                                   ]
                                                                                                  :=
                                                                                                  35
                                                                                                   ;

                                                                                              resnum
                                                                                                   [
                                                                                                 'S'
                                                                                                   ]
                                                                                                  :=
                                                                                                  35
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'T'
                                                                                                   ]
                                                                                                  :=
                                                                                                  36
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'U'
                                                                                                   ]
                                                                                                  :=
                                                                                                  39
                                                                                                   ;

                                                                                              resnum
                                                                                                   [
                                                                                                 'V'
                                                                                                   ]
                                                                                                  :=
                                                                                                  40
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'W'
                                                                                                   ]
                                                                                                  :=
                                                                                                  41
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'X'
                                                                                                   ]
                                                                                                  :=
                                                                                                  43
                                                                                                   ;

                                                                                              resnum
                                                                                                   [
                                                                                                 'Y'
                                                                                                   ]
                                                                                                  :=
                                                                                                  43
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                 'Z'
                                                                                                   ]
                                                                                                  :=
                                                                                                  43
                                                                                                   ;
                                                                                              resnum
                                                                                                   [
                                                                                                succ
                                                                                                   (
                                                                                                 'Z'
                                                                                                   )
                                                                                                   ]
                                                                                                  :=
                                                                                                  43
                                                                                                   ;


                                                                                             reslist
                                                                                                   [
                                                                                                   1
                                                                                                   ]
                                                                                                  :=
                                                                                        'AND       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   1
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                   2
                                                                                                   ]
                                                                                                  :=
                                                                                        'ARRAY     '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   2
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                   3
                                                                                                   ]
                                                                                                  :=
                                                                                        'BEGIN     '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   3
                                                                                                   ]
                                                                                                  :=
                                                                                             beginsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                   4
                                                                                                   ]
                                                                                                  :=
                                                                                        'CASE      '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   4
                                                                                                   ]
                                                                                                  :=
                                                                                              casesy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                   5
                                                                                                   ]
                                                                                                  :=
                                                                                        'CONST     '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   5
                                                                                                   ]
                                                                                                  :=
                                                                                             constsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                   6
                                                                                                   ]
                                                                                                  :=
                                                                                        'DO        '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   6
                                                                                                   ]
                                                                                                  :=
                                                                                                dosy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                   7
                                                                                                   ]
                                                                                                  :=
                                                                                        'DIV       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   7
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                   8
                                                                                                   ]
                                                                                                  :=
                                                                                        'DOWNTO    '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   8
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                   9
                                                                                                   ]
                                                                                                  :=
                                                                                        'END       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                   9
                                                                                                   ]
                                                                                                  :=
                                                                                               endsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  10
                                                                                                   ]
                                                                                                  :=
                                                                                        'ELSE      '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  10
                                                                                                   ]
                                                                                                  :=
                                                                                              elsesy
                                                                                                   ;


                                                                                                   #
                                                                                                   #
                                                                                             reslist
                                                                                                   [
                                                                                                  11
                                                                                                   ]
                                                                                                  :=
                                                                                        'EXIT____  '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  11
                                                                                                   ]
                                                                                                  :=
                                                                                              exitsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  12
                                                                                                   ]
                                                                                                  :=
                                                                                        'EXTERN    '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  12
                                                                                                   ]
                                                                                                  :=
                                                                                            externsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  13
                                                                                                   ]
                                                                                                  :=
                                                                                        'FOR       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  13
                                                                                                   ]
                                                                                                  :=
                                                                                               forsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  14
                                                                                                   ]
                                                                                                  :=
                                                                                        'FILE      '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  14
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  15
                                                                                                   ]
                                                                                                  :=
                                                                                        'FORWARD   '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  15
                                                                                                   ]
                                                                                                  :=
                                                                                           forwardsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  16
                                                                                                   ]
                                                                                                  :=
                                                                                        'FUNCTION  '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  16
                                                                                                   ]
                                                                                                  :=
                                                                                          functionsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  17
                                                                                                   ]
                                                                                                  :=
                                                                                        'FORTRAN   '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  17
                                                                                                   ]
                                                                                                  :=
                                                                                              langsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  18
                                                                                                   ]
                                                                                                  :=
                                                                                        'GOTO      '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  18
                                                                                                   ]
                                                                                                  :=
                                                                                              gotosy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  19
                                                                                                   ]
                                                                                                  :=
                                                                                        'IF        '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  19
                                                                                                   ]
                                                                                                  :=
                                                                                                ifsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  20
                                                                                                   ]
                                                                                                  :=
                                                                                        'IN        '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  20
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;


                                                                                             reslist
                                                                                                   [
                                                                                                  21
                                                                                                   ]
                                                                                                  :=
                                                                                        'INITPROCED'
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  21
                                                                                                   ]
                                                                                                  :=
                                                                                          initprocsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  22
                                                                                                   ]
                                                                                                  :=
                                                                                        'LOOP____  '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  22
                                                                                                   ]
                                                                                                  :=
                                                                                              loopsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  23
                                                                                                   ]
                                                                                                  :=
                                                                                        'LABEL     '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  23
                                                                                                   ]
                                                                                                  :=
                                                                                             labelsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  24
                                                                                                   ]
                                                                                                  :=
                                                                                        'MOD       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  24
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  25
                                                                                                   ]
                                                                                                  :=
                                                                                        'NOT       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  25
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  26
                                                                                                   ]
                                                                                                  :=
                                                                                        'NIL       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  26
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  27
                                                                                                   ]
                                                                                                  :=
                                                                                        'OR        '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  27
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  28
                                                                                                   ]
                                                                                                  :=
                                                                                        'OF        '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  28
                                                                                                   ]
                                                                                                  :=
                                                                                                ofsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  29
                                                                                                   ]
                                                                                                  :=
                                                                                        'OTHERS    '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  29
                                                                                                   ]
                                                                                                  :=
                                                                                            otherssy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  30
                                                                                                   ]
                                                                                                  :=
                                                                                        'PACKED    '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  30
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;


                                                                                             reslist
                                                                                                   [
                                                                                                  31
                                                                                                   ]
                                                                                                  :=
                                                                                        'PROCEDURE '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  31
                                                                                                   ]
                                                                                                  :=
                                                                                         proceduresy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  32
                                                                                                   ]
                                                                                                  :=
                                                                                        'PROGRAM   '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  32
                                                                                                   ]
                                                                                                  :=
                                                                                           programsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  33
                                                                                                   ]
                                                                                                  :=
                                                                                        'RECORD    '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  33
                                                                                                   ]
                                                                                                  :=
                                                                                            recordsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  34
                                                                                                   ]
                                                                                                  :=
                                                                                        'REPEAT    '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  34
                                                                                                   ]
                                                                                                  :=
                                                                                            repeatsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  35
                                                                                                   ]
                                                                                                  :=
                                                                                        'SET       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  35
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  36
                                                                                                   ]
                                                                                                  :=
                                                                                        'THEN      '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  36
                                                                                                   ]
                                                                                                  :=
                                                                                              thensy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  37
                                                                                                   ]
                                                                                                  :=
                                                                                        'TO        '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  37
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  38
                                                                                                   ]
                                                                                                  :=
                                                                                        'TYPE      '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  38
                                                                                                   ]
                                                                                                  :=
                                                                                              typesy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  39
                                                                                                   ]
                                                                                                  :=
                                                                                        'UNTIL     '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  39
                                                                                                   ]
                                                                                                  :=
                                                                                             untilsy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  40
                                                                                                   ]
                                                                                                  :=
                                                                                        'VAR       '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  40
                                                                                                   ]
                                                                                                  :=
                                                                                               varsy
                                                                                                   ;


                                                                                             reslist
                                                                                                   [
                                                                                                  41
                                                                                                   ]
                                                                                                  :=
                                                                                        'WHILE     '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  41
                                                                                                   ]
                                                                                                  :=
                                                                                             whilesy
                                                                                                   ;

                                                                                             reslist
                                                                                                   [
                                                                                                  42
                                                                                                   ]
                                                                                                  :=
                                                                                        'WITH      '
                                                                                                   ;
                                                                                               ressy
                                                                                                   [
                                                                                                  42
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                                 End
                                                                                                   ;



                                                                                                   #
                                                                                           Procedure
                                                                                               init2
                                                                                                   ;
                                                                                                   "
                                                                                       INITPROCEDURE
                                                                                                   ;
                                                                                                   "

                                                                                               Begin
                                                                                            (*SETS*)

                                                                                                   #
                                                                                                   #
                                                                                                   "
                                                                                              digits
                                                                                                  :=
                                                                                                   [
                                                                                                 '0'
                                                                                                   .
                                                                                                   .
                                                                                                 '9'
                                                                                                   ]
                                                                                                   ;

                                                                                             letters
                                                                                                  :=
                                                                                                   [
                                                                                                 'A'
                                                                                                   .
                                                                                                   .
                                                                                                 'Z'
                                                                                                   ]
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                            alphanum
                                                                                                  :=
                                                                                                   [
                                                                                                 '0'
                                                                                                   .
                                                                                                   .
                                                                                                 '9'
                                                                                                   ,
                                                                                                 'A'
                                                                                                   .
                                                                                                   .
                                                                                                 'Z'
                                                                                                   ]
                                                                               (*LETTERS OR DIGITS*)
                                                                                                   ;
                                                                                                   "

                                                                                              decsym
                                                                                                  :=
                                                                                                   [
                                                                                             labelsy
                                                                                                   ,
                                                                                             constsy
                                                                                                   ,
                                                                                              typesy
                                                                                                   ,
                                                                                               varsy
                                                                                                   ,
                                                                                           programsy
                                                                                                   ]
                                                                                                   ;

                                                                                              prosym
                                                                                                  :=
                                                                                                   [
                                                                                          functionsy
                                                                                                   .
                                                                                                   .
                                                                                          initprocsy
                                                                                                   ]
                                                                                                   ;

                                                                                              endsym
                                                                                                  :=
                                                                                                   [
                                                                                          functionsy
                                                                                                   .
                                                                                                   .
                                                                                               eobsy
                                                                                                   ]
                                                                                                   ;
                                                                            (*PROSYM OR ENDSYMBOLS*)

                                                                                              begsym
                                                                                                  :=
                                                                                                   [
                                                                                             beginsy
                                                                                                   .
                                                                                                   .
                                                                                                ifsy
                                                                                                   ]
                                                                                                   ;

                                                                                         relevantsym
                                                                                                  :=
                                                                                                   [
                                                                                             labelsy
                                                                                                   .
                                                                                                   .
                                                                                          initprocsy
                                                                                (*DECSYM OR PROSYM*)
                                                                                                   ,
                                                                                             beginsy
                                                                                                   ,
                                                                                           forwardsy
                                                                                                   ,

                                                                                            externsy
                                                                                                   ,
                                                                                               eobsy
                                                                                                   ]
                                                                                                   ;

                                                                                                 End
                                                                                            (*SETS*)
                                                                                                   ;



                                                                                           Procedure
                                                                                                init
                                                                                                   ;

                                                                                               Begin

                                                                                                   #
                                                                                               init0
                                                                                                   ;

                                                                                                   #
                                                                                               init1
                                                                                                   ;

                                                                                                   #
                                                                                               init2
                                                                                                   ;

                                                                                                   #
                                                                                               rtime
                                                                                                   [
                                                                                                   0
                                                                                                   ]
                                                                                                  :=
                                                                                               clock
                                                                                                   (
                                                                                                   1
                                                                                                   )
                                                                                                   ;

                                                                                                 new
                                                                                                   (
                                                                                            heapmark
                                                                                                   )
                                                                                                   ;
                                                      (*THE HEAP IS DEALLOCATED AFTER EACH PROGRAM*)

                                                                                            workcall
                                                                                                  :=
                                                                                                 Nil
                                                                                                   ;

                                                                                                   i
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                             bufflen
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                            buffmark
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                           bufferptr
                                                                                                  :=
                                                                                                   2
                                                                                                   ;

                                                                                       variant_level
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                          reallincnt
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                             linecnt
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                             blocknr
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                               level
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                             pagecnt
                                                                                                  :=
                                                                                                   1
                                                                                                   ;

                                                                                            pagecnt2
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                            errcount
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                              eoline
                                                                                                  :=
                                                                                                true
                                                                                                   ;

                                                                                          gotoinline
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                      programpresent
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                       procstrucdata
                                                                                                   .
                                                                                              exists
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                           oldspaces
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                           declaring
                                                                                                  :=
                                                                                               false
                                                                                                   ;

                                                                                           bmarktext
                                                                                                  :=
                                                                                                 ' '
                                                                                                   ;

                                                                                           emarktext
                                                                                                  :=
                                                                                                 ' '
                                                                                                   ;

                                                                                                  sy
                                                                                                  :=
                                                                                              blanks
                                                                                                   ;
                                                                                           prog_name
                                                                                                  :=
                                                                                              blanks
                                                                                                   ;

                                                                                                   #
                                                                                                   "
                                                                                                date
                                                                                                   (
                                                                                           date_text
                                                                                                   )
                                                                                                   ;
                                                                                                time
                                                                                                   (
                                                                                           time_text
                                                                                                   )
                                                                                                   ;
                                                                                                   "

                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 chr
                                                                                                   (
                                                                                                   0
                                                                                                   )
                                                                                                  To
                                                                                                 chr
                                                                                                   (
                                                                                                 255
                                                                                                   )
                                                                                                  Do

                                                                                           firstname
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                                 Nil
                                                                                                   ;

                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 ' '
                                                                                                  To
                                                                                                 'Z'
                                                                                                  Do

                                                                                               delsy
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                             othersy
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 'A'
                                                                                                  To
                                                                                                 'I'
                                                                                                  Do
                                                                                               delsy
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                            letterup
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 'J'
                                                                                                  To
                                                                                                 'R'
                                                                                                  Do
                                                                                               delsy
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                            letterup
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 'S'
                                                                                                  To
                                                                                                 'Z'
                                                                                                  Do
                                                                                               delsy
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                            letterup
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 'a'
                                                                                                  To
                                                                                                 'i'
                                                                                                  Do
                                                                                               delsy
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                            letterlo
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 'j'
                                                                                                  To
                                                                                                 'r'
                                                                                                  Do
                                                                                               delsy
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                            letterlo
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 's'
                                                                                                  To
                                                                                                 'z'
                                                                                                  Do
                                                                                               delsy
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                            letterlo
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                                 For
                                                                                                  ch
                                                                                                  :=
                                                                                                 '0'
                                                                                                  To
                                                                                                 '9'
                                                                                                  Do
                                                                                               delsy
                                                                                                   [
                                                                                                  ch
                                                                                                   ]
                                                                                                  :=
                                                                                               digit
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                               delsy
                                                                                                   [
                                                                                                 '"'
                                                                                                   ]
                                                                                                  :=
                                                                                            dquotech
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                               delsy
                                                                                                   [
                                                                                                 '#'
                                                                                                   ]
                                                                                                  :=
                                                                                              skipch
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                               delsy
                                                                                                   [
                                                                                                 '$'
                                                                                                   ]
                                                                                                  :=
                                                                                            dollarch
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                               delsy
                                                                                                   [
                                                                                                ''''
                                                                                                   ]
                                                                                                  :=
                                                                                             quotech
                                                                                                   ;

                                                                                                   #
                                                                                                   #
                                                                                                   #
                                                                                               delsy
                                                                                                   [
                                                                                                 '_'
                                                                                                   ]
                                                                                                  :=
                                                                                              undsch
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 ' '
                                                                                                   ]
                                                                                                  :=
                                                                                             spacech
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 '('
                                                                                                   ]
                                                                                                  :=
                                                                                             lparent
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 ')'
                                                                                                   ]
                                                                                                  :=
                                                                                             rparent
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 '['
                                                                                                   ]
                                                                                                  :=
                                                                                            lbracket
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 ']'
                                                                                                   ]
                                                                                                  :=
                                                                                            rbracket
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 ';'
                                                                                                   ]
                                                                                                  :=
                                                                                           semicolon
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 '.'
                                                                                                   ]
                                                                                                  :=
                                                                                               point
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 ':'
                                                                                                   ]
                                                                                                  :=
                                                                                               colon
                                                                                                   ;

                                                                                               delsy
                                                                                                   [
                                                                                                 '='
                                                                                                   ]
                                                                                                  :=
                                                                                               eqlsy
                                                                                                   ;

                                                                                                 For
                                                                                                   i
                                                                                                  :=
                                                                                                   -
                                                                                                   1
                                                                                                  To
                                                                                                 201
                                                                                                  Do

                                                                                              buffer
                                                                                                   [
                                                                                                   i
                                                                                                   ]
                                                                                                  :=
                                                                                                 ' '
                                                                                                   ;

                                                                                                   i
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                                 new
                                                                                                   (
                                                                                           firstname
                                                                                                   [
                                                                                                 'M'
                                                                                                   ]
                                                                                                   )
                                                                                                   ;

                                                                                             listptr
                                                                                                  :=
                                                                                           firstname
                                                                                                   [
                                                                                                 'M'
                                                                                                   ]
                                                                                                   ;

                                                                                                With
                                                                                           firstname
                                                                                                   [
                                                                                                 'M'
                                                                                                   ]
                                                                                                   @
                                                                                                  Do

                                                                                               Begin

                                                                                                name
                                                                                                  :=
                                                                                        'MAIN.     '
                                                                                                   ;

                                                                                               llink
                                                                                                  :=
                                                                                                 Nil
                                                                                                   ;

                                                                                               rlink
                                                                                                  :=
                                                                                                 Nil
                                                                                                   ;

                                                                                          profunflag
                                                                                                  :=
                                                                                                 'M'
                                                                                                   ;

                                                                                                 new
                                                                                                   (
                                                                                               first
                                                                                                   )
                                                                                                   ;

                                                                                                last
                                                                                                  :=
                                                                                               first
                                                                                                   ;

                                                                                                With
                                                                                                last
                                                                                                   @
                                                                                                  Do

                                                                                               Begin

                                                                                              linenr
                                                                                                  :=
                                                                                                   1
                                                                                                   ;

                                                                                              pagenr
                                                                                                  :=
                                                                                                   1
                                                                                                   ;

                                                                                            contlink
                                                                                                  :=
                                                                                                 Nil
                                                                                                   ;

                                                                                                 End
                                                                                                   ;

                                                                                                 End
                                                                                                   ;

                                                                                                 new
                                                                                                   (
                                                                                          procstrucf
                                                                                                   )
                                                                                                   ;

                                                                                                With
                                                                                          procstrucf
                                                                                                   @
                                                                                                  Do

                                                                                               Begin

                                                                                            procname
                                                                                                  :=
                                                                                           firstname
                                                                                                   [
                                                                                                 'M'
                                                                                                   ]
                                                                                                   ;

                                                                                            nextproc
                                                                                                  :=
                                                                                                 Nil
                                                                                                   ;

                                                                                              linenr
                                                                                                  :=
                                                                                                   1
                                                                                                   ;

                                                                                              pagenr
                                                                                                  :=
                                                                                                   1
                                                                                                   ;

                                                                                           proclevel
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                           firstcall
                                                                                                  :=
                                                                                                 Nil
                                                                                                   ;

                                                                                                 End
                                                                                                   ;

                                                                                          procstrucl
                                                                                                  :=
                                                                                          procstrucf
                                                                                                   ;

                                                                                                  ch
                                                                                                  :=
                                                                                                 ' '
                                                                                                   ;

                                                                                                 For
                                                                                                   i
                                                                                                  :=
                                                                                                   1
                                                                                                  To
                                                                                                  17
                                                                                                  Do

                                                                                                   #
                                                                                                   #
                                                                                                tabs
                                                                                                   [
                                                                                                   i
                                                                                                   ]
                                                                                                  :=
                                                                                                   "
                                                                                                 chr
                                                                                                   (
                                                                                                  ht
                                                                                                   )
                                                                                                   "
                                                                                                 ' '
                                                                                                   ;

                                                                                                   #
                                                                                              linenb
                                                                                                  :=
                                                                                             '-----'
                                                                                                   ;

                                                                                                 End
                                                                                            (*INIT*)
                                                                                                   ;
    (*CHECKOPTIONS[*) (*SETSWITCH*)


(*---------------------------------------------------------------------
     !  CHECKS THE PRESENCE OF SWITCHES WITH THE FILE NAMES.
     !
     !  VALID SWITCHES ARE:                     BRACKETS INDICATE OPTIONAL.
     !                                          <N> STANDS FOR AN INTEGER NUMBER
.
     !                                          <L> STANDS FOR A LETTER.
     !
     !  SWITCH          MEANING                                         DEFAULT.
     !
     !           FILES.
     !   /[NO]NEW        WRITTING OF THE NEWSOURCE FILE                 ON
     !   /[NO]CROSS[:<N>]  WRITTING OF THE CROSSLIST FILE.              ON,15
     !                    <N> IS THE SUM OF:
     !                          1   SOURCE PROGRAM LISTING
     !                          2   LISTING OF IDENTIFIERS
     !                          4   LISTING OF PROC-FUNC
     !                              DECLARATION NESTING.
     !                          8   LISTING OF PROC-FUNC CALL NESTING.
     !   /version:<n>    behave as if conditionally compiling %<n>
     !                     comments.                                    -1
     !
     !           PAGE AND LINE FORMAT
     !   /WIDTH:<N>      PAGE WIDTH FOR CROSSLIST. (MINIMUM: 40)        132
     !   /INDENT:<N>     INDENTATION BETWEEN LEVELS.                    4
     !   /INCREMENT:<N>  LINE NUMBER INCREMENT                          100
     !   /[NO]DOTS       PUT AS A GUIDE A DOTTED LINE AT THE LEFT
     !                   MARGIN EVERY FIFTH LINE                        ON
     !
     !           STATEMENT FORMAT
     !   /BEGIN:[-]<N>   IF THE [-] IS NOT THERE, THE CONTENTS OF A
     !                     BEGIN..END BLOCK IS INDENTED N SPACES FURTHER.
     !                   IF IT IS THERE, THE BLOCK WILL NOT BE INDENTED,
     !                     BUT THE BEGIN AND END STATEMENTS WILL BE
     !                     EXDENTED N SPACES.                           0
     !   /[NO]FORCE      FORCES NEWLINE IN STANDARD PLACES. (BEFORE AND
     !                    AFTER BEGIN, END, THEN, ELSE, REPEAT, ETC.)   OFF
     !   /[NO]CLEAN      CONVERTS THE SYMBOLS FOR BEGIN AND END OF
     !                    COMMENT FROM OLD STANDARDS TO '('-'*' AND '*'-')'
ON
     !
     !           UPPER AND LOWER CASE
     !                          NOTE: THE POSSIBLE VALUES FOR <L> ARE:
     !                                  U MEANS UPPER CASE
     !                                  L MEANS LOWER CASE.
     !
     !   /RES:<L>        CASE USED FOR RESERVED WORDS.                  U
     !   /NONRES:<L>     SAME FOR NON-RESERVED WORDS.                   L
     !   /COMM:<L>       SAME FOR COMMENTS.                             L
     !   /STR:<L>        SAME FOR STRINGS.                              U
     !   /CASE:<L>       RESETS ALL THE DEFAULTS TO <L>.
OFF
     !
     +--------------------------------------------------------------------*)


                                                                                           Procedure
                                                                                        checkoptions
                                                                                                   ;

                                                                                                 Var

                                                                                                 Try
                                                                                                   :
                                                                                             integer
                                                                                                   ;


                                                                                           Procedure
                                                                                           setswitch
                                                                                                   (
                                                                                                 opt
                                                                                                   :
                                                                                                alfa
                                                                                                   ;
                                                                                                 Var
                                                                                              switch
                                                                                                   :
                                                                                             boolean
                                                                                                   )
                                                                                                   ;

                                                                                                 Var

                                                                                                   i
                                                                                                   :
                                                                                             integer
                                                                                                   ;

                                                                                               Begin
                                                                                       (*SETSWITCH*)

                                                                                                   #
                                                                                                   #
                                                                        (*    getoption(opt,i);   *)
                                                                                                   i
                                                                                                  :=
                                                                                                 ord
                                                                                                   (
                                                                                                 'l'
                                                                                                   )
                                                                                                   ;

                                                                                                  If
                                                                                                   i
                                                                                                   =
                                                                                                 ord
                                                                                                   (
                                                                                                 'L'
                                                                                                   )
                                                                                                Then

                                                                                              switch
                                                                                                  :=
                                                                                               false

                                                                                                Else

                                                                                                  If
                                                                                                   i
                                                                                                   =
                                                                                                 ord
                                                                                                   (
                                                                                                 'U'
                                                                                                   )
                                                                                                Then

                                                                                              switch
                                                                                                  :=
                                                                                                true
                                                                                               ;
                                                                                             End
(*SETSWITCH*)                                                                                ;


                                                                                           Procedure
                                                                                         showthemall
                                                                                             (i:
                                                                                             integer
                                                                                             );
                                                                                             Begin

                                                                                             writeln
                                                                                               (tty,
                                                                                                '(',
                                                                                                i:3,
                                                                                                ')',
                                                                                           oldfileid
                                                                                                ,','
                                                                                                ,
                                                                                         programname
                                                                                               );

                                                                                             writeln
                                                                                               (tty,
                                                                                            new_name
                                                                                                ,','
                                                                                                ,
                                                                                            new_prot
                                                                                                ,','
                                                                                                ,
                                                                                             new_ppn
                                                                                                ,','
                                                                                                ,
                                                                                             new_dev
                                                                                                ,','
                                                                                                ,

                                                                                           newfileid
                                                                                                ,','
                                                                                                ,
                                                                                         programname
                                                                                               );

                                                                                             writeln
                                                                                               (tty,
                                                                                          cross_name
                                                                                                ,','
                                                                                                ,
                                                                                          cross_prot
                                                                                                ,','
                                                                                                ,
                                                                                           cross_ppn
                                                                                                ,','
                                                                                                ,
                                                                                           cross_dev
                                                                                                ,','
                                                                                                ,

                                                                                         crossfileid
                                                                                                ,','
                                                                                                ,
                                                                                         programname
                                                                                               );

                                                                                             writeln
                                                                                               (tty)
                                                                                               ;
                                                                                               ##
                                                                                   (* break(tty); *)
                                                                                             End;

                                                                                             Begin
(*CHECKOPTIONS*)
                                                                                               #####
                                                                                               #####
                                                                                               #
(*##############
    getparameter(oldsource,oldfileid,programname,true);
    IF NOT option('NONEW     ') THEN
      parnameget(new_name,new_prot,new_ppn,new_dev,newfileid,programname,false);
    IF NOT option('NOCROSS   ') THEN
        parnameget(cross_name,cross_prot,cross_ppn,cross_dev,crossfileid,program
name,false);

    IF NOT option('NONEW     ') THEN
        begin
        IF (new_name = '         ') AND (new_dev = 'dsk   ') THEN
            BEGIN
            getstatus(oldsource, new_name,old_prot,old_ppn,old_dev);
            new_name[7]:='N';
            new_name[8]:='E';
            new_name[9]:='W';
            END;
        startfile(newsource,new_name,new_prot,new_ppn,new_dev,false,newfileid);
        end;

    IF NOT option('NOCROSS   ') THEN
        begin
        IF (cross_name = '         ') AND (cross_dev = 'dsk   ') THEN
            BEGIN
            getstatus(oldsource, cross_name,old_prot,old_ppn,old_dev);
            cross_name[7]:='C';
            cross_name[8]:='R';
            cross_name[9]:='L';
            END;
        startfile(crosslist,cross_name,cross_prot,cross_ppn,cross_dev,false,cros
sfileid);
        end;
######################*)
                                                                                               #####
                                                                                               #####
                                                                                               ####

                                                                                               ##
                                                                                            renewing
                                                                                               := 
                                                                                                true
                                                                                                  "
                                                                                                 Not
                                                                                              option
                                                                                                  (
                                                                                        'NONEW     '
                                                                                                  )"
                                                                                               ;

                                                                                               ##
                                                                                            crossing
                                                                                               := 
                                                                                                true
                                                                                                  "
                                                                                                 Not
                                                                                              option
                                                                                                  (
                                                                                        'NOCROSS   '
                                                                                                  )"
                                                                                               ;
                                                                                               If 
                                                                                            crossing
                                                                                                Then

                                                                                               Begin
                                                                                                   #
                                                                                                   #
                                                           (*    getoption('CROSS     ',try);     *)

                                                                                                 Try
 
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                                  If
                                                                                                 Try
                                                                                                   =
                                                                                                   0
                                                                                                Then

                                                                                                 Try
 
                                                                                                  :=
                                                                                                  15
                                                                                                   ;

                                                                                         callnesting
                                                                                                  :=
                                                                                                 Try
                                                                                                   >
                                                                                                   7
                                                                                                   ;

                                                                                          decnesting
                                                                                                  :=
                                                                                                   (
                                                                                                 Try
                                                                                                 Mod
                                                                                                   8
                                                                                                   )
                                                                                                   >
                                                                                                   3
                                                                                                   ;

                                                                                              refing
                                                                                                  :=
                                                                                                   (
                                                                                                 Try
                                                                                                 Mod
                                                                                                   4
                                                                                                   )
                                                                                                   >
                                                                                                   1
                                                                                                   ;

                                                                                            crossing
                                                                                                  :=
                                                                                                   (
                                                                                                 Try
                                                                                                 Mod
                                                                                                   2
                                                                                                   )
                                                                                                   =
                                                                                                   1
                                                                                                   ;
                                                                                                 End
                                                                                               ;

                                                                                               ##
                                                                (*if option('version   ') then    *)
                                                                                               Begin
                                                                                                 ##
                                                      (*    getoption('version   ',goodversion);  *)
                                                                                         goodversion
                                                                                                 := 
                                                                                                  15
                                                                                                 ;
                                                                                                 If 
                                                                                         goodversion
                                                                                                   >
                                                                                                   9
                                                                                                Then

                                                                                               Begin

                                                                                         goodversion
                                                                                                  :=
                                                                                                   -
                                                                                                   1
                                                                                                   ;

                                                                                          anyversion
                                                                                                  :=
                                                                                                true
                                                                                                   ;

                                                                                                 End
                                                                                                 ;
                                                                                               End;

                                                                                               ##
                                                                  (*IF option('WIDTH     ') THEN  *)
                                                                                               Begin
                                                                                                 ##
                                                            (*    getoption('WIDTH     ',maxch);  *)
                                                                                               maxch
                                                                                                 := 
                                                                                                  90
                                                                                                 ;
                                                                                                 If 
                                                                                               maxch
                                                                                                   <
                                                                                                  40
                                                                                                Then

                                                                                               maxch
                                                                                                  :=
                                                                                                  40
                                                                                                 ;

                                                                                               maxch
                                                                                                 := 
                                                                                               maxch
                                                                                                   -
                                                                                                  18
                                                                                                 ;
                                                                                               End;

                                                                                               #####
                                                                                               #####
                                                                                               #####
                                                                                               ##
(*##################
    IF option('INDENT    ') THEN
        BEGIN
##(*    getoption('INDENT    ',feed);                 *)
                                                                                               If 
                                                                                                feed
                                                                                                  <
                                                                                                  0
                                                                                                Then

                                                                                                feed
                                                                                                 := 
                                                                                                   4
                                                                                               ;
                                                                                             End;

                                                                                             If 
                                                                                              option
                                                                                                (
                                                                                        'INCREMENT '
                                                                                                )
                                                                                               Then
                                                                                               Begin
                                                                                                 ##
                                              (*    getoption('INCREMENT ',increment);            *)
                                                                                                 If 
                                                                                           increment
                                                                                                   <
                                                                                                   0
                                                                                                Then
                                                                                                   #
                                                                                                   #
                                                                                           increment
                                                                                                  :=
                                                                                                   "
                                                                                                 100
                                                                                                   "
                                                                                                   1
                                                                                                 ;
                                                                                               End;

                                                                                             doting 
                                                                                             := Not
                                                                                              option
                                                                                                (
                                                                                        'NODOTS    '
                                                                                                );

                                                                                             If 
                                                                                              option
                                                                                                (
                                                                                        'BEGIN     '
                                                                                                )
                                                                                               Then
                                                                                               Begin
                                                                                                 ##
                                              (*    getoption('BEGIN     ',indentbegin);          *)
                                                                                                 If 
                                                                                         indentbegin
                                                                                                   <
                                                                                                   0
                                                                                                Then

                                                                                               Begin

                                                                                              begexd
                                                                                                  :=
                                                                                                   -
                                                                                         indentbegin
                                                                                                   ;

                                                                                         indentbegin
                                                                                                  :=
                                                                                                   0
                                                                                                   ;

                                                                                                 End
                                                                                                 ;
                                                                                               End;

                                                                                             forcing
                                                                                             := 
                                                                                              option
                                                                                                (
                                                                                        'FORCE     '
                                                                                                );


                                                                                            cleaning
                                                                                             := Not
                                                                                              option
                                                                                                (
                                                                                        'NOCLEAN   '
                                                                                                );

                                                                                             If 
                                                                                              option
                                                                                                (
                                                                                        'CASE      '
                                                                                                )
                                                                                               Then
                                                                                               Begin

                                                                                           setswitch
                                                                                                 (
                                                                                        'CASE      '
                                                                                                  ,
                                                                                             rescase
                                                                                                 );

                                                                                            nonrcase
                                                                                                 := 
                                                                                             rescase
                                                                                                 ;

                                                                                             comcase
                                                                                                 := 
                                                                                             rescase
                                                                                                 ;

                                                                                             strcase
                                                                                                 := 
                                                                                             rescase
                                                                                                 ;
                                                                                               End;


                                                                                           setswitch
                                                                                             (
                                                                                        'RES       '
                                                                                              ,
                                                                                             rescase
                                                                                             );

                                                                                           setswitch
                                                                                             (
                                                                                        'NONRES    '
                                                                                              ,
                                                                                            nonrcase
                                                                                             );

                                                                                           setswitch
                                                                                             (
                                                                                        'COMM      '
                                                                                              ,
                                                                                             comcase
                                                                                             );

                                                                                           setswitch
                                                                                             (
                                                                                        'STR       '
                                                                                              ,
                                                                                             strcase
                                                                                             );
                                                                                             #######
                                                                                             #######
                                                                                             ###*)##
                                                                                             #######
                                                                                             #######
                                                                                             ##
                                                                                           End
(*CHECKOPTIONS*);
    (*PAGE AND LINE CONTROL*) (*HEADER*) (*NEWPAGE*) (*NEWLINE*)

Procedure header (name: alfa);
    (*PRINT TOP OF FORM AND HEADER ON LIST OUTPUT*)

Var 
  position: integer;

Begin
(*HEADER*)
  pagecnt2 := pagecnt2 + 1;
  reallincnt := 0;
  If crossing Then
    Begin
      page(crosslist);
      " writeln(crosslist) ;
      "
      ##      write (crosslist, 'Page':9, pagecnt:4, '-', pagecnt2:3 ", ' ':15");
      position := 84;
      If maxch < 84 Then
        Begin
          reallincnt := 1;
          writeln(crosslist);
          position := 42;
        End;
      write(crosslist,'   [', prog_name,']', time"_text":50, date"_text");
      If (name <> blanks) And (maxch < position + 25) Then
        Begin
          reallincnt := reallincnt + 1;
          writeln (crosslist);
          position := 0;
        End;
      writeln (crosslist, ' ': maxch - position, name);
      writeln(crosslist);
    End;
End
(*HEADER*);


Procedure newpage;
Begin
(*NEWPAGE*)
  pagecnt2 := 0;
  pagecnt := pagecnt + 1;
  If renewing Then
    ##    (*write(newsource, chr(cr), chr(ff));*)    writeln(newsource) ;
  header (blanks);
  If eoln (oldsource) Then
    readln(oldsource);
  linecnt := 0;
  reallincnt := 0;
  If prog_name <> blanks  Then
    write(tty, pagecnt:3,'..');
  ##   (* break(tty); *)
End
(*NEWPAGE*);


Procedure newline;
Begin
  If reallincnt = maxline Then
    header (blanks);
  linecnt := linecnt + 1;
  reallincnt := reallincnt + 1;
  ##  If crossing Then write(crosslist, ' ':5);
  ##  If renewing Then write(newsource, ' ':5) ;
End;
    (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USETABS*) (*]*)
 (*SETLASTSPACES*)


Procedure block;

Var 
  curproc : listptrty;
(*ZEIGER AUF DIE PROZEDUR IN DEREN ANWEISUNG
STEIL DAS PROGRAMM SICH BEFINDET*)
  itisaproc : boolean;
(*TRUE WHEN THE WORD PROCEDURE IS FOUND*)
  locprocstl: procstructy;


Procedure error (errnr : errkinds);
Begin
(*ERROR*)
  errcount := errcount+1;
  reallincnt := reallincnt + 1;
(*COUNT THE LINE OF THE ERROR MESSAGE ON T
HE LPT: FILE*)
  If crossing Then
    Begin
      write (crosslist, ' ':17,' *??* ');
      Case errnr Of 
        begerrinblkstr   : write(crosslist, sy,' ? ? ? : ERROR IN BLOCK'
                                 ,'STRUCTURE. POSSIBLY A MISSING BEGIN.');
        enderrinblkstr   : write(crosslist, sy,' ? ? ? : ERROR IN BLOCK'
                                 ,'STRUCTURE. POSSIBLY A MISSING END.');
        missgenduntil : write(crosslist, 'MISSING ''END'' OR ''UNTIL'' '
                              ,'NUMBER ',emarknr : 4);
        missgthen     : write(crosslist, 'MISSING ''THEN'' NUMBER ',
                              emarknr : 4);
        missgof       : write(crosslist, 'MISSING ''OF'' TO ''CASE'' '
                              ,'NUMBER ',bmarknr : 4);
        missgexit     : write(crosslist, 'MISSING ''EXIT'' IN ''LOOP'' '
                              ,emarknr : 4);
        missgrpar     : write(crosslist, 'MISSING RIGHT PARENTHESIS OR '
                              ,'BRACKET');
        missgquote    : write(crosslist, 'MISSING CLOSING QUOTE ON THIS'
                              ,' LINE');
        linetoolong:
                     If renewing Then
                       write(crosslist,'NEXT LINE IS TOO LONG. IT WILL '
                             ,'BE BROKEN AT COLUMN',
                             oldwidth:4,' IN NEWSOURCE.');
        missgmain     : write(crosslist, 'WARNING: THIS FILE HAS NO '
                              ,'MAIN BODY');
        missgpoint    : write(crosslist,'MISSING CLOSING POINT AT END '
                              ,'OF PROGRAM.');
      End;
      writeln(crosslist,' *??*');
    End;
  writeln(tty);
  write(tty, ' ERROR AT ', linecnt*increment: 5, '/', pagecnt:2,
        ord(errnr): 12);
End
(*ERROR*) ;


Procedure writeline (position (*LETZTES ZU DRUCKENDES ZEICHEN IM PUFFER*):
                     integer);

Var 
  i, j, tabcnt, maxchar: integer;
(*MARKIERT ERSTES ZU DRUCKENDES Z
EICHEN*)


Procedure usetabs(lastspaces: integer;crossing,renewing:boolean);

Var 
  lspaces: integer;
Begin
(*USETABS*)
            (*USE TABS AND SPACES TO MAKE INDENTATION*)
  tabcnt := lastspaces Div 8;
  lspaces := lastspaces Mod 8;
  If renewing Then
    Begin
      write(newsource, tabs:tabcnt*8);
      write(newsource, ' ': lspaces);
    End;
  If crossing Then
    If doting And ((reallincnt Mod 5) = 4) Then
      Begin
        ##                  write(crosslist, ' ', dots: lastspaces - 1);
        If lastspaces > 0 Then
          write (crosslist, ' ');
      End
  Else
    Begin
      write(crosslist, tabs: tabcnt*8);
      write (crosslist, ' ': lspaces);
             (*+++  IF lastspaces > 7 THEN              (*COMPENSATE FOR THE FIR
ST TAB*)
      write (crosslist, '  ');
      +++*)
    End;
End
(*USETABS*);

Begin
(*WRITELINE*)
  position := position - 2;
  If position > 0 Then
    Begin
      i := buffmark + 1;
      While (buffer [i] = ' ') And (i <= position) Do
        i := i + 1;
      buffmark := position;
      While (buffer [position] = ' ') And (i < position) Do
        position := position - 1;
      If i <= position Then
        Begin
          If Not programpresent Then
            Begin
              programpresent := true;
              header (blanks);
            End;
          newline;
          If crossing Then
            Begin
              If gotoinline Then
                Begin
                  write(crosslist, '****GOTO****');
                  gotoinline := false;
                  bmarktext := ' ';
                  emarktext := ' ';
                End
              Else
                Begin
                  If bmarktext <> ' ' Then
                    Begin
                      write (crosslist, bmarktext, bmarknr : 4, ' ');
                      bmarktext := ' ';
                    End
                  Else
                    write(crosslist,'      ');
                  If emarktext <> ' ' Then
                    Begin
                      write (crosslist,emarktext,emarknr : 4,' ');
                      emarktext := ' ';
                    End
                  Else
                    write (crosslist,'      ');
                End;
              write (crosslist, linecnt * increment : 5,' ');
            End;
          If Not oldspaces Then
            lastspaces := spaces;
          usetabs(lastspaces,crossing,renewing);
          maxchar := maxch+i-lastspaces-1;
          For j := i To position Do
            Begin
              If crossing And (j > maxchar) Then
                Begin
                  writeln(crosslist);
                  If reallincnt = maxline Then
                    header (blanks);
                  reallincnt := reallincnt+1;
                  usetabs(lastspaces+18+feed,crossing,false);
                  maxchar := maxch+j-lastspaces-1;
                End;
              ##                  If (Not flagger[j]) And
                                (* ('A' <= buffer[j]) AND
###                  (buffer[j] <= 'Z') *)
                                     (delsy[buffer[j]] = letterup) Then
                                    Begin
                                      If crossing Then
                                        ###                         write(crosslist,chr(ord(buffer[j
                                                                          ])-64(*+40B*)));
                                      If renewing Then
                                        ###                         write(newsource,chr(ord(buffer[j
                                                                          ])-64(*+40B*)));
                                    End
              Else
                ##                  If flagger[j] And (delsy[buffer[j]] = letterlo)  Then

                                      Begin
                                        If crossing Then
                                          ###                         write(crosslist,chr(ord(buffer
                                                                            [j])+64(*+40B*)));
                                        If renewing Then
                                          ###                         write(newsource,chr(ord(buffer
                                                                            [j])+64(*+40B*)));
                                      End
              Else
                Begin
                  If crossing Then
                    write (crosslist, buffer [j]);
                  If renewing Then
                    write(newsource, buffer[j]);
                End;
            End;
          If crossing Then
            writeln(crosslist);
          If renewing Then
            writeln(newsource);
          If ((linenb = '     ') And (position = bufflen)) Or (maxinc <=
             linecnt) Then
            newpage;
        End;
    End;
  lastspaces := spaces;
  oldspaces := false;
  thendo := false;
End
(*WRITELINE*) ;


Procedure setlastspaces(i: integer);
Begin
  oldspaces := true;
  ##      lastspaces := 0 ;
  If i > 0 Then  lastspaces := i ;
(*max(0,i);*)
End;
        (*INPUT PROCEDURES:*) (*INSYMBOL[*) (*READBUFFER*)

Procedure insymbol ;

Label 1;

Var 
  oldspacesmark,            (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG V
ON KOMMENTAREN*)
  i: integer;



Procedure readbuffer;
            (*READS A CHARACTER FROM THE INPUT BUFFER*)


Procedure readline;

(*HANDLES LEADING BLANKS AND BLANK LINES, READS NEXT NONBLANK LI
NE
                 (WITHOUT LEADING BLANKS) INTO BUFFER*)

Label 111 ;

Var 
  ch : char;
Begin
(*READLINE*)
                (*ENTERED AT THE BEGINNING OF A LINE*)
  Repeat
    While eoln (oldsource) And Not eof (oldsource) Do
      Begin
                        (*IS THIS A PAGE MARK?*)
        ##                     "getlinenr (oldsource,linenb);
        "
        readln(oldsource);
        If (linenb = '     ') And programpresent Then
          newpage
        Else
          If programpresent Then
            Begin
                                (*HANDLE BLANK LINE*)
              newline;
              If crossing Then
                writeln (crosslist,"chr(ht)"' ': 12,linecnt *
                                                 increment : 5);
              If renewing Then
                writeln(newsource);
              If maxinc <= linecnt Then
                newpage;
            End;
      End;
    read(oldsource, ch);
  Until (ch <> ' ') Or (eof (oldsource));
  bufflen := 0;
                (*READ IN THE LINE*)
  ##            (*LOOP *)  Repeat
                             bufflen := bufflen + 1;
                             buffer [bufflen] := ch;
                             flagger[bufflen] := nonrcase;
                             ##            (*EXIT*) If (eoln (oldsource) Or (bufflen = oldwidth))
                                                      Then GOTO 111 ;
                             read(oldsource, ch);
                  (*END*)
  Until FALSE ;
  111:
       buffer[bufflen+1] := ' ';
(*SO WE CAN ALWAYS BE ONE CHAR AHEAD*)
  If Not eoln (oldsource) Then
    error(linetoolong)
  Else
    If Not eof (oldsource) Then
      Begin
        ##                     "getlinenr (linenb);
        "
        readln(oldsource);
      End;
  bufferptr := 1;
  buffmark := 0;
End
(*READLINE*) ;

Begin
(*READBUFFER*)
            (*IF READING PAST THE EXTRA BLANK ON THE END, GET A NEW LINE*)
  If eoline Then
    Begin
      writeline (bufferptr);
      ch := ' ';
      If eof (oldsource) Then
        eob := true
      Else
        readline;
    End
  Else
    Begin
      ch := buffer [bufferptr];
      bufferptr := bufferptr + 1;
    End;
  eoline := bufferptr = bufflen + 2;
End
(*READBUFFER*) ;

            (*RESWORD*) (*FINDNAME*) (*PARENTHESE*)

Function resword: boolean ;
            (*DETERMINES IF THE CURRENT IDENTIFIER IS A RESERVED WORD*)
##

Label 222 ;

Var 
  i,j: integer;
  lid : alfa ;
Begin
(*RESWORD*)
  ##          resword := false;
  lid := sy ;
  ##          For i := 1 To 10 Do
                ##            If delsy[lid[i]] = letterlo Then lid[i] := chr( ord(lid[i]) +64) ;
  ##          For i:=resnum[lid[1]] To resnum[succ(lid[1])] - 1 
                Do
                ##              If reslist[ i ] = lid Then
                                  Begin
                                    resword := true;
                                    syty := ressy [i];
                                    ##               (* i:=resnum[succ(sy[1])]; ** BUG 1 **   *)
                                    For j:=bufferptr-syleng-1 To bufferptr-2 Do
                                      flagger[j] := rescase;
                                    ##                   GOTO 222;
                                  End;
  ##          222:
End
(*RESWORD*) ;


##      Procedure findname "(curproc: listptrty)" (*does not seem to be used*);

Var 
  lptr: listptrty;
(*ZEIGER AUF DEN VORGAENGER IM BAUM*)
  bptr,
  zptr : lineptrty;
(*ZEIGER AUF DIE VORLETZTE ZEILENNUMMER
IN EINER KETTE*)
  found,                  (*SET AFTER IDENTIFIER IS FOUND*)
  right: boolean;
(*MERKVARIABLE FUER DIE VERZWEIGUNG IM B
AUM*)
  indexch : char;
(*INDEXVARIABLE FUER DAS FELD DER STARTZ
EIGER (FIRSTNAME)*)

Begin
(*FINDNAME*)
  indexch := sy [1];
  listptr := firstname [indexch];
            (*SEARCH IN THE TREE FOR THE IDENTIFIER*)
  found := false;
  While Not found And (listptr <> Nil) Do
    Begin
      lptr := listptr;
      If sy = listptr@.name Then
        Begin
          found := true;
          ##                  If "(listptr@.profunflag In ['P', 'F'])"(Not declaring) And
                                 ##                    ((listptr@.profunflag = 'P')Or(listptr@.
                                 profunflag = 'F'))
                                Then
                                Begin
                                  new (workcall);
                                  workcall@.whom := listptr@.procdata;
                                  workcall@.nextcall := Nil;
                                End;
          zptr := listptr@.last;
          If (zptr@.linenr <> linecnt+1) Or (zptr@.pagenr <> pagecnt)
            Then
            Begin
              new (listptr@.last);
              With listptr@.last@ Do
                Begin
                  linenr := linecnt + 1;
                  pagenr := pagecnt;
                  contlink := Nil;
                  If declaring Then
                    declflag := 'D'
                  Else
                    declflag := ' ';
                End;
              zptr@.contlink := listptr@.last;
            End
          Else
            zptr@.declflag := 'M';
        End
      Else
        If sy > listptr@.name Then
          Begin
            listptr := listptr@.rlink;
            right := true;
          End
      Else
        Begin
          listptr := listptr@.llink;
          right := false;
        End;
    End;
  If Not found Then
    Begin
(*UNKNOWN IDENTIFIER*)
      new (listptr);
      With listptr@ Do
        Begin
          name := sy;
          llink := Nil;
          rlink := Nil;
          profunflag := ' ';
          externflag := ' ';
          procdata := Nil;
        End;
      If firstname [indexch] = Nil Then
        firstname [indexch] := listptr
      Else
        If right Then
          lptr@.rlink := listptr
      Else
        lptr@.llink := listptr;
      With listptr@ Do
        Begin
          new (first);
          With first@ Do
            Begin
              linenr := linecnt + 1;
              pagenr := pagecnt;
              contlink := Nil;
              If declaring Then
                declflag := 'D'
              Else
                declflag := ' ';
            End;
          last := first ;
        End;
    End;
End
(*FINDNAME*) ;

Procedure insertcall;

Var 
  thiscall: calledty;
  repeated,               (*SET IF SY IS A PROC-NAME AND IS ALREAD
Y IN THE CALL SEQUENCE*)
  finished: boolean;
(*SET WHEN DONE CHECKING THE CALL SEQUEN
CE*)

Begin
(*INSERTCALL*)
  If locprocstl@.firstcall = Nil Then
    locprocstl@.firstcall := workcall
  Else
    Begin
      thiscall := locprocstl@.firstcall;
      repeated := false;
      finished := false;
      While (Not finished) And (Not repeated) Do
        If thiscall@.whom@.procname@.name = workcall@.whom@.procname
           @.name Then
          repeated := true
        Else
          If thiscall@.nextcall = Nil Then
            finished := true
        Else
          thiscall := thiscall@.nextcall;
      If Not repeated Then
        thiscall@.nextcall := workcall;
    End;
  workcall := Nil;
End
(*INSERTCALL*);


Procedure parenthese (which: symbol);
            (*HANDLES THE FORMATTING OF PARENTHESES, EXCEPT THOSE IN VARIANT PAR
TS OF RECORDS*)

Var 
  oldspacesmark : integer;
(*ALTER ZEICHENVORSCHUB BEI FORM
ATIERUNG VON KLAMMERN*)
Begin
(*PARENTHESE*)
  If variant_level = 0 Then
    Begin
      oldspacesmark := spaces;
      If Not oldspaces Then
        setlastspaces (spaces);
      spaces := lastspaces + bufferptr - buffmark - 2;
                (*SKIP STUFF UNTIL WE SEEM TO BE OUT OF THE EXPRESSION*)
      If declaring Then
        Repeat
          insymbol;
          Case syty Of 
            colon: declaring := false;
            semicolon: declaring := true;
          End;
        Until syty In [externsy..rparent,labelsy..typesy,initprocsy
              ..exitsy,dosy..forwardsy]
      Else
        Repeat
          insymbol
        Until syty In [externsy..rparent,labelsy..typesy,initprocsy
              ..exitsy,dosy..forwardsy];
      spaces := oldspacesmark;
      oldspaces := true;
      If syty = which Then
        insymbol
      Else
        error(missgrpar);
    End;
End
(*PARENTHESE*) ;
            (*DOCOMMENT*) (*]INSYMBOL*)


Procedure docomment (dellength: integer; firstch, secondch: char;
                     cleaning: boolean);
##

Var temposp : boolean ;

Procedure expand (here: integer; firstch, secondch: char);

Var 
  i: integer;

Begin
(*EXPAND*)
  bufferptr := here + 2;
  bufflen := bufflen + 1;
  For i := bufflen + 1 Downto here + 2 Do
    buffer [i] := buffer [i-1];
  buffer [here] := firstch;
  buffer [here + 1] := secondch;
End
(*EXPAND*);
Procedure dumpit;

Var i: integer;
Begin
  write (tty, '<');
  For i := 1 To bufflen Do
    write (tty, buffer[i]);
  writeln (tty);
  writeln (tty,'<',' ':bufferptr -1, '@');
End;

Begin
(* DOCOMMENT *)
  oldspacesmark := spaces;
  If oldspaces Then
    spaces := lastspaces
  Else
    lastspaces := spaces;
  spaces := spaces + bufferptr - 1;
  oldspaces := true;
  If dellength = 2 Then
    Begin
      If cleaning Then
        Begin
          buffer [bufferptr - 1] := '(';
          buffer [bufferptr] := '*';
        End;
      ##              readbuffer ;
      flagger[bufferptr] := comcase ;
      readbuffer ;
                (* skip over comment beginning bracket *)
      ##              If ch = '%' Then
                        ##              Repeat
                                          readbuffer;
                                          flagger[bufferptr] := comcase;
                                          ##                If ch <> '*' Then
                                                              ##
                                                              Begin
                                                                ##                  If ch = 'X' Then
                                                                                      ##
                                                                                      Begin
                                                                                        readbuffer;
                                                                                        crossing := 
                                                                                                  ch
                                                                                                   =
                                                                                                 '+'
                                                                                      End
                                                                                      ##
                                                                Else If ch = 'F' Then
                                                                       ##
                                                                       Begin
                                                                         readbuffer;
                                                                         renewing := ch = '+';
                                                                       End
                                                                       ##
                                                                Else If ch = 'R' Then
                                                                       ##
                                                                       Begin
                                                                         readbuffer;
                                                                         rescase := ch = '+'
                                                                       End
                                                                       ##
                                                                Else If ch = 'C' Then
                                                                       ##
                                                                       Begin
                                                                         readbuffer ;
                                                                         comcase := ch = '+' ;
                                                                       End
                                                                       ##
                                                                Else If ch = 'N' Then
                                                                       ##
                                                                       Begin
                                                                         readbuffer ;
                                                                         nestcomments := ch ='+'
                                                                       End
                                                                       ##
                                                                Else If ch='I' Then
                                                                       ##
                                                                       Begin
                                                                         readbuffer ;
                                                                         nonrcase := ch = '+'
                                                                       End
                                                                       ##
(*ELSE IF ch = 'S' THEN
##                      BEGIN  readbuffer ;  SAVEREGS := ch <> '-'  END
##                      ELSE IF ch = 'F' THEN
##                      BEGIN readbuffer ;  SAVEFPRS := ch <> '-' ;
##                      END  *)
                                                                ;
                                                                ##                  readbuffer
                                                                ##
                                                              End
                                                              ##
                        Until ch <> ',' ;
      ##
      ##          (*  REPEAT   *)
      ##              While Not((ch = secondch) And (buffer[bufferptr-2] = firstch)
                            ##                        Or eob)  Do
                        ##
                        Begin
                          ##                  If nestcomments Then
                                                ##                    If (ch = '(') And (buffer[
                                                                         bufferptr] = '*') Then
                                                                        ##
                                                                        Begin
                                                                          ##
                                                                          temposp := oldspaces ;
                                                                          ##
                                                                          docomment(2, '*', ')',
                                                                                    false) ;
                                                                          ##
                                                                          oldspaces := temposp;
                                                                          ##
                                                                          readbuffer;
                                                                          ##
                                                                        End;
                          ##
                          flagger[bufferptr] := comcase;
                          readbuffer;
                          ##
                          ##
                        End
(* while .. *) ;
      ##
      (*  UNTIL (ch = secondch) AND (buffer[bufferptr-2] = firstch) OR eob
;           *)
      If cleaning Then
        Begin
          buffer [bufferptr - 2] := '*';
          buffer [bufferptr - 1] := ')';
        End;
    End
  Else
    Begin
      If cleaning Then
        expand (bufferptr - 1,'(','*');
      Repeat
        flagger[bufferptr] := comcase;
        readbuffer;
      Until (ch = firstch) Or eob;
      If cleaning Then
        expand (bufferptr - 1, '*', ')');
    End;
  spaces := oldspacesmark;
  oldspaces := true;
End
(*DOCOMMENT*);

Begin
(*INSYMBOL*)
  syleng := 0;
  "While (ch In ['_', '(', ' ', '$', '?', '!', '@', '%', '/', '\']) And Not
         eob  Do
     "
     ###     While ((delsy[ch] In [spacech, dquotech, skipch, lparent])
                   ###           And (Not eob)) Do
               ##
(* WHILE  ( (ch = '_') OR (ch = '(') OR (ch = ' ') OR (ch = '$') OR
##              (ch = '?') OR (ch = '!') OR (ch = '@') OR (ch = '%') OR
##              (ch = '/') OR (ch = '\') OR (ch = '#') OR (ch = '"') )
##              AND (NOT eob)  DO  *)
               Begin
                 If (ch = '(') And (buffer[bufferptr] = '*') Then
                   docomment (2,'*',')', false)
                 Else
                   ##
(* IF (ch = '/') AND (buffer[bufferptr] = '*') THEN
                    docomment (2,'*','/',cleaning)
##              ELSE   *)
                   ##                  If ch = '"' Then  docomment(1, '"', ' ', cleaning)
                                         ##
                 Else  If ch = '#' Then buffer[bufferptr-1] := ' '
                                                               ##
(*ELSE
                    IF ch = '%' THEN
##                    IF   (buffer[bufferptr] >= '0') AND
##                         (buffer[bufferptr] <= '9') then
                            if anyversion OR (ord(buffer[bufferptr]) - ord ('0')
 = goodversion) then
                                bufferptr := bufferptr + 1
                            else
                                docomment (1,'\','\',cleaning)
                        else
##                      docomment (1,'\','\',cleaning)    *)
                                                               ##
                 Else  If ch = '#' Then buffer[bufferptr-1] := ' '
                 Else
                   ##                      If (ch = '(') (* OR (ch = '/') *) Then
                                             GOTO 1;
                 readbuffer;
               End;
  ##    " Case ch Of 
            'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
            'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
            'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
            ##          'Z': "
                             ##   (*  IF (ch >= 'A') AND (ch <= 'Z')  THEN  *)
                             ###
                             ###    Case delsy[ch] Of 
                                      ###
                                      ###    letterup, letterlo :
                                                                  Begin
                                                                    syleng := 0;
                                                                    sy := '          ';
                                                                    Repeat
                                                                      syleng := syleng + 1;
                                                                      If syleng <= 10 Then
                                                                        sy [syleng] := ch;
                                                                      readbuffer;
                                                                      ##
(*   UNTIL NOT (((ch >= '0') AND (CH <= '9')) OR
##                      ((ch >= 'A') AND (ch <= 'Z')) OR (ch = '_'));*)
                                                                      ###
                                                                    Until Not(delsy[ch] In [letterup
                                                                          , letterlo, digit,
                                                                          ###
                                                                          dollarch, undsch]) ;
                                                                    If Not resword Then
                                                                      Begin
                                                                        syty := ident ;
                                                                        ##                findname"(
                                                                                             curproc
                                                                        )";
                                                                      End
                                                                      ##
                                                                  End ;
                                      ##    (* ELSE IF  (ch >= '0') AND (ch <= '9') THEN *)
                                      ##        " '0', '1', '2', '3', '4', '5', '6', '7', '8',
                                      '9': "

                                           ##          digit :
                                                               Begin
                                                                 Repeat
                                                                   syleng := syleng + 1;
                                                                   readbuffer;
                                                                 Until Not (('0' <= ch) And (ch <=
                                                                       '9'));
                                                                 syty := intconst;
                                                                 If ch = 'B' Then
                                                                   Begin
                                                                     flagger[bufferptr-1] := true;
                                                                     readbuffer;
                                                                   End
                                                                 Else
                                                                   Begin
                                                                     If ch = '.' Then
                                                                       Begin
                                                                         Repeat
                                                                           readbuffer
                                                                         Until Not (('0' <= ch) And
                                                                               (ch <= '9'));
                                                                         syty := othersy;
                                                                         syleng := 0;
(*REALS CAN'T BE LABELS*)
                                                                       End;
                                                                     If ch = 'E' Then
                                                                       Begin
                                                                         readbuffer;
                                                                         If (ch = '+') Or (ch = '-')
                                                                           Then
                                                                           readbuffer;
                                                                         While ('0' <= ch) And (ch
                                                                               <= '9') Do
                                                                           readbuffer;
                                                                         syty := othersy;
                                                                         syleng := 0;
(*REALS CAN'T BE LABELS*)
                                                                       End;
                                                                   End;
                                                                 ##
                                                               End  ;
                                      ##     (* ELSE IF ch = ''''  THEN  *)
                                      ###       quotech :
                                                          Begin
                                                            syty := strgconst;
                                                            Repeat
                                                              ###
                                                              (* flagger[bufferptr]:=strcase; *)
                                                              ###
                                            (*this ensures that Strings will not be up/low shifted*)
                                                              ###                flagger[bufferptr] 
                                                              := delsy[buffer[bufferptr]] = letterup
                                                              ;
                                                              readbuffer;
                                                            Until (ch = '''') Or eob Or eoline;
                                                            If ch <> '''' Then
                                                              error(missgquote);
                                                            readbuffer;
                                                            ##
                                                          End ;
                                      ##
(*  ELSE IF ch = '"' THEN
              BEGIN
              REPEAT
                  readbuffer
##            UNTIL NOT ((ch >= '0') AND (ch <= '9')) "(digits + ['A'..'F']))";
              syty := intconst;
##            END     *)
                                      ##     (* ELSE IF ch = ' ' THEN *)

                                      ###    spacech : syty := eobsy ;
(*END OF FILE*)
                                      ##     (* ELSE   *)  (*OTHERS*)

                                      ###    othersy, lparent, rparent, lbracket, rbracket,
                                      ###    semicolon, point, colon, eqlsy :
                                                                              Begin
                                                                                1:
                                                                                   syty := delsy [ch
                                                                                           ];
                                                                                readbuffer;
                                                                                If (syty = colon)
                                                                                   And (ch = '=')
                                                                                  Then
                                                                                  Begin
                                                                                    workcall := Nil;
                                                                                    syty := othersy;
                                                                                    readbuffer;
                                                                                  End
                                                                                Else
                                                                                  If syty In [
                                                                                     lparent,
                                                                                     lbracket] Then
                                                                                    If syty =
                                                                                       lparent Then
                                                                                      parenthese (
                                                                                             rparent
                                                                                      )
                                                                                Else
                                                                                  parenthese (
                                                                                            rbracket
                                                                                  );
                                                                              End ;
                                      ##
                             End;
(* CASE delsy[ch] OF *)
            If workcall <> Nil Then
              insertcall;
  End
(*INSYMBOL*) ;

        (*"PARSING" PROCEDURES:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)

  Procedure recdef;

  Var 
    oldspacesmark  : integer;
(*ALTER ZEICHENVORSCHUB BEI FORMAT
IERUNG VON RECORDS*)


  Procedure casedef;

  Var 
    oldspacesmark  : integer;
(*ALTER ZEICHENVORSCHUB BEI FORM
ATIERUNG VON VARIANT PARTS*)


  Procedure parenthese;
                (*HANDLES THE FORMATTING OF PARENTHESES INSIDE VARIANT PARTS*)

  Var 
    oldspacesmark : integer;
(*SAVED VALUE OF 'SPACES'*)
  Begin
(*PARENTHESE*)
    oldspacesmark := spaces;
    If Not oldspaces Then
      setlastspaces (spaces);
    spaces := spaces + bufferptr - 2;
    declaring := true;
    insymbol;
    Repeat
      ##              If  Not (syty In [casesy, recordsy, semicolon, lparent,
                         ##                           eqlsy, colon])  Then  insymbol
                        ##
      Else
        Case syty Of 
          casesy  : casedef;
          recordsy : recdef;
          semicolon, lparent:
                              Begin
                                declaring := true;
                                insymbol;
                              End;
          eqlsy, colon:
                        Begin
                          declaring := false;
                          insymbol;
                        End;
          ##                     "OTHERS:  insymbol"
        End;
                    (*UNTIL WE APPARENTLY LEAVE THE DECLARATION*)
    Until syty In [strgconst..whilesy,rparent,labelsy..exitsy,dosy..
          beginsy,
          loopsy..forwardsy];
    spaces := oldspacesmark;
    oldspaces := true;
    If syty = rparent Then
      insymbol
    Else
      error(missgrpar);
  End
(*PARENTHESE*) ;

  Begin
(*CASEDEF*)
    variant_level := variant_level+1;
    oldspacesmark := spaces;
    If Not oldspaces Then
      setlastspaces (spaces);
    spaces := bufferptr - buffmark + lastspaces - syleng + 3;
    declaring := true;
    insymbol;
    declaring := false;
    Repeat
      If syty = lparent Then
        parenthese
      Else
        insymbol
    Until syty In [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy]
    ;
    spaces := oldspacesmark;
    variant_level := variant_level-1;
  End
(*CASEDEF*) ;

  Begin
(*RECDEF*)
    oldspacesmark := spaces;
    setlastspaces(spaces);
    spaces := bufferptr - buffmark + spaces - syleng - 2 + feed;
    declaring := true;
    insymbol;
    Repeat
      ##          If  Not(syty In [casesy, recordsy, semicolon, lparent,
                     ##                       eqlsy, colon])  Then  insymbol
                    ##
      Else
        Case syty Of 
          casesy   : casedef;
          recordsy : recdef;
          semicolon, lparent:
                              Begin
                                declaring := true;
                                insymbol;
                              End;
          eqlsy, colon:
                        Begin
                          declaring := false;
                          insymbol;
                        End;
          ##            " OTHERS   : insymbol "
        End;
    Until syty In [untilsy..exitsy,labelsy..endsy,dosy..beginsy];
    oldspaces := true;
    lastspaces := spaces - feed;
    spaces := oldspacesmark;
    If syty = endsy Then
      Begin
        declaring := true;
        insymbol;
      End
    Else
      error(missgenduntil);
  End
(*RECDEF*) ;
        (*STATEMENT[*) (*AND ITS PARTS*) (*]*)


  Procedure statement;

  Var 
    oldspacesmark,           (*SPACES AT ENTRY OF THIS PROCEDURE*)
    curblocknr : integer;
(*CURRENT BLOCKNUMBER*)


  Procedure endedstatseq(endsym: symbol;  markch: char);
  Begin
    statement;
    While syty = semicolon Do
      Begin
        insymbol;
        statement;
      End;
    While Not (syty In [endsym,eobsy,proceduresy,functionsy]) Do
      Begin
        error(enderrinblkstr);
        If Not (syty In begsym) Then
          insymbol;
        statement;
        While syty = semicolon Do
          Begin
            insymbol;
            statement;
          End;
      End;
    If forcing Then
      writeline(bufferptr-syleng);
    emarktext := markch;
    emarknr := curblocknr;
    If (endsym = endsy) Then
      If indentbegin = 0 Then
        setlastspaces(spaces-begexd)
    Else
      setlastspaces(spaces-indentbegin)
    Else
      setlastspaces(spaces - feed);
    If syty <> endsym Then
      error(missgenduntil);
  End
(*ENDEDSTATSEQ*);


  Procedure compstat;
  Begin
(*COMPSTAT*)
    If indentbegin = 0 Then
      If Not oldspaces Then
        setlastspaces (spaces-begexd)
    Else
      If Not oldspaces Then
        setlastspaces (spaces - indentbegin);
    bmarktext := 'B';
    insymbol;
    If forcing Then
      writeline(bufferptr-syleng);
    endedstatseq(endsy, 'E');
    If syty = endsy Then
      Begin
        insymbol ;
        writeline(bufferptr-syleng);
      End;
  End
(*COMPSTAT*) ;


  Procedure casestat;

  Label 333 ;

  Var 
    oldspacesmark : integer;
(*SAVED VALUE OF 'SPACES'*)

  Begin
(*CASESTAT*)
    bmarktext := 'C';
    If Not oldspaces Then
      setlastspaces (spaces-feed);
    insymbol;
    statement;
    If syty = ofsy Then
      writeline (bufferptr)
    Else
      error (missgof);
    ##        " LOOP " Repeat
                         Repeat
                           Repeat
                             insymbol
                           Until syty In [colon,functionsy..eobsy];
                           If syty = colon Then
                             Begin
                               oldspacesmark := spaces;
                               lastspaces := spaces;
                               spaces := bufferptr - buffmark + spaces - 4;
                               oldspaces := true;
                               thendo := true;
                               insymbol;
                               statement;
                               spaces := oldspacesmark;
                             End;
                         Until syty In endsym;
                         ##        " EXIT"If syty In [endsy,eobsy,proceduresy,functionsy] Then GOTO
                                            333;
                         error (enderrinblkstr);
                         ##
    Until FALSE "
  End
  ";
  ##        333:
                 writeline(bufferptr-syleng);
  emarktext := 'E';
  emarknr := curblocknr;
  If syty = endsy Then
    Begin
      insymbol ;
      writeline(bufferptr-syleng);
    End
  Else
    error (missgenduntil);
End
(*CASESTAT*) ;


Procedure loopstat;
Begin
(*LOOPSTAT*)
  bmarktext := 'L';
  If Not oldspaces Then
    setlastspaces (spaces - feed);
  insymbol;
  writeline(bufferptr-syleng);
  statement;
  While syty = semicolon Do
    Begin
      insymbol;
      statement;
    End;
  If syty = exitsy Then
    Begin
      writeline(bufferptr-syleng);
      oldspaces := true;
      lastspaces := spaces-feed;
      emarktext := 'X';
      emarknr := curblocknr;
      insymbol;
      insymbol;
    End
  Else
    error(missgexit);
  endedstatseq(endsy, 'E');
  If syty = endsy Then
    Begin
      insymbol ;
      writeline(bufferptr-syleng);
    End;
End
(*LOOPSTAT*) ;


Procedure ifstat;

Var 
  oldspacesmark: integer;

Begin
  oldspacesmark := spaces;
  bmarktext := 'I';
  If Not oldspaces Then
    setlastspaces (spaces - feed);
            (*DON'T INDENT THE 'IF'*)
            (*MAKE 'THEN' AND 'ELSE' LINE UP WITH 'IF' UNLESS ON SAME LINE*)
  spaces := lastspaces + bufferptr - buffmark + feed - 4;
  insymbol;
  statement;
(*WILL EAT THE EXPRESSION AND STOP ON A KEYWORD*)
  If syty = thensy Then
    Begin
      If Not oldspaces Then
        setlastspaces (spaces-feed);
      emarktext := 'T';
      emarknr := curblocknr;
      If forcing Then
        writeline(bufferptr)
      Else
        thendo := true;
                (*SUPPRESS FURTHER INDENTATION FROM A 'DO'*)
      insymbol;
      statement;
    End
  Else
    error (missgthen);
  If syty = elsesy Then
    Begin
      writeline(bufferptr-syleng);
      emarktext := 'S';
      emarknr := curblocknr;
      If Not oldspaces Then
        setlastspaces (spaces-feed);
      If forcing Then
        writeline(bufferptr)
      Else
        thendo := true;
      insymbol;
      statement;
    End;
  oldspaces := true;
(*PRESERVE INDENTATION OF STATEMENT*)
  writeline(bufferptr-syleng);
  spaces := oldspacesmark;
End
(*IFSTAT*) ;


Procedure labelstat;
Begin
(*LABELSTAT*)
  lastspaces := level * feed;
  oldspaces := true;
  insymbol;
  writeline(bufferptr-syleng);
End
(*LABELSTAT*) ;


Procedure repeatstat;
Begin
  bmarktext := 'R';
  If Not oldspaces Then
    setlastspaces (spaces - feed);
  insymbol;
  endedstatseq(untilsy, 'U');
  If syty = untilsy Then
    Begin
      insymbol;
      statement;
      writeline(bufferptr-syleng);
    End;
End
(*REPEATSTAT*) ;

Begin
(*STATEMENT*)
  oldspacesmark := spaces;
(*SAVE THE INCOMING VALUE OF SPACES TO BE ABLE
TO RESTORE  IT*)
  If syty = intconst Then
    Begin
      insymbol;
      If syty = colon Then
        labelstat;
    End;
  If syty In begsym Then
    Begin
      blocknr := blocknr + 1;
      curblocknr := blocknr;
      bmarknr := curblocknr;
      If Not thendo Then
        Begin
          writeline(bufferptr-syleng);
          If (syty <> beginsy) Then
            spaces := spaces + feed
          Else
            spaces := spaces + indentbegin;
        End;
      Case syty Of 
        beginsy : compstat;
        loopsy  : loopstat;
        casesy  : casestat;
        ifsy    : ifstat;
        repeatsy: repeatstat
      End;
    End
  Else
    Begin
      If forcing Then
        If syty In [forsy,whilesy] Then
          writeline(bufferptr-syleng);
      If syty = gotosy Then
        gotoinline := true;
      While Not (syty In [semicolon,functionsy..recordsy]) Do
        insymbol;
      If syty = dosy Then
        Begin
          If Not thendo Then
            Begin
              setlastspaces(spaces);
              spaces := spaces + feed;
              If Not forcing Then
                thendo := true;
            End;
          insymbol;
          statement;
          writeline(bufferptr-syleng);
        End;
    End;
  spaces := oldspacesmark;
End
(*STATEMENT*) ;

        (*]BLOCK*)

Begin
(*BLOCK*)
  Repeat
    insymbol
  Until syty In relevantsym;
  level := level + 1;
  curproc := listptr;
  spaces := level * feed;
    (*HANDLE NESTING LIST*)
  locprocstl := procstrucf;
  ##If procstrucdata.exists Then      (*** BUG 2 ***)
      With procstrucdata, item, procname@ Do
        ##    (*IF exists THEN*)
        Begin
          If procdata <> Nil Then
            Begin
              If externflag = 'F' Then
                procdata := Nil
              Else
                If externflag = ' ' Then
                  externflag := 'D';
              locprocstl := procdata;
            End;
          If procdata = Nil Then
            Begin
              If (syty In [forwardsy,externsy]) Then
                If syty = externsy Then
                  externflag := 'E'
              Else
                externflag := 'F';
              new(procstrucl@.nextproc);
              procstrucl := procstrucl@.nextproc;
              procdata := procstrucl;
              procstrucl@ := item;
              locprocstl := procstrucl;
            End;
          procstrucdata.exists := false
        End;
  Repeat
    fwddecl := false;
    While syty In decsym Do
      Begin
        writeline(bufferptr-syleng);
        setlastspaces(spaces-feed);
        If syty = programsy Then
          Begin
            insymbol;
            prog_name := sy;
            procstrucf@.procname := listptr;
            listptr@.procdata := procstrucf;
            listptr@.profunflag := 'M';
            writeln(tty);
            write(tty,'1', version:8,new_name:7,' [',prog_name,']  1..');
            If pagecnt > 1 Then
              For i := 2 To pagecnt Do
                write (tty, i:3,'..');
            ##               (* break(tty); *)
            declaring := false;
          End
        Else
          Begin
            declaring := true;
            If forcing Then
              writeline(bufferptr);
          End;
        Repeat
          insymbol;
          Case syty Of 
            semicolon, lparent : declaring := true;
            eqlsy, colon : declaring := false;
            recordsy: recdef;
          End;
        Until syty In relevantsym;
      End;
    While syty In prosym Do
      Begin
        writeline(bufferptr-syleng);
        setlastspaces(spaces-feed);
        If syty <> initprocsy Then
          Begin
            itisaproc := syty = proceduresy;
            declaring := true;
            insymbol;
            If itisaproc Then
              listptr@.profunflag := 'P'
            Else
              listptr@.profunflag := 'F';
            With procstrucdata, item Do
              Begin
                exists := true;
                procname := listptr;
                nextproc := Nil;
                linenr := linecnt+1;
                pagenr := pagecnt;
                proclevel := level;
                printed := false;
                firstcall := Nil;
              End;
          End;
        block;
        If syty = semicolon Then
          insymbol;
      End;
        (*FORWARD AND EXTERNAL DECLARATIONS MAY COME BEFORE 'VAR', ETC.*)
  Until Not fwddecl;
  If forcing Then
    writeline(bufferptr-syleng);
  level := level - 1;
  spaces := level * feed;
  If Not (syty In [beginsy,forwardsy,externsy,eobsy,langsy]) Then
    Begin
      If (level = 0) And (syty = point) Then
        nobody := true
      Else
        error (begerrinblkstr);
      While Not (syty In [beginsy,forwardsy,externsy,eobsy,langsy,point]) Do
        insymbol
    End;
  If syty = beginsy Then
    Begin
      declaring := false;
      locprocstl@.begline := linecnt + 1;
      locprocstl@.begpage := pagecnt;
      statement;
      locprocstl@.endline := linecnt + 1;
      locprocstl@.endpage := pagecnt;
    End
  Else
    If Not nobody Then
      Begin
        fwddecl := true;
        insymbol;
        If syty = langsy Then
          insymbol
      End;
  If programpresent And (level = 0) Then
    Begin
      If nobody Then
        Begin
          error (missgmain);
          errcount := errcount - 1;
        End;
      If syty <> point Then
        Begin
          error(missgpoint);
          Repeat
(*SKIP TEXT UNTIL END OF FILE OR END OF PROGRAM HIT*)
            Repeat
              insymbol
            Until (syty = endsy) Or (syty = eobsy);
            If syty = endsy Then
              insymbol;
          Until (syty = point) Or (syty = eobsy);
        End;
      writeline(bufflen+2);
      writeln(tty);
      writeln(tty);
      ##      writeln (tty,errcount:4,' ERROR(S) DETECTED');
(* break(tty); *)
    End;
End
(*BLOCK*) ;

Procedure print_xref_list;

Var 
  pred : listptrty;
  indexch : char;
(*LAUFVARIABLE FUER DAS FELD 'FIRSTNAME' ZUM AUS
DRUCKEN*)
  listpgnr : boolean;
(*TRUE IF THE SOURCE CONTAINS A PAGE MARK*)
  itemlen: integer;
(*LENGTH OF A PRINTED LINENUMBER, 9 OR 12*)
  thiscall : calledty;
  oldcrossing: boolean;


Procedure checkpage(heading: boolean);
Begin
  If reallincnt = maxline Then
    Begin
      If heading Then
        header (listptr@.name)
      Else
        header (blanks);
    End;
  reallincnt := reallincnt+1;
End
(*CHECKPAGE*);

Procedure writeprocname (procstrucl: procstructy; depth: integer; mark: char
                         ; numbering: boolean);
Begin
(*WRITEPROCNAME*)
  writeln(crosslist);
  checkpage(false);
  With procstrucl@, procname@ Do
    Begin
      If numbering Then
        ##              write (crosslist, linecnt * increment:6, '  ')
        ##
      Else write(crosslist, linenr*increment:6, '  ') ;
      ##
(* IF depth > 2 THEN
                write (crosslist, '. ',dots:depth-2)
            ELSE
##              write (crosslist, '.':depth);  *)
      ##          write  (crosslist, ' ': depth*3, name: 10, ' ':25-depth*3,
                          ' (', profunflag, ')', mark:2, externflag:2
                          ##                  ",chr(ht), linenr * increment : 8");
      ##          If numbering Then  write(crosslist, linenr*increment:10) ;
      If listpgnr Or (pagenr > 1) Then
        write(crosslist, ' / ',pagenr : 1);
      If (mark = ' ') And Not ((externflag = 'E') Or
         ##                                   (externflag = 'F')) Then
        Begin
          write (crosslist, begline * increment: 10);
          If listpgnr Then
            write (crosslist, ' / ', begpage: 1);
          ##              write (crosslist, endline * increment: 7);
          If listpgnr Then
            write (crosslist, ' / ', endpage:1);
        End;
    End;
End
(*WRITEPROCNAME*);

Procedure writelinenr (spaces : integer);

Var 
  link : lineptrty;
(*ZEIGER ZUM DURCHHANGELN DURCH DIE VERKETTUNG DER
 ZEILENNUMMERN*)
  maxcnt,             (*MAXIMUM ALLOWABLE VALUE OF COUNT*)
  count : integer;
(*ZAEHLT DIE GEDRUCKTEN ZEILENNUMMERN PRO ZEILE*)
Begin
(*WRITELINENR*)
  count := 0;
  maxcnt := (maxch+20 - spaces) Div itemlen;
(*ITEMS ARE ITEMLEN CHARS EAC
H*)
  link := listptr@.first;
  Repeat
    If count = maxcnt Then
      Begin
        writeln(crosslist);
        checkpage(true);
        write (crosslist, ' ' : spaces);
        count := 0;
      End;
    count := count + 1;
    write (crosslist, link@.linenr * increment : 6);
    If listpgnr Then
      write(crosslist, '/',link@.pagenr : 2);
    write (crosslist,link@.declflag,'  ');
    link := link@.contlink;
  Until link = Nil;
End
(*WRITELINENR*) ;

Procedure dumpcall (thisproc: procstructy; depth: integer);

Var 
  thiscall: calledty;

Begin
(*DUMPCALL*)
  linecnt := linecnt + 1;
  With thisproc@ Do
    If printed Then
      writeprocname (thisproc, depth,'*', true)
    Else
      Begin
        writeprocname (thisproc, depth, ' ', true);
        printed := true;
        linenr := linecnt;
        pagenr := pagecnt;
        thiscall := firstcall;
        While thiscall <> Nil Do
          Begin
            ##                  dumpcall (thiscall@.whom, depth + "4"1);
            thiscall := thiscall@.nextcall;
          End;
      End;
End
(*DUMPCALL*);
        (*]PRINT_XREF_LIST*)

Begin
(*PRINT_XREF_LIST*)
  oldcrossing := crossing;
  crossing := true;
  listpgnr := pagecnt > 1;
  If listpgnr Then
    itemlen := 12
  Else
    itemlen := 9;
  With firstname ['M']@ Do
(*DELETE 'MAIN'*)
    If rlink = Nil Then
      firstname ['M'] := llink
    Else
      Begin
        listptr := rlink;
        While listptr@.llink <> Nil Do
          listptr := listptr@.llink;
        listptr@.llink := llink;
        firstname ['M'] := rlink;
      End;
  indexch := 'a';
  While (indexch < 'Z') And (firstname [indexch] = Nil) Do
    indexch := succ (indexch);
  If firstname [indexch] <> Nil Then
    Begin
      If refing Then
        Begin
          pagecnt := pagecnt + 1;
          pagecnt2 := 0;
          header (blanks);
          writeln (crosslist,
                   ' CROSS REFERENCE LISTING OF IDENTIFIERS   ':46) ;
          writeln (crosslist,
                   ' **************************************   ':46) ;
          reallincnt := reallincnt + 3;
          For indexch := indexch To 'Z' Do
            While firstname [indexch] <> Nil Do
              Begin
                listptr := firstname [indexch];
                While listptr@.llink <> Nil Do
                  Begin
                    pred := listptr;
                    listptr := listptr@.llink;
                  End;
                If listptr = firstname [indexch] Then
                  firstname [indexch] := listptr@.rlink
                Else
                  pred@.llink := listptr@.rlink;
                writeln(crosslist);
                checkpage(true);
                write (crosslist, listptr@.profunflag, listptr@.name : 11);
                writelinenr (12);
              End;
          ##          writeln(crosslist) ;
        End;

      If procstrucl <> procstrucf Then
        Begin
          If decnesting Then
            Begin
              pagecnt := pagecnt + 1;
              pagecnt2 := 0;
              writeln (crosslist);
              header (blanks);
              writeln (crosslist,
                       ' NESTING OF PROCEDURE-FUNCTION DECLARATION':46) ;
              writeln (crosslist,
                       ' *****************************************':46) ;
              writeln (crosslist,
                       ' HEADERLINE, NAME, P/F, BEGINLINE, ENDLINE':46) ;
              reallincnt := reallincnt + 4;
              procstrucl := procstrucf;
              Repeat
                ##                  writeprocname (procstrucl, procstrucl@.proclevel"* 2",' ',
                                                   false);
                procstrucl := procstrucl@.nextproc;
              Until procstrucl = Nil;
            End;
          If callnesting Then
            Begin
              pagecnt := pagecnt + 1;
              pagecnt2 := 0;
              writeln (crosslist);
              header (blanks);
              writeln (crosslist,
                       ' NESTING OF PROCEDURE-FUNCTION CALLS      ':46);
              writeln (crosslist,
                       ' ***********************************      ':46);
              writeln (crosslist,
                       ' NAME, P/F, HEADLINE, BEGINLINE, ENDLINE  ':46) ;
              reallincnt := reallincnt + 4;
              linecnt := 0;
              procstrucl := procstrucf;
              While procstrucl <> Nil Do
                Begin
                  If Not procstrucl@.printed Then
                    dumpcall (procstrucl, 0);
                  procstrucl := procstrucl@.nextproc;
                End;
            End;
          ##          writeln(crosslist) ;
        End;
    End;
  crossing := oldcrossing;
End
(*PRINT_XREF_LIST*) ;

    (*MAIN PROGRAM*)

Begin
  # RESET(OLDSOURCE) ;
  # REWRITE(NEWSOURCE);
  # REWRITE(CROSSLIST) ;
  # REWRITE(TTY) ;
  checkoptions;
  ##"getstatus(oldsource,new_name,new_prot,new_ppn,new_dev);
  "

(*FIND MAX POSSIBLE LINE NUMBER WITH THIS INCREMENT*)
  ##increment := 1 ;
  maxinc := (99999 Div increment);
  If maxinc > 4000 Then
    maxinc := 4000;

  ##"LOOP" Repeat
             init;
             block;
             ##"EXIT" If Not programpresent Or (syty = eobsy) Then GOTO 444;
             If refing Or decnesting Or callnesting Then
               print_xref_list;
             ##  "dispose(heapmark);
             "    (*RELEASE THE ENTIRE HEAP*)
             rtime[0] := clock(1)-rtime[0];
             rtime[1] := rtime[0] Div 60000;
             rtime[2] := (rtime[0] Mod 60000) Div 1000;
             rtime[3] := rtime[0] Mod 1000;
             writeln(tty);
             writeln(tty,' RUNTIME:',rtime[1]:3,':',rtime[2]:2,'.',rtime[3]:3);
             ##   (* break(tty); *)
             ##
  Until FALSE "
End
";
##  444:
         ##   (* writeln(tty, bel);   break(tty); *)

         ##  "getnextcall (link_name, link_device);
##   If link_name <> '         ' Then
       ##     call (link_name, link_device);
"
End
(*PCROSS*).