'===========================================================================
' Subject: COLORED SOURCE LISTER V1.0         Date: 11-23-97 (22:49)       
'  Author: Sami Kyostila                      Code: QB, QBasic, PDS        
'  Origin: hiteck@mail.freenet.hut.fi       Packet: MISC.ABC
'===========================================================================
'----------------------------------------------------------------------------
'             Colored Source Lister v1.0 (c) Sami Ky”stil„ 1997
'----------------------------------------------------------------------------
' 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.
'----------------------------------------------------------------------------

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)

FOR i = 1 TO Words
  READ QWord$(i)
NEXT

'----------------------------------------------------------------------------
' Open file
'----------------------------------------------------------------------------
Filename$ = UCASE$("codelist.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 "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 "REM"
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$)
FOR i = 1 TO LEN(Text$)
  Done = 0
  DO
    IF MID$(Text$, i, 1) = "&" AND INSTR("0123456789ABCDEF", MID$(Text$, i + 1, 1)) AND i < LEN(Text$) THEN
      COLOR VAL("&H" + MID$(Text$, i + 1, 1))
      i = i + 2
    ELSE
      Done = 1
    END IF
  LOOP UNTIL Done
  PRINT MID$(Text$, i, 1);
NEXT
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

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

    IF Found <= 0 AND OldChar$ = " " THEN       'Check for QBasic keywords
      FOR ii& = 1 TO Words
        Parse$ = MID$(Line$, i, LEN(QWord$(ii&)))
        IF QWord$(ii&) = "REM" AND Parse$ = QWord$(ii&) THEN PColor = Col.Comment: Comment = 1: EXIT FOR
        IF Parse$ = QWord$(ii&) THEN PColor = Col.Statement: Found = LEN(Parse$): EXIT FOR
      NEXT
    END IF

    'Check for numbers
    IF ASC(Char$) >= 48 AND ASC(Char$) <= 57 THEN PColor = Col.Number: Number = 1
    IF Word$ = "&H" THEN PColor = Col.Number: Hex = 1
    IF Word$ = "&O" THEN PColor = Col.Number: Hex = 1

    'Check for math
    IF Char$ = "+" THEN PColor = Col.Math: Math = 1
    IF Char$ = "-" THEN PColor = Col.Math: Math = 1
    IF Char$ = "/" THEN PColor = Col.Math: Math = 1
    IF Char$ = "\" THEN PColor = Col.Math: Math = 1
    IF Char$ = "<" THEN PColor = Col.Math: Math = 1
    IF Char$ = ">" THEN PColor = Col.Math: Math = 1
    IF Char$ = "^" THEN PColor = Col.Math: Math = 1
    IF Char$ = "*" THEN PColor = Col.Math: Math = 1
    IF Char$ = "=" THEN PColor = Col.Math: Math = 1
  END IF

  IF CharSt = -1 THEN
                                  'Check for comments
    IF Char$ = "'" THEN PColor = Col.Comment: Comment = 1
    IF Comment = 0 THEN
      IF Char$ = "(" THEN PColor = Col.Default
      IF Char$ = ")" THEN PColor = Col.Default
      IF Char$ = "," THEN PColor = Col.Default
    END IF
  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