home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / genapps / ifthen20.arj / IF-THEN.BAS next >
BASIC Source File  |  1992-01-02  |  25KB  |  774 lines
  1. '      ╔══════════════════════════════════════════════════════════════╗
  2. '      ║                                                              ║
  3. '      ║        The Structural Pest Control Utility --                ║
  4. '      ║        for your pesky IF-THEN, DO-LOOP, WHILE                ║
  5. '      ║        and SELECT mismatches ....                            ║
  6. '      ║                                                              ║
  7. '      ║                  I F - T H E N . B A S                       ║
  8. '      ║                                                              ║
  9. '      ║                            --  Howard Ballinger,   5-6-91    ║
  10. '      ║                                (CompuServe ID# 71121,776)    ║
  11. '      ╚══════════════════════════════════════════════════════════════╝
  12.  
  13. 'revised 08/91 Dan Kubala (CompuServe ID# 73230,1754)
  14. '        Allowed print of comment statements
  15. '        Ignore comment triggers chr$(39) and "REM" when in quotes
  16. '        Split multi-statement lines for processing
  17. '        Ignore split indicator (:,COLON) when in quotes, parens or comment
  18. '        Indent nested levels - put left brackets around nests
  19. '        Allow input from non-current directory (via APPEND)
  20. '              output (*.if-) allways in current directory.
  21. '        Include FOR-NEXT recognition
  22.  
  23. 'revised 12/91 Dan Kubala (CompuServe ID# 73230,1754)
  24. '        Included transfer statements (eg GOTO,RETURN,etc)
  25. '        Included pointer statements (eg GOSUB,RESTORE,etc)
  26. '        Identify Labels/Line Numbers, show their usage.
  27.  
  28.                             $COMPILE EXE
  29.                             $OPTION CNTLBREAK OFF
  30.                             $ERROR ALL OFF
  31.                             $LIB ALL OFF
  32.                             DEFINT A-Z
  33.  
  34.  CALL ReadNMatchColor
  35.  
  36.  dim SortTable$(500)
  37.  map Indent$$ * 12
  38.  
  39.  Shift$ = "  "
  40.  TEST$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.%&!#$|"
  41.  FlowStart$ = "~IF~DO~WHILE~SELECT~FOR~"
  42.  OneWordCmd$ = "~BEEP~CLEAR~CLOSE~CLS~END~RESET~RESUME~RETURN~RUN~" +_
  43.            "STOP~SYSTEM~"
  44.  LineLabel$ = "~"
  45.  GoToPtr$  = "~"
  46.  SubPtr$    = "~"
  47.  RestorePtr$ = "~"
  48.  
  49.  cls
  50.  IF COMMAND$ = "" THEN
  51.    PRINT
  52.    PRINT "   IF-THEN: The Structural Pest Control";
  53.    PRINT " Utility -- (Howard Ballinger, 5-91)"
  54.    PRINT STRING$ (80, 205);
  55.     INPUT "PowerBASIC File to Process"; F$
  56.    IF F$ = "" THEN END 1
  57.  ELSE
  58.    F$ = COMMAND$
  59.  END IF
  60.  
  61.  GOSUB FilesOpen
  62.  PRINT "  Opening "; InpFile$; " for input and "; OutFile$; " for output."
  63.  IF FileErr THEN BEEP: PRINT "FILE NOT FOUND": DELAY 2: END 1
  64.  Row = CSRLIN
  65.  GOSUB PrintHeader
  66.  
  67.  '--- get source records
  68.  DO UNTIL EOF (1)
  69.    LastLn = Ln
  70.    INCR Ln
  71.    LineNumb$ = "": ImaLabel = 0
  72.    Flag = 0: Pre = 0: Post = 0
  73.    LOCATE Row+1, 10: PRINT USING "Reading line #### ..."; Ln
  74.    LINE INPUT #1, L0$
  75.  
  76.    '--- left justify input line; create working line
  77.    L0$ = ltrim$ (L0$,any " "+chr$(9))
  78.    if L0$ = "" then goto NextLine
  79.    L0$ = rtrim$(L0$,any " "+chr$(9))
  80.  
  81.    '--- look for line NUMBER; strip it off
  82.    call LineNmbr (1,L0$,x$,Split)
  83.    if Split > 0 then
  84.       LineNumb$ = X$
  85.       L0$ = right$(L0$,len(L0$)-len(x$)-1)
  86.       Flag = 1: Pre = 0: Post = 0
  87.       if instr(LineLabel$, "~"+x$+"~") = 0 then
  88.      LineLabel$ = LineLabel$ + x$ + "~"
  89.       end if
  90.    end if
  91.    LW$ = ucase$(ltrim$(L0$,any " "+chr$(9)))
  92.  
  93.    '--- skip blank comment lines
  94.    if (left$(LW$,1) = chr$(39) and len(LW$) = 1) or _
  95.       (left$(LW$,3) = "REM" and len(LW$) = 3) then
  96.       goto NextLine
  97.    elseif left$(LW$,1) = chr$(39) or left$(LW$,4) = "REM " then
  98.       '--- print comment-only lines
  99.       L0L$ = L0$
  100.       LWL$ = L0$
  101.       Flag = -1: Pre = 0: Post = 0
  102.       goto PrintLine
  103.    else
  104.       '--- whack off trailing comments in work line
  105.       call EraseCmnt(LW$,"'")
  106.       call EraseCmnt(LW$,"REM")
  107.       TagCmnt$ = mid$(L0$,len(LW$)+1)
  108.       LW$ = RTRIM$ (LW$,any " "+chr$(9))
  109.    end if
  110.  
  111.    '--- Now check for continued lines & splice them together ...
  112.    IF RIGHT$ (LW$, 1) = "_" THEN
  113.       DO
  114.      LW$ = RTRIM$ (LW$,any "_ "+chr$(9)): L0$ = mid$(L0$,1,len(LW$))
  115.      LINE INPUT #1, L0C$
  116.      L0C$ = LTRIM$(L0C$,any " "+chr$(9))
  117.      L0C$ = rtrim$(L0C$,any " "+chr$(9))
  118.      '--- look for line NUMBER; strip it off
  119.      call LineNmbr (1,L0C$,x$,Split)
  120.      if Split > 0 then
  121.         L0C$ = ltrim$(right$(L0C$,len(L0C$)-len(x$)-1))
  122.      end if
  123.      LWC$ = ucase$(L0C$)
  124.  
  125.      '--- look for separators between continuation statements
  126.      if instr(Test$,right$(LW$,1)) > 0 and_
  127.         instr(Test$,left$(LWC$,1)) > 0 then
  128.         LW$ = LW$+" ": L0$ = L0$+" "
  129.      end if
  130.      LW$ = LW$ + LWC$: L0$ = L0$ + L0C$
  131.      call EraseCmnt(LW$,"'")
  132.      call EraseCmnt(LW$,"REM")
  133.      LW$= RTRIM$ (LW$,any " "+chr$(9)): '.....L0$= rtrim$(mid$(L0$,1,len(LW$)))
  134.       LOOP UNTIL RIGHT$ (LW$, 1) <> "_"
  135.    END IF
  136.  
  137.    '--- split multi-statement lines; process singles
  138.    LWL$ = LW$: '......L0L$ = L0$
  139.    call SplitLine (LWL$,LWR$,Split)
  140.    '--- split input/output image as is done (sic) to working image
  141.    L0L$ = mid$(L0$,1,len(LWL$))
  142.    if Split > 0 then
  143.       L0R$ = ltrim$(mid$(L0$,split+1),any " "+chr$(9))
  144.    else
  145.       L0R$ = ""
  146.    end if
  147.  
  148.    while LWL$ > ""    '--- statement(s) remaining in line
  149.       '--- identify line labels
  150.       if LWR$ = "" and Split > 0 then
  151.      OffSet = 1: x$=fnFindNextWord$(LW$)
  152.      if X$+":" = LWL$ then
  153.         Flag = 1: Pre = 0: Post = 0
  154.         ImaLabel = 1
  155.         if instr(LineLabel$, "~"+x$+"~") = 0 then
  156.            LineLabel$ = LineLabel$ + x$ + "~"
  157.         end if
  158.         goto PrintLine
  159.      end if
  160.       end if
  161.  
  162.       '--- add space so we can look left for whole word eg- "else "
  163.       LWL$ = ucase$ (rtrim$ (LWL$,any " "+chr$(9))) + " "
  164.  
  165.      '--- check for Label/Line Number transfers & pointers
  166.       call Chk4Xfr (Lwl$,L0L$,Flag,Pre,Post,GoToPtr$)
  167.       call Chk4Ptr (Lwl$,L0L$,Flag,Pre,Post,SubPtr$,RestorePtr$)
  168.  
  169.       '--- Conditional Processing
  170.       IF LEFT$ (LWL$, 3)  = "IF " then
  171.      Flag = -1: Pre= 0: Post= 0
  172.      if RIGHT$ (LWL$, 6) = " THEN " then
  173.         Post = 1
  174.      else
  175.         call ArgInQuote (LWL$," THEN ",Split)
  176.         OffSet = Split+6
  177.         Action$ = mid$(LWL$,OffSet)
  178.         x$ =  FnFindNextWord$ (LWL$)
  179.         '--- create indent if action is a flow starter
  180.         if instr(FlowStart$,"~"+x$+"~") > 0 then
  181.            Post= 1
  182.         else
  183.            '--- identify implied GOTO
  184.            if x$= "" then call LineNmbr (1,Action$,x$,Split)
  185.            x$ = rtrim$(ltrim$(x$)): Action$ = rtrim$(ltrim$(Action$))
  186.            if x$ = Action$ then
  187.           if instr(left$(x$,1),any "0123456789") > 0 or _
  188.              instr(OneWordCmd$,"~"+x$+"~") = 0 and _
  189.              x$ > "" then
  190.              L0L$ = L0L$ + " " +string$(4,chr$(16))
  191.              if instr(GoToPtr$, "~"+x$+"~") = 0 then
  192.             GoToPtr$ = GoToPtr$ + x$ +"~"
  193.              end if
  194.           end if
  195.            end if
  196.         end if
  197.     end if
  198.  
  199.       '--- Flow Control Statements
  200.       elseif left$ (LWL$, 4) = "$IF "        then: Flag= -1: Pre= 0: Post= 1
  201.       elseIF LEFT$ (LWL$, 3) = "DO "         then: Flag= -1: Pre= 0: Post= 1
  202.       elseIF LEFT$ (LWL$, 6) = "WHILE "      then: Flag= -1: Pre= 0: Post= 1
  203.       elseIF LEFT$ (LWL$, 7) = "SELECT "     THEN: Flag= -1: Pre= 0: Post= 1
  204.       elseIF LEFT$ (LWL$, 4) = "FOR "        THEN: Flag= -1: Pre= 0: Post= 1
  205.  
  206.       elseif left$ (LWL$, 6) = "$ELSE "      then: Flag= -1: Pre= 1: Post= 1
  207.       elseIF LEFT$ (LWL$, 5) = "ELSE "       THEN: Flag= -1: Pre= 1: Post= 1
  208.       elseIF LEFT$ (LWL$, 7) = "ELSEIF "     THEN: Flag= -1: Pre= 1: Post= 1
  209.       elseIF LEFT$ (LWL$, 5) = "CASE "       THEN: Flag= -1: Pre= 1: Post= 1
  210.  
  211.       elseif left$ (LWL$, 7) = "$ENDIF "     then: Flag= -1: Pre= 1: Post= 0
  212.       elseIF LEFT$ (LWL$, 5) = "LOOP "       THEN: Flag= -1: Pre= 1: Post= 0
  213.       elseIF LEFT$ (LWL$, 5) = "WEND "       THEN: Flag= -1: Pre= 1: Post= 0
  214.       elseIF LEFT$ (LWL$, 11)= "END SELECT " THEN: Flag= -1: Pre= 1: Post= 0
  215.       elseIF LEFT$ (LWL$, 7) = "END IF "     THEN: Flag= -1: Pre= 1: Post= 0
  216.       elseIF LEFT$ (LWL$, 5) = "NEXT "       THEN: Flag= -1: Pre= 1: Post= 0
  217.  
  218.       '--- Inclusion Indicators
  219.       elseIF LEFT$ (LWL$, 9) = "$INCLUDE "   THEN: Flag= -1: Pre= 0: Post= 0
  220.       elseif left$ (LWL$, 8) = "$INLINE "    then: Flag= -1: Pre= 0: Post= 0
  221.       elseif left$ (LWL$, 6) = "$LINK "      then: Flag= -1: Pre= 0: Post= 0
  222.       elseif left$ (LWL$, 8) = "DECLARE "    then: Flag= -1: Pre= 0: Post= 0
  223.  
  224.       '--- Procedure Definers
  225.       elseif left$ (LWL$, 4) = "SUB "        then: Flag= -1: Pre= 0: Post= 0
  226.       elseif left$ (LWL$, 4) = "DEF "        then: Flag= -1: Pre= 0: Post= 0
  227.       elseif left$ (LWL$, 9) = "FUNCTION "   then: Flag= -1: Pre= 0: Post= 0
  228.       elseif left$ (LWL$, 8) = "END SUB "    then: Flag= -1: Pre= 0: Post= 0
  229.       elseif left$ (LWL$, 8) = "END DEF "    then: Flag= -1: Pre= 0: Post= 0
  230.       elseif left$ (LWL$,13) = "END FUNCTION " then: Flag=-1: Pre= 0: Post= 0
  231.  
  232.       '--- Comment Identifiers
  233.       elseif left$ (LWL$, 1) = chr$(39)      then: Flag= -1: Pre= 0: Post= 0
  234.       elseif left$ (LWL$, 4) = "REM "        then: Flag= -1: Pre= 0: Post= 0
  235.  
  236.       '--- Procedure Transfers
  237.       elseif left$ (LWL$, 3) = "ON "         then: Flag= -1: Pre= 0: Post= 0
  238.       elseif left$ (LWL$, 5) = "EXIT "       then: Flag= -1: Pre= 0: Post= 0
  239.       elseif left$ (LWL$, 5) = "GOTO "       then: Flag= -1: Pre= 0: Post= 0
  240.       elseif left$ (LWL$, 6) = "GOSUB "      then: Flag= -1: Pre= 0: Post= 0
  241.       elseif left$ (LWL$, 5) = "CALL "       then: Flag= -1: Pre= 0: Post= 0
  242.       elseif left$ (LWL$, 7) = "RETURN "     then: Flag= -1: Pre= 0: Post= 0
  243.       elseif left$ (LWL$, 7) = "RESUME "     then: Flag= -1: Pre= 0: Post= 0
  244.  
  245.       '--- Program Transfers
  246.       elseif left$ (LWL$, 6) = "CHAIN "      then: Flag= -1: Pre= 0: Post= 0
  247.       elseif left$ (LWL$, 8) = "EXECUTE "    then: Flag= -1: Pre= 0: Post= 0
  248.       elseif left$ (LWL$, 4) = "RUN "        then: Flag= -1: Pre= 0: Post= 0
  249.       elseif left$ (LWL$, 6) = "SHELL "      then: Flag= -1: Pre= 0: Post= 0
  250.       elseif left$ (LWL$, 5) = "STOP "       then: Flag= -1: Pre= 0: Post= 0
  251.       elseif left$ (LWL$, 7) = "SYSTEM "     then: Flag= -1: Pre= 0: Post= 0
  252.       elseif left$ (LWL$, 4) = "END "        then: Flag= -1: Pre= 0: Post= 0
  253.       end if
  254.  
  255. PrintLine:
  256.       IF Flag THEN
  257.       if ImaLabel = 1 then LineNumb$= L0L$: L0L$ = ""
  258.      if LastLn >< Ln then
  259.         if instr(left$(LineNumb$,1),any "0123456789") > 0 then
  260.            rset Indent$$ = LineNumb$
  261.         else
  262.            lset Indent$$ = LineNumb$
  263.         end if
  264.         LastLn = Ln
  265.         PRINT #2, USING$ ("#### ", Ln);
  266.         '--- put Tag Comment only on 1st part of statement
  267.         L0L$ = rtrim$(L0L$) + "  " + ltrim$(TagCmnt$): TagCmnt$ = ""
  268.      else
  269.         rset Indent$$ = ""
  270.         print #2, "   ";chr$(34);" ";
  271.      end if
  272.      print #2, Indent$$;" ";
  273.  
  274. '.....lprint Ln,flag;imalabel;linenumb$,mid$(L0L$,1,20)
  275.      on error goto BasicError
  276.      if Pre = 0 and Post = 1 then        'Do, While, Select, If-Then
  277.         Shift$ = left$(Shift$,len(Shift$)-2)
  278.         Shift$ = Shift$ + " "+chr$(218)
  279.         print #2, Shift$;ltrim$(L0L$,any " "+chr$(9))
  280.         Shift$ = left$(Shift$,len(Shift$)-2)
  281.         Shift$ = Shift$ + " "+chr$(179)+"  "
  282.      elseif Pre = 1 and Post = 1 then        'Else, ElseIf, Case
  283.         Shift$ = left$(Shift$,len(Shift$)-2)
  284.         print #2, Shift$;ltrim$(L0L$,any " "+chr$(9))
  285.         Shift$ = Shift$ + "  "
  286.      elseif Pre = 1 and Post = 0 then        'Loop, Wend, End Select, End If
  287.         Shift$ = left$(Shift$,len(Shift$)-4)
  288.         Shift$ = Shift$ + " "+chr$(192)
  289.         print #2, Shift$;ltrim$(L0L$,any " "+chr$(9))
  290.         Shift$ = left$(Shift$,len(Shift$)-2)
  291.         Shift$ = Shift$ + "  "
  292.      else
  293.         print #2, Shift$;ltrim$(L0L$,any " "+chr$(9))
  294.      end if
  295.      on error goto 0
  296.       END IF
  297.       Flag = 0: ImaLabel = 0
  298.  
  299.       LWL$ = LWR$: '...L0L$ = L0R$
  300.       call SplitLine (LWL$,LWR$,Split)
  301.       '--- split input/output image as is done (sic) to working image
  302.       L0L$ = mid$(L0R$,1,len(LWL$))
  303.       if Split > 0 then
  304.      L0R$ = ltrim$(mid$(L0R$,split+1) ,any " "+chr$(9))
  305.       else
  306.      L0R$ = ""
  307.       end if
  308.    wend   'single statements
  309.  NextLine:
  310.    LOOP  'record read
  311.  
  312.    print: print: print spc(9);"Processing Labels & Line Numbers": print
  313.  
  314.    '--- identify Labels and Line Numbers
  315.    '...call TableLoad(LineLabel$,"Line Labels")
  316.    call TableLoad(GoToPtr$,"GoTo Objects")
  317.    call TableLoad(SubPtr$,"GoSub Calls")
  318.    call TableLoad(RestorePtr$,"Restore Pointers")
  319.  
  320.    call Comparator (LineLabel$,1,"Line Labels/Numbers NOT used")
  321.    call Comparator (GoToPtr$,  2,"GoTo = GoSub (TROUBLE ????)")
  322.    call Comparator (GoToPtr$,  3,"GoTo = Restore (TROUBLE ??)")
  323.    call Comparator (SubPtr$,   4,"GoSub = Restore (TROUBLE ?)")
  324.  
  325. QUITIT:
  326.    close #2
  327.    PRINT: PRINT: PRINT "               (Requires LIST.COM)"
  328.    LOCATE CSRLIN-2, 1, 1
  329.    PRINT "         "; OutFile$; " is complete. LIST file ?? ";
  330.    DO: K$ = UCASE$ (INKEY$): LOOP UNTIL (K$) = "Y" OR (K$) = "N"
  331.    IF K$ = "Y" THEN
  332.       CLS
  333.       LOCATE 4, 10: PRINT "USE CURSOR KEYS TO SCROLL FILE"
  334.       LOCATE 6, 15: PRINT "Escape to Quit
  335.       LOCATE 8, 10: PRINT "Press any Key to start LIST"
  336.       DO: LOOP WHILE INKEY$ = ""
  337.       SHELL "LIST " + OutFile$
  338.       CLS
  339.    ELSE
  340.       PRINT: PRINT: PRINT
  341.    END IF
  342.    END
  343.  
  344. FilesOpen:
  345.    F$ = UCASE$ (F$)
  346.    IF INSTR (F$, ".") = 0 THEN
  347.      InpFile$ = F$ + ".BAS"
  348.    ELSE
  349.      InpFile$ = F$
  350.    END IF
  351.  
  352.    OutFile$ = InpFile$
  353.    DO until instr(OutFile$,"\") = 0
  354.       OutFile$ = mid$(OutFile$,instr(OutFile$,"\")+1)
  355.    LOOP
  356.    OutFile$ = EXTRACT$ (OutFile$, ".") + ".IF-"
  357.  
  358.    on error goto BasicError
  359.    OPEN InpFile$ FOR INPUT AS 1
  360.    OPEN OutFile$ FOR OUTPUT AS 2
  361.    on error goto 0
  362.    RETURN
  363.  
  364. BasicError:
  365.    if ERR = 53 then
  366.       print InpFile$;"  FILE NOT FOUND"
  367.       delay 2
  368.    elseif ERR = 5 then
  369.       print
  370.       print "  IMPROPER END OF NEST - see end of output listing"
  371.       resume QUITIT
  372.    end if
  373.    end
  374.  
  375. PrintHeader:
  376.    PRINT #2, "                              " + DATE$ + " at " + TIME$
  377.    PRINT #2, "    LISTING OF STRUCTURAL STATEMENTS IN "; InpFile$;
  378.    PRINT #2, " FOR ERROR ANALYSIS"
  379.    PRINT #2, ""
  380.    print #2, "Line";spc(2);"Stmnt#";spc(8); _
  381.          "Statement, Flow Control -or- Line Numbered"
  382.    print #2, ""
  383.    RETURN
  384.  
  385. SUB ReadNMatchColor
  386.    LOCAL A        '                                  sets COLOR to match the
  387.    A = SCREEN (CSRLIN, POS, 1) '                     color presently on the
  388.    COLOR A MOD 16, A \ 16 '                          display (at cursor position).
  389.    END SUB
  390.  
  391. '--------------------------------------------------------------------------
  392. SUB EraseCmnt(T$,Cmnt$)
  393. Shared Test$
  394. Local  Posn,Quote,Split
  395.  
  396. '  This sub determines if a Comment indicator is in quotes.  It exists to
  397. '  allow us to strip comments but to retain the quoted material so that we
  398. '  can later identify INCLUDE files, etc
  399.  
  400.    Posn = 1
  401.    Split = instr(Posn,T$,Cmnt$)
  402.    if Split = 0 then
  403.       exit SUB
  404.    elseif Cmnt$ = "REM" then   '--- check for whole word
  405.       while -1
  406.      if split = 1 then
  407.         if (Split+2 = len(T$) or instr(Test$,mid$(T$,Split+3,1)) > 0) then
  408.            exit SUB    '--- we have a REM
  409.         end if
  410.      else
  411.         if instr(Test$,mid$(T$,Split-1,1)) = 0 and _
  412.            (Split+2 = len(T$) or instr(Test$,mid$(T$,Split+3,1)) > 0) then
  413.            exit SUB    '--- we have a REM
  414.         end if
  415.      end if
  416.  
  417.      Posn = Split+3
  418.      Split = instr(Posn,T$,Cmnt$)
  419.      if Split = 0 then exit SUB
  420.       wend
  421.    end if
  422.  
  423.    Posn = 1
  424.    DO
  425.       Quote = instr(Posn,T$,chr$(34))     'open quote
  426.       if Quote = 0 or Split < Quote then
  427.      T$ =  rtrim$(left$(T$,Split-1),any " "+chr$(9))
  428.      exit SUB
  429.       else
  430.      Posn = Quote+1
  431.      Quote = instr(Posn,T$,chr$(34))   'close quote
  432.      if Quote = 0 then                 'close quote is missing
  433.         exit SUB
  434.      elseif Split < Quote then         'look for next split
  435.         Split = instr(Quote,T$,Cmnt$)
  436.         if Split = 0 or Split = len(T$) then
  437.            exit SUB
  438.         elseif Cmnt$ = "REM" then   '--- check for whole word
  439.            while -1
  440.           if instr(Test$,mid$(T$,Split-1,1)) = 0 and _
  441.              (Split+2 = len(T$) or_
  442.              instr(Test$,mid$(T$,Split+3,1)) > 0) then
  443.              exit LOOP    '--- we have a REM
  444.           else
  445.              Posn = Split+3
  446.              Split = instr(Posn,T$,Cmnt$)
  447.              if Split = 0 then exit SUB
  448.           end if
  449.            wend
  450.         end if
  451.      else
  452.         Posn = Quote+1                 'look for next open quote
  453.         if Posn > len(T$) then exit SUB
  454.      end if
  455.       end if
  456.    LOOP
  457.    exit sub
  458.    end sub
  459.  
  460. '--------------------------------------------------------------------------
  461. SUB SplitLine (T$,T1$,Split)
  462. local  Posn,Quote,Kloser$
  463.  
  464. '  This sub determines if a statement separator is in quotes.  It exists to
  465. '  allow us to split statements but to retain the quoted material so that we
  466. '  can later identify INCLUDE files, etc
  467.  
  468.    Posn = 1
  469.    Split = instr(T$,":")
  470.    if Split = 0 or Split = len(T$) then
  471.       T1$ = ""
  472.       exit SUB
  473.    else
  474.       DO
  475.      Quote = instr(Posn,T$,any "("+chr$(34))     'open quote/paren
  476.      if Quote = 0 or Split < Quote then
  477.         T1$ = ltrim$(right$(T$,len(T$)-Split),any " "+chr$(9))
  478.         T$ =  rtrim$(left$(T$,Split-1),any " "+chr$(9))
  479.         exit SUB
  480.      else
  481.         Kloser$ = mid$(T$,Quote,1)
  482.         if Kloser$ >< chr$(34) then
  483.            Kloser$ = ")"
  484.         end if
  485.  
  486.         Posn = Quote+1
  487.         Quote = instr(Posn,T$,Kloser$)   'close quote/paren
  488.         if Quote = 0 then                 'close quote is missing
  489.            Split = 0
  490.            T1$ = ""
  491.            exit SUB
  492.         elseif Split < Quote then         'look for next split
  493.            Split = instr(Quote+1,T$,":")
  494.            if Split = 0 or Split = len(T$) then
  495.           T1$ = ""
  496.           exit SUB
  497.            end if
  498.         end if
  499.         Posn = Quote+1                 'look for next open quote
  500.         if Posn > len(T$) then exit SUB
  501.      end if
  502.      LOOP
  503.       end if
  504.       end sub
  505.  
  506. '--------------------------------------------------------------------------
  507. DEF FnFindNextWord$ (T$)
  508. shared OFFSET, PREVCHAR$, TEST$
  509. local  FLAG, X$, THEWORD$
  510.  
  511. 'This function returns the next word in T$ starting at OFFSET (global).
  512. 'A word is begins with the first alphabetic character encountered and
  513. 'continues until a character outside the set (A-Z, 0-9, ".%&#$!") is
  514. 'encountered.
  515. 'OFFSET is set to the first character position after the word.
  516. 'PREVCHAR$ is set to the char preceeding the word (to find % for constants)
  517.  
  518.    FLAG = 1
  519.    THEWORD$ = ""
  520.    PREVCHAR$ = ""
  521.    X$ = ""
  522.  
  523.    while OFFSET <= LEN (T$)        'Find first alpha character
  524.       X$ = mid$ (T$, OFFSET, 1)
  525.       if X$ >= "A" and X$ <= "Z" then EXIT LOOP
  526.       OFFSET = OFFSET + 1
  527.    wend
  528.  
  529.    if X$ < "A" or X$ > "Z" then        'None found
  530.       OFFSET = len (T$)
  531.       FnFindNextWord$ = ""
  532.       EXIT DEF
  533.    end if
  534.  
  535.    if OFFSET > 1 then
  536.       PREVCHAR$ = mid$ (T$, OFFSET - 1, 1)
  537.       if PrevChar$ = "%" or PrevChar$ = "&" then TheWord$ = PrevChar$
  538.    end if
  539.  
  540.    while FLAG
  541.       THEWORD$ = THEWORD$ + X$
  542.       if OFFSET <= len (T$) then
  543.      OFFSET = OFFSET + 1
  544.       else
  545.      FLAG = 0
  546.       end if
  547.       X$ = mid$ (T$, OFFSET, 1)
  548.       if X$ = "" then
  549.      Flag = 0
  550.       elseif instr (TEST$, X$) = 0 then
  551.      FLAG = 0            'End of word found
  552.       end if
  553.    wend
  554.  
  555.    FnFindNextWord$ = THEWORD$
  556.    END DEF
  557.  
  558. '----------------------------------------------------------------------------
  559. SUB ArgInQuote (T$,ArgMnt$,Split)
  560. '  This procedure determines if an instring value is in quotes or parens.
  561. '  It returns a value, Split, only if the value is a string and not
  562. '  an arguement.
  563.  
  564.    Local  Kloser$,Posn,Quote
  565.  
  566.    Split = instr(T$,ArgMnt$)
  567.    if Split = 0 then
  568.       exit sub
  569.    else
  570.       Posn = 1
  571.       DO
  572.      Quote = instr(Posn,T$,any "("+chr$(34))     'open paren/quote
  573.      if Quote = 0 or Split < Quote then
  574.         exit SUB
  575.      else
  576.         Kloser$ = mid$(T$,Quote,1)
  577.         if Kloser$ >< chr$(34) then
  578.            Kloser$ = ")"
  579.         end if
  580.  
  581.         Posn = Quote+1
  582.         Quote = instr(Posn,T$,Kloser$)   'close paren/quote
  583.         if Quote = 0 then                'close quote is missing
  584.            Split = 0
  585.            exit SUB
  586.         elseif Split < Quote then        'look for next split
  587.            Split = instr(Quote+1,T$,ArgMnt$)
  588.            if Split = 0 then exit SUB
  589.         end if
  590.         Posn = Quote+1                   'look for next open quote
  591.         if Posn > len(T$) then exit SUB
  592.      end if
  593.      LOOP
  594.       end if
  595.       end sub
  596.  
  597. '----------------------------------------------------------------------
  598. SUB LineNmbr (Posn,T$,x$,Split)
  599.  
  600.    if mid$(T$,Posn,1) = " " then
  601.       while mid$(T$,Posn,1) = " " and Posn < len(T$)
  602.       Posn = Posn + 1
  603.       wend
  604.     end if
  605.     Split = instr(mid$(T$,Posn,1), any "0123456789")
  606.     if Split > 0 then
  607.        x$ = extract$(mid$(T$,Posn)," ")
  608.     end if
  609.     end sub
  610.  
  611. '----------------------------------------------------------------------
  612. SUB TableLoad (T$,Hdr$)
  613.  
  614.     Shared SortTable$(),Indent$$
  615.     Local  E,I,Items,S,x$
  616.  
  617.     '--- Load Sort Table
  618.     Items = tally (T$,"~") -1
  619.     if Items > 0 then
  620.        S = 2
  621.        for I = 1 to Items
  622.       E = instr(S,T$,"~")
  623.       if E = 0 then
  624.          exit for
  625.       else
  626.          x$ = mid$(T$,S,E-S)
  627.          if instr(left$(x$,1), any "0123456789") > 0 then
  628.         rset indent$$ = x$
  629.         SortTable$(I) = indent$$
  630.          else
  631.         SortTable$(I) = x$
  632.          end if
  633.          S = E+1
  634.       end if
  635.        next I
  636.  
  637.        array sort SortTable$(1) for Items
  638.  
  639.        print #2, " "
  640.        print #2, Hdr$
  641.        for I = 1 to Items
  642.       print #2, "  ";SortTable$(I)
  643.        next I
  644.     end if
  645.     end sub
  646.  
  647.    '----------------------------------------------------------------------
  648.    Sub Comparator (T$,Kase,Msg$)
  649.  
  650.       Shared Indent$$,SortTable$()
  651.       Shared GoToPtr$,SubPtr$,RestorePtr$
  652.       Local  E,Found,I,Items,Misses,S,x$
  653.  
  654.       Items = tally (T$,"~") -1
  655.       if Items > 0 then
  656.      Misses = 0
  657.      S = 2
  658.      for I = 1 to Items
  659.         E = instr(S,T$,"~")
  660.         if E = 0 then
  661.            exit if
  662.         else
  663.            x$ = mid$(T$,S,E-S)
  664.            Found = 0
  665.            select case Kase
  666.            case 1
  667.           if instr(GoToPtr$, "~"+x$+"~") = 0 and _
  668.              instr(SubPtr$, "~"+x$+"~") = 0  and _
  669.              instr(RestorePtr$, "~"+x$+"~") = 0 then Found = 1
  670.            case 2
  671.           if Instr(SubPtr$, "~"+x$+"~") >< 0 then Found = 1
  672.            case 3,4
  673.           if instr(RestorePtr$, "~"+x$+"~") >< 0 then Found = 1
  674.            case else
  675.           print #2, "Compare Option, ";Kase;", Not Available
  676.           exit sub
  677.            end select
  678.            If Found > 0 then
  679.           incr Misses
  680.           if instr(left$(x$,1),any "0123456789") > 0 then
  681.              rset indent$$ = x$
  682.              SortTable$(Misses) = indent$$
  683.           else
  684.              SortTable$(Misses) = x$
  685.           end if
  686.            end if
  687.         end if
  688.         S = E+1
  689.      next I
  690.  
  691.       if Misses > 0 then
  692.      array sort SortTable$() for Misses
  693.      print #2, " "
  694.      print #2, Msg$
  695.      for I = 1 to Misses
  696.         print #2, "  ";SortTable$(I)
  697.      next I
  698.       end if
  699.    end if
  700.    end Sub
  701.  
  702.    '-----------------------------------------------------------------------
  703.    Sub Chk4Xfr (LWL$,L0L$,Flag,Pre,Post,GoToPtr$)
  704.        shared OffSet
  705.        local  x$,ArgPos,ArgLen,Split
  706.  
  707.       call ArgInQuote (LWL$,"GOTO ",ArgPos): ArgLen = 4
  708.       if ArgPos = 0 then call ArgInQuote (LWL$,"RESUME ",ArgPos): ArgLen = 6
  709.       if ArgPos = 0 then call ArgInQuote (LWL$,"RETURN ",ArgPos): ArgLen = 6
  710.  
  711.       if ArgPos > 0 then
  712.      Flag = -1: Pre= 0: Post= 0
  713.      OffSet = ArgPos + ArgLen
  714.      while -1
  715.         call LineNmbr (OffSet,LWL$,x$,Split)
  716.         if Split = 0 then
  717.            x$=fnFindNextWord$(LWL$)
  718.            Offset = OffSet + 1
  719.            if x$ = "NEXT" then exit sub
  720.         else
  721.            x$ = extract$(x$,",")
  722.            OffSet = OffSet + len(x$) + 1
  723.            if x$ = "0" and left$(LWL$,9) = "ON ERROR " or _
  724.                    mid$(LWL$,ArgPos,6) = "RESUME" then exit sub
  725.         end if
  726.         if len(x$) = 0 then exit sub
  727.         if instr(GoToPtr$, "~"+x$+"~") = 0 then
  728.            GoToPtr$ = GoToPtr$ + x$ +"~"
  729.         end if
  730.         if OffSet => len(LWL$) then exit loop
  731.      Loop
  732.      L0L$ = L0L$ + " " + string$(4,chr$(16))
  733.       end if
  734.       end sub
  735.  
  736.       '--------------------------------------------------------------------
  737.       Sub Chk4Ptr (Lwl$,L0L$,Flag,Pre,Post,SubPtr$,RestorePtr$)
  738.       shared OffSet
  739.       local  x$,ArgPos,ArgLen,Split,Kase
  740.  
  741.       call ArgInQuote (LWL$,"GOSUB ",ArgPos): ArgLen = 5: Kase = 1
  742.       if ArgPos = 0 then
  743.      call ArgInQuote (LWL$,"RESTORE ",ArgPos)
  744.      ArgLen = 7: Kase = 2
  745.       end if
  746.       if ArgPos > 0 then
  747.      Flag = -1: Pre= 0: Post= 0
  748.      OffSet = ArgPos+ArgLen
  749.      While -1
  750.         call LineNmbr (OffSet,LWL$,x$,Split)
  751.         if Split = 0 then
  752.            x$=fnFindNextWord$(LWL$)
  753.            Offset = Offset + 1
  754.         else
  755.            x$ = extract$(x$,",")
  756.            OffSet = OffSet + len(x$) + 1
  757.         end if
  758.         if len(x$) = 0 then exit sub
  759.         Select Case Kase
  760.         case 1
  761.            if instr(SubPtr$, "~"+x$+"~") = 0 then
  762.           SubPtr$ = SubPtr$ + x$ +"~"
  763.            end if
  764.         case 2
  765.            if instr(RestorePtr$, "~"+x$+"~") = 0 then
  766.           RestorePtr$ = RestorePtr$ + x$ +"~"
  767.            end if
  768.         end select
  769.         if OffSet => len(LWL$) then exit loop
  770.      Loop
  771.      L0L$ = L0L$ + " " + chr$(17) + "==" + chr$(16)
  772.       end if
  773.       end sub
  774.