'===========================================================================
' Subject: OPTIMIZED COLORED SOURCE LISTER    Date: 02-23-98 (15:08)       
'  Author: Jonathan L. Leger                  Code: QB, QBasic, PDS        
'  Origin: leger@earthlink.net              Packet: TEXT.ABC
'===========================================================================
DEFINT A-Z

'----------------------------------------------------------------------------
'             Colored Source Lister v1.0 (c) Sami Ky”stil„ 1997
'                       Optomized by Jonathan Leger
'----------------------------------------------------------------------------
' Here's a program that parses a QBasic source code file for statements,
' strings, numbers, etc. and then displays them in color. It's still a
' little slow, but it seems to work fine. Pass a line of source to
' FUNCTION Parseline, and it'll return a color-coded version of it.
' Then you can display the returned string with SUB ColPrint, or maybe
' store it into a second file for later use.
'----------------------------------------------------------------------------
' This version scans the files for the following keywords:
'
'  + QBasic statements - 268 of 'em, check the DATA lines below
'  + Comments
'  + Numbers - 1-9, and also HEX numbers, ie &H60
'  + Strings
'  + Mathematical operators - (+,-,/,\,<,>,^,*,=)
'----------------------------------------------------------------------------
' You may use this program freely, as long as you give me some credit too.
'----------------------------------------------------------------------------

'*************************************************
'*** Optomization Notes  *** by Jonathan Leger ***
'*********************************************************************
'*** First of all, let me say that I think Sami wrote an execllent ***
'*** program.  I really like the way he handled some of the many   ***
'*** difficulties this kind of program requires tackeling.  But in ***
'*** order to speed it up, first of all I simply made all of the   ***
'*** variables default to integers--that in itself gave quite a    ***
'*** boost to the program.  I re-wrote the ColPrint() sub, which   ***
'*** gave a _small_ increase in speed, but the major speed boost   ***
'*** comes from the coloring of statements.  All of the coloring   ***
'*** for math, numbers and comments are Sami's original code, but  ***
'*** I completely rewrote the coloring for statements.  Sami's     ***
'*** original code was checking each line, character by character, ***
'*** for all 286 statements, which (although it worked quite well) ***
'*** was very slow.  I replaced this seach by using INSTR() to find***
'*** which statements were in each line, and coloring them accord- ***
'*** ingly.                                                        ***
'*********************************************************************
'*** Again, thanks to Sami for a great program, and I hope these   ***
'*** optomizations come in handy.                                  ***
'*********************************************************************

DECLARE SUB ColPrint (Text$)
DECLARE FUNCTION ParseLine$ (Line$)

TYPE ColType
  Comment AS INTEGER
  Statement AS INTEGER
  Number AS INTEGER
  CString AS INTEGER
  Math AS INTEGER
  Default AS INTEGER
END TYPE

DIM SHARED Words AS INTEGER
DIM SHARED Col AS ColType

'----------------------------------------------------------------------------
' Define colors
'----------------------------------------------------------------------------
Col.Comment = 15          'Comment
Col.Statement = 9         'QBasic statement
Col.Number = 13           'a Number
Col.CString = 14          'a String expression
Col.Math = 10             'a Mathematical operator
Col.Default = 7           'Default color

RESTORE QData
READ Words

DIM SHARED QWord$(1 TO Words), Commands$

FOR i = 1 TO Words
  READ QWord$(i): Commands$ = Commands$ + QWord$(i) + " "
NEXT

'----------------------------------------------------------------------------
' Open file
'----------------------------------------------------------------------------
Filename$ = UCASE$("colrcode.bas")
'Filename$ = UCASE$("liteview.bas")
'Filename$ = UCASE$("test.bas")

OPEN Filename$ FOR INPUT AS #1
CLS
COLOR 15, 4
LOCATE 1, 1
PRINT STRING$(80, " ")
LOCATE 1, 1
PRINT " ž Parsing file "; Filename$
VIEW PRINT 2 TO 25
COLOR 7, 0
LOCATE 25, 1

'----------------------------------------------------------------------------
' Parse file
'----------------------------------------------------------------------------
DO UNTIL EOF(1) OR INKEY$ <> ""
  LINE INPUT #1, Line$
  Line$ = ParseLine(Line$)
  ColPrint Line$
  PRINT
  VIEW PRINT
  COLOR 15, 4
  LOCATE 1, 60
  PRINT RTRIM$(STR$(INT(SEEK(1) / LOF(1) * 100))); "%"
  COLOR Col.Default, 0
  VIEW PRINT 2 TO 25
  LOCATE 25, 1
LOOP
CLOSE #1

QData:
'----------------------------------------------------------------------------
' QBasic keyword data
'----------------------------------------------------------------------------
DATA 268
DATA "REM"
DATA "XOR"
DATA "ABS"
DATA "APPEND"
DATA "ACCESS"
DATA "AS"
DATA "ALIAS"
DATA "ASC"
DATA "AND"
DATA "ATN"
DATA "ANY"
DATA "BASE"
DATA "BLOAD"
DATA "BSAVE"
DATA "BEEP"
DATA "BYVAL"
DATA "BINARY"
DATA "CALL"
DATA "CLS"
DATA "CALLS"
DATA "COLOR"
DATA "CALL"
DATA "ABSOLUTE
DATA "COM"
DATA "CALL"
DATA "INTERRUPT"
DATA "COMMAND$"
DATA "CASE"
DATA "COMMON"
DATA "CDBL"
DATA "CONST"
DATA "CDECL"
DATA "COS"
DATA "CHAIN"
DATA "CSNG"
DATA "CHDIR"
DATA "CSRLIN"
DATA "CHR$"
DATA "CVD"
DATA "CINT"
DATA "CVDMBF"
DATA "CIRCLE"
DATA "CVI"
DATA "CLEAR"
DATA "CVL"
DATA "CLNG"
DATA "CVS"
DATA "CLOSE"
DATA "CVSMBF"
DATA "DATA"
DATA "DEFINT"
DATA "DEFLNG"
DATA "DATE$"
DATA "DEFSNG"
DATA "DATE$"
DATA "DEFSTR"
DATA "DECLARE"
DATA "DIM"
DATA "DO"
DATA "LOOP"
DATA "DEF FN"
DATA "DOUBLE"
DATA "DEF SEG"
DATA "DRAW"
DATA "DEFDBL"
DATA "$DYNAMIC"
DATA "ELSE"
DATA "ERDEV"
DATA "ELSEIF"
DATA "ERDEV$"
DATA "END"
DATA "ERL"
DATA "END"
DATA "IF"
DATA "ERR"
DATA "ENVIRON"
DATA "ERROR"
DATA "ENVIRON$"
DATA "EXIT"
DATA "EOF"
DATA "EXP"
DATA "EQV"
DATA "ERASE"
DATA "FIELD"
DATA "FOR"
DATA "NEXT"
DATA "FILEATTR"
DATA "FRE"
DATA "FILES"
DATA "FREEFILE"
DATA "FIX"
DATA "FUNCTION"
DATA "GET"
DATA "GOSUB"
DATA "GET"
DATA "GOTO"
DATA "HEX$"
DATA "IF"
DATA "THEN"
DATA "INPUT$"
DATA "IMP"
DATA "INSTR"
DATA "$INCLUDE"
DATA "INT"
DATA "INKEY$"
DATA "INTEGER"
DATA "INP"
DATA "IOCTL"
DATA "INPUT"
DATA "IOCTL$"
DATA "INPUT #"
DATA "IS"
DATA "KEY"
DATA "KILL"
DATA "KEY"
DATA "LBOUND"
DATA "LOCATE"
DATA "LCASE$"
DATA "LOCK"
DATA "UNLOCK"
DATA "LEFT$"
DATA "LOF"
DATA "LEN"
DATA "LOG"
DATA "LET"
DATA "LINE"
DATA "LONG"
DATA "LINE
DATA "INPUT"
DATA "LOOP"
DATA "LPOS"
DATA "LIST"
DATA "LPRINT"
DATA "LOC"
DATA "LSET"
DATA "LOCAL"
DATA "LTRIM$"
DATA "MID$"
DATA "MKL$"
DATA "MID$"
DATA "MKS$"
DATA "MKD$"
DATA "MKSMBF$"
DATA "MKDIR"
DATA "MOD"
DATA "MKDMBF$"
DATA "MKI$"
DATA "NAME"
DATA "NOT"
DATA "NEXT"
DATA "OCT$"
DATA "UEVENT"
DATA "OFF"
DATA "ON"
DATA "GOSUB"
DATA "GOTO"
DATA "COM"
DATA "OPEN"
DATA "ERROR"
DATA "OPEN"
DATA "COM"
DATA "KEY"
DATA "OPTION BASE"
DATA "PEN"
DATA "OR"
DATA "PLAY"
DATA "OUT"
DATA "STRIG"
DATA "OUTPUT"
DATA "TIMER"
DATA "PAINT"
DATA "POINT"
DATA "PALETTE"
DATA "POKE"
DATA "PCOPY"
DATA "POS"
DATA "PEEK"
DATA "PRESET"
DATA "PEN"
DATA "PRINT"
DATA "PEN"
DATA "PRINT"
DATA "USING"
DATA "PLAY"
DATA "PRINT"
DATA "PLAY"
DATA "PSET"
DATA "PLAY"
DATA "PUT"
DATA "PMAP"
DATA "PUT"
DATA "RANDOM"
DATA "RETURN"
DATA "RANDOMIZE"
DATA "RIGHT$"
DATA "READ"
DATA "RMDIR"
DATA "REDIM"
DATA "RND"
DATA "RSET"
DATA "RESET"
DATA "RTRIM$"
DATA "RESTORE"
DATA "RUN"
DATA "RESUME"
DATA "SADD"
DATA "SPC"
DATA "SCREEN"
DATA "SQR"
DATA "SCREEN"
DATA "STATIC"
DATA "SEEK"
DATA "$STATIC"
DATA "SEEK"
DATA "STEP"
DATA "SELECT"
DATA "CASE"
DATA "STICK"
DATA "SETMEM"
DATA "STOP"
DATA "SGN"
DATA "STR$"
DATA "SHARED"
DATA "STRIG"
DATA "SHELL"
DATA "STRIG"
DATA "SIGNAL"
DATA "STRING"
DATA "SIN"
DATA "STRING$"
DATA "SINGLE"
DATA "SUB"
DATA "SLEEP"
DATA "SWAP"
DATA "SOUND"
DATA "SYSTEM"
DATA "SPACE$"
DATA "TAB"
DATA "TIMER"
DATA "TAN"
DATA "TO"
DATA "THEN"
DATA "TROFF"
DATA "TIME$"
DATA "TRON"
DATA "TIME$"
DATA "TYPE"
DATA "TIMER"
DATA "UBOUND"
DATA "UNLOCK"
DATA "UCASE$"
DATA "UNTIL"
DATA "UEVENT"
DATA "USING"
DATA "VAL"
DATA "VARSEG"
DATA "VIEW"
DATA "VARPTR"
DATA "VIEW"
DATA "VARPTR$"
DATA "WAIT"
DATA "WINDOW"
DATA "WEND"
DATA "WRITE"
DATA "WHILE"
DATA "WEND"
DATA "WRITE"
DATA "WIDTH"

SUB ColPrint (Text$)
   amploc = INSTR(Text$, "&")
   DO WHILE amploc > 0
      PRINT LEFT$(Text$, amploc - 1);
      IF amploc + 1 <= LEN(Text$) THEN
         nextletter$ = MID$(Text$, amploc + 1, 1)
         IF INSTR("0123456789ABCDEF", nextletter$) THEN
            COLOR VAL("&H" + nextletter$)
            Text$ = RIGHT$(Text$, LEN(Text$) - amploc - 1)
         ELSE
            PRINT "&"; : Text$ = RIGHT$(Text$, LEN(Text$) - amploc)
         END IF
      END IF
      amploc = INSTR(Text$, "&")
   LOOP
   PRINT Text$;
END SUB

FUNCTION ParseLine$ (Line$)
'----------------------------------------------------------------------------
' Parses a QBasic source code line and returns a color-coded version of it,
' which can be printed with ColPrint.
'----------------------------------------------------------------------------

Comment = 0                'Reset flags
CharSt = -1
Found = 0
Math = 0
Number = 0
Hex = 0
OldChar$ = " "
Parsed$ = "&" + HEX$(Col.Default)
Pcolor = Col.Default
OldPColor = Col.Default

'**** This section of code added by Jonathan Leger. ***
Remark = 0
FOR ii = 1 TO Words
  
   Changed = 0
  
   QWloc = INSTR(Line$, QWord$(ii))
  
   DO
      IF QWloc > 0 AND NOT Remark THEN

         '*** Check to see if statement is within quotes.
         qcount = 0
         ql = INSTR(Line$, CHR$(34))
         IF ql > 0 AND ql < QWloc THEN
            FOR lloc = 1 TO QWloc
               IF MID$(Line$, lloc, 1) = CHR$(34) THEN
                  qcount = qcount + 1
               END IF
            NEXT lloc
         END IF

         '*** Change the color only if the statement is not within quotes.
         IF (qcount MOD 2) = 0 THEN

            '*** Run through some tests to make sure that the statement
            '*** is an individual word and not part of another statement.
            IF QWloc = 1 THEN
               IF LEN(QWord$(ii)) = LEN(Line$) THEN
                  Okay = -1
               ELSE
                  IF MID$(Line$, QWloc + LEN(QWord$(ii)), 1) = " " THEN
                     Okay = -1
                  ELSE
                     Okay = 0
                  END IF
               END IF
            ELSE
               IF MID$(Line$, QWloc - 1, 1) = " " THEN
                  IF (QWloc + LEN(QWord$(ii)) - 1) = LEN(Line$) THEN
                     Okay = -1
                  ELSE
                     IF MID$(Line$, QWloc + LEN(QWord$(ii)), 1) = " " THEN
                        Okay = -1
                     ELSE
                        Okay = 0
                     END IF
                  END IF
               ELSE
                  Okay = 0
               END IF
            END IF

            sqloc = INSTR(Line$, "'")
            IF sqloc > 0 THEN
               IF sqloc < ql OR ql = 0 THEN
                  Pcolor = Col.Comment
                  ParseLine$ = "&" + HEX$(Pcolor) + Line$
                  EXIT FUNCTION
               END IF
            END IF

            '*** Looks good, change the color.
            IF Okay THEN
               IF QWord$(ii) = "REM" THEN
                  Pcolor = Col.Comment
                  Remark = -1
               ELSE
                  Pcolor = Col.Statement
               END IF
               WrdLen = LEN(QWord$(ii))
               l$ = LEFT$(Line$, QWloc - 1)
               Wrd$ = MID$(Line$, QWloc, WrdLen)
               r$ = RIGHT$(Line$, LEN(Line$) - (QWloc + WrdLen - 1))

               IF Remark THEN
                  ParseLine = "&" + HEX$(Pcolor) + Line$
                  EXIT FUNCTION
               ELSE
                  Line$ = l$ + "&" + HEX$(Pcolor) + Wrd$ + "&" + HEX$(Col.Default) + r$
                  Changed = 2
               END IF

            END IF
         END IF

      END IF
       
      QWloc = INSTR(QWloc + 1, Line$, QWord$(ii))
    
   LOOP UNTIL QWloc = 0

NEXT ii
'**** End of code added by Jonathan Leger. ***

FOR i = 1 TO LEN(Line$)

  IF Math = 1 THEN Pcolor = Col.Default: Math = 0
  IF Number = 1 THEN Pcolor = Col.Default: Number = 0

  Char$ = MID$(Line$, i, 1)   'Read byte/word
  Word$ = MID$(Line$, i, 2)

  IF Comment = 0 THEN         'Check for string
    IF Char$ = CHR$(34) THEN Pcolor = Col.CString: CharSt = -CharSt
  END IF

  IF Comment = 0 AND CharSt = -1 THEN
    IF Char$ = " " THEN Pcolor = Col.Default: Hex = 0

    'Check for numbers
    IF ASC(Char$) >= 48 AND ASC(Char$) <= 57 THEN
      IF i > 1 THEN
         IF MID$(Line$, i - 1, 1) <> "&" THEN
            Pcolor = Col.Number: Number = 1
         END IF
      ELSE
         Pcolor = Col.Number: Number = 1
      END IF
    END IF
  
    IF Word$ = "&H" THEN Pcolor = Col.Number: Hex = 1
    IF Word$ = "&O" THEN Pcolor = Col.Number: Hex = 1

    'Check for math
    IF INSTR("+-/\<>^*=", Char$) > 0 THEN Pcolor = Col.Math: Math = 1
 
  END IF

  IF CharSt = -1 THEN
                                  'Check for comments
    IF Char$ = "'" THEN Pcolor = Col.Comment: Comment = 1
  END IF

  IF Hex = 1 THEN Pcolor = Col.Number     'Check for a hex number

  IF Pcolor <> OldPColor THEN Parsed$ = Parsed$ + "&" + HEX$(Pcolor)
  OldPColor = Pcolor
  OldChar$ = Char$
  Parsed$ = Parsed$ + Char$
  Found = Found - 1
NEXT

ParseLine$ = Parsed$

END FUNCTION