'===========================================================================
' Subject: OPTIMIZED COLORED SOURCE LISTER    Date: 09-29-99 (22:06)       
'  Author: Antoni Gual                        Code: QB, PDS                
'  Origin: agual@eic.ictnet.es              Packet: MISC.ABC
'===========================================================================
DEFINT A-Z
DECLARE FUNCTION filesel$ (prompt$, new%)
DECLARE SUB loadkwds ()
DECLARE FUNCTION parsebas2$ (line$)
DECLARE SUB colprint2 (TEXT$)
DECLARE FUNCTION BufIn$ (FileNum%, done%)

'----------------------------------------------------------------------------
'             Optimized Colored Source Lister
'             by Antoni Gual   agual@eic.ictnet.es
'----------------------------------------------------------------------------
' The idea is Sami Kyostila's. Jonathan Leger 's optimization unfortu-
'  nately hangs somewhere (1), so i decided to try myself.
' My contributions are speed, a file selector,a QB format detector
'  and a duplicated entries in keyword table detector.
' CREDITS
' Sami, off course .
' The buffered file reader is Ethan Winer's.
' The file selector is a new version of one I sent months ago. I think
'  it works fine now.
' The parsing thing and color printer are all mine. Quite fast!
'
' SPEED CONTEST:
'   Using CONVERT.BAS, a 95 Kb ABC file
'   In a P166 in W95's  DOS
'
'   runing              IDE    COMPILED
'--------------------------------------
' Sami's original:  125 sec    47,4 sec
' Jonathan's         29 sec    13,7 sec
' This version       12 sec     8,6 sec
'--------------------------------------
' To test program speed set PAGE connstant to FALSE. A timer will appear.
' NOTES:
' -The parse routine is built by trial and error as you can see. No theory!
'   A serious programmer could improve it further.
' -To increase speed I implemented a binary search in the keyword table. Thus
'  I had to sort the table and remove duplicates. The counter will give you
'  224 kwds in front of the original 268.
' -I changed the color prefix for an ESC, that's not found in normal texts.
' -Added metacommands recognition.
' -The file select routine uses interrupt calls so it can't be run in QBasic
'
' KNOWN BUGS:
' -If one of the components of a dotted variable name looks like a kwd
'   the program considers it a kwd.
' -The minus sign is colored erroneously as a math sign when it precedes
'   a negative number (should be considered part of the number).
' Please report any problem!
'----------------------------------------------------------------------------
' (1) Jonathan's version hangs when it finds a line with a single &
'   This can be solved changing the color prefix to ESC.
'----------------------------------------------------------------------------




CONST FALSE = 0: CONST true = NOT FALSE
'----------------------------------------------------------------------------
'Edit constants here at your convenience
'----------------------------------------------------------------------------
'Colors

CONST col.comment = 8           'Comment
CONST col.label = 14            'a label
CONST col.meta = 11             'a metacommand
CONST col.statement = 9         'a QBasic keyword
CONST col.number = 13           'a Number
CONST col.cstring = 12          'a String expression
CONST col.math = 10             'a Mathematical operator
CONST col.sign = 6              'a punctuation sign
CONST col.Default = 7           'Default color
CONST col.type = 2              'a var type extension

'if you want to test program speed, set page=false to avoid paging

CONST PAGE = true

'---------------------------------------------------------------------------
'
'---------------------------------------------------------------------------
CONST numlin = 25

'$INCLUDE: 'qb.bi'
DIM SHARED words AS INTEGER                'num of kwds found in data
DIM SHARED errata AS INTEGER               'variable that brings back error code
										   'to the originating routine
DIM SHARED INREG AS RegTypeX, outreg AS RegTypeX

qbsign$ = CHR$(&HFC) + CHR$(0) + CHR$(1)   'qbasic format's signature
DIM SHARED esc$: esc$ = CHR$(27)           'we use escape to insert color codes
DIM SHARED cr$: cr$ = CHR$(13)
'----------------------------------------------------------------------------
' Here We go!
'----------------------------------------------------------------------------

REDIM SHARED qword$(0)
loadkwds
DO
	Filename$ = filesel$("File To View", 0)
	WIDTH , numlin
	CLS
	COLOR 15, 4
	LOCATE 1, 1
	PRINT STRING$(80, " ")
	LOCATE 1, 1
	PRINT " þ Parsing file "; Filename$
	VIEW PRINT 2 TO numlin
	COLOR 7, 0
	LOCATE 25, 1
	init! = TIMER
	OPEN Filename$ FOR BINARY AS #1
	a$ = SPACE$(3)
   
	GET #1, , a$
	IF a$ = qbsign$ THEN
		PRINT "The file " + Filename$ + " is in QB internal format an can't be viewed by this app."
	ELSE
'----------------------------------------------------------------------------
' Main Loop
'----------------------------------------------------------------------------
   
		DO
			colprint2 parsebas2(BufIn(1, done))
'SNIPPET SCREEN PAGER
			IF PAGE THEN cnt = cnt + 1: IF cnt = numlin - 2 THEN a$ = INPUT$(1): cnt = 0
'END SNIPPET
			IF a$ = esc$ THEN EXIT DO
		LOOP UNTIL done
	END IF
	CLOSE
	IF NOT PAGE THEN PRINT "Parse time: "; TIMER - init!
	COLOR 15: INPUT ; "Another file [Y]/N"; a$
LOOP UNTIL UCASE$(a$) = "N"

END

errorhandler: errata = ERR: RESUME NEXT

'----------------------------------------------------------------------------
' QBasic keyword data
'----------------------------------------------------------------------------
QData:
DATA "ABS", "ABSOLUTE","APPEND","ACCESS","AS", "ALIAS","ASC", "ANY", "ATN"

DATA "BASE","BLOAD","BSAVE", "BEEP", "BYVAL", "BINARY"

DATA "CALL","CLS","CALLS","COLOR","CASE","COMMAND$","COMMON","COM","CDBL"
DATA "CONST","CDECL","COS","CHAIN","CSNG","CHDIR","CSRLIN","CHR$","CVD"
DATA "CINT","CVDMBF","CIRCLE","CVI","CLEAR","CVL", "CLNG","CVS","CLOSE","CVSMBF"

DATA "DATA","DEF","DEFINT","DEFLNG","DATE$","DEFSNG", "DEFSTR", "DECLARE","DIM"
DATA "DO","DOUBLE","DRAW", "DEFDBL","$DYNAMIC"

DATA "ELSE", "ERDEV", "ELSEIF", "ERDEV$", "END", "ERROR", "ERL", "ERR", "ENVIRON"
DATA "ENVIRON$","EXIT","EOF","EXP", "EQV", "ERASE"

DATA "FIELD","FOR", "FILEATTR", "FRE", "FILES", "FREEFILE", "FIX", "FUNCTION"

DATA "GOTO","GOSUB","GET"

DATA "HEX$"

DATA "IF","INTERRUPT","INPUT$","IMP","INSTR","$INCLUDE","INT","INKEY$","INTEGER"
DATA "INP","IOCTL","IOCTL$", "IS", "INPUT"

DATA "KILL","KEY"

DATA "LBOUND","LOCATE","LCASE$","LOCK","LEFT$","LOF","LEN","LOG","LET","LONG"
DATA "LINE"
DATA "LOOP"
DATA "LPOS"
DATA "LIST"
DATA "LPRINT"
DATA "LOC"
DATA "LSET"
DATA "LOCAL"
DATA "LTRIM$"

DATA "MID$","MKL$","MKS$", "MKD$","MKSMBF$", "MKDIR", "MOD","MKDMBF$", "MKI$"

DATA "NAME","NEXT","NOT"

DATA "OCT$","OFF", "ON", "OPEN", "OPTION", "OR", "OUT", "OUTPUT"

DATA "PLAY"
DATA "PAINT"
DATA "POINT"
DATA "PALETTE"
DATA "POKE"
DATA "PCOPY"
DATA "POS"
DATA "PEEK"
DATA "PRESET"
DATA "PEN"
DATA "PRINT"
DATA "PSET"
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 "STRIG"
DATA "SPC"
DATA "SCREEN"
DATA "SQR"
DATA "STATIC"
DATA "SEEK"
DATA "$STATIC"
DATA "STEP"
DATA "SELECT"
DATA "STICK"
DATA "SETMEM"
DATA "STOP"
DATA "SEG"
DATA "SGN"
DATA "STR$"
DATA "SHARED"
DATA "SHELL"
DATA "SIGNAL"
DATA "STRING"
DATA "SIN"
DATA "STRING$"
DATA "SINGLE"
DATA "SUB"
DATA "SLEEP"
DATA "SWAP"
DATA "SOUND"
DATA "SYSTEM"
DATA "SPACE$"

DATA "TAB","TAN","TO", "THEN","TROFF", "TRON", "TIME$","TYPE","TIMER"

DATA "UBOUND","UNLOCK","UCASE$","UNTIL", "USING", "UEVENT"

DATA "VAL","VARSEG","VIEW","VARPTR", "VARPTR$"

DATA "WAIT","WINDOW","WEND","WRITE","WHILE", "WIDTH"

DATA "@@@"

FUNCTION BufIn$ (FileNum, done) STATIC 'Buffered text input from file
'---------------------------------------------
IF NOT Reading THEN
  Reading = -1: done = 0: cr = 0: Remaining& = LOF(FileNum): BufSize = 4096
  Buffer$ = SPACE$(BufSize)
END IF
DO WHILE Remaining&
  IF cr = 0 THEN
	IF Remaining& < BufSize THEN BufSize = Remaining&: Buffer$ = SPACE$(BufSize)
	GET #FileNum, , Buffer$: BufPos = 1
  END IF

  DO
	cr = INSTR(BufPos, Buffer$, cr$)
	IF cr THEN
	  SaveCR = cr
	  BufIn$ = MID$(Buffer$, BufPos, cr - BufPos)
	  BufPos = cr + 2
	  EXIT FUNCTION
	ELSE
	  IF SEEK(FileNum) >= LOF(FileNum) THEN
		Output$ = MID$(Buffer$, SaveCR + 2)
		BufIn$ = Output$
		Remaining& = BufSize
		EXIT DO
	  END IF
	  Slop = BufSize - SaveCR - 1
	  Remaining& = Remaining& + Slop
	  SEEK #FileNum, SEEK(FileNum) - Slop
	END IF
  LOOP WHILE cr
  Remaining& = Remaining& - BufSize
LOOP
Reading = 0: done = -1
END FUNCTION

SUB colprint2 (TEXT$) STATIC 'prints text to screen expanding esc-char->colors
'---------------------------------------------------------------------------
'ESC @ ->color 0  (black)
'ESC O ->color 15 (white)
'---------------------------------------------------------------------------
i = 1: J = 1
DO
	a = INSTR(J, TEXT$, esc$)
	IF a THEN J = a + 2: PRINT MID$(TEXT$, i, a - i); : COLOR ASC(MID$(TEXT$, a + 1, 1)) - 64: i = J
LOOP WHILE a
PRINT MID$(TEXT$, i)
END SUB

SUB comments 'to do
'    falta distinguir guion de signo -. Signo - tiene espacio izq y cifra der
'ok! tratar distinto . de extension y . decimal.
'OK! NO ENCUENTRA 1ER KWD EN LINEA SANGRADA (RECONOCE TABS?)
'ok! NO RECONOCE &H0
'ok! NO RECONOCE // DE COMMON SHARED /BLOQUE/
'    si un componente de variable con punto es kwd, lo reconoce como tal
END SUB

FUNCTION filesel$ (prompt$, dummy%) 'Allows user to select a file
'------------------------------------
'dummy% parameter not used
'------------------------------------
'error messages
CONST pak$ = " Press a key.."
CONST pnf$ = "Path not Found."
CONST ddne$ = "Drive does not Exist."
CONST dnr$ = "Drive not ready. Retry/Abort"
CONST fdne$ = "File not found."
CONST pfe$ = "Path-file error."

'screen reset, start error handler
VIEW PRINT: COLOR 7, 0: CLS
ON ERROR GOTO errorhandler

DO
GOSUB VIEWFILES
askdrive:
GOSUB question: INPUT ; "Drive [Enter:Current]>", drive$
'if no input, go ask path
	IF LEN(drive$) THEN
'---CHDRIVE drive$ in PDS-----------------------
R3:
		DRIV% = ASC(UCASE$(drive$)) - 65
		INREG.AX = &HE00: INREG.DX = DRIV%
		CALL INTERRUPTX(&H21, INREG, INREG)
'probably the drive we asked for does'nt exist
		INREG.AX = &H1900
		CALL INTERRUPTX(&H21, INREG, INREG)
		IF (INREG.AX AND &HFF) <> DRIV% THEN ERROR 68
		IF errata = 68 THEN msgerr$ = ddne$ + pak$: GOSUB errmsg: GOTO askdrive
		IF errata = 71 THEN msgerr$ = dnr$: GOSUB errmsg: IF a$ = "R" THEN GOTO R3 ELSE GOTO askdrive
		GOSUB VIEWFILES
	END IF

askpath:
'what is in?  Here we trap the no disk error
R4:
	IF errata = 71 THEN msgerr$ = dnr$: GOSUB errmsg: IF a$ = "R" THEN GOTO R4 ELSE GOTO askdrive
	GOSUB question: INPUT ; "Path [Enter:Current]>", path$
'if no input go ask filename
	IF LEN(path$) THEN
R1:
		CHDIR path$
		IF errata = 53 OR errata = 76 THEN msgerr$ = pnf$ + pak$: GOSUB errmsg: GOTO askpath
		IF errata = 71 THEN msgerr$ = dnr$: GOSUB errmsg: IF a$ = "R" THEN GOTO R1 ELSE GOTO askdrive
		GOSUB VIEWFILES
	END IF
askname:
	GOSUB question: INPUT ; "File [Enter:New path]>", name$
'does it exist?
R2:
	OPEN name$ FOR INPUT AS #254
	SELECT CASE errata
	CASE 76: msgerr$ = pnf$ + pak$: GOSUB errmsg: GOTO askname
	CASE 53, 64:
	  LOCATE 2, 1: msgerr$ = fdne + pak$: GOSUB errmsg: GOTO askname
	CASE 71: msgerr$ = dnr$: GOSUB errmsg: IF a$ = "R" THEN GOTO R2 ELSE GOTO askdrive
	CASE 75: msgerr$ = pfe$ + pak$: GOSUB errmsg: GOTO askname
	END SELECT
r5:
CLOSE #254
LOOP UNTIL LEN(name$)

'file exists: return
msgerr$ = "File " + UCASE$(name$) + " found.." + pak$: GOSUB errmsg
VIEW PRINT: COLOR 7, 0: CLS
ON ERROR GOTO 0
filesel$ = name$

EXIT FUNCTION

VIEWFILES:
	VIEW PRINT 3 TO 25: COLOR 7, 0: CLS : FILES:
	VIEW PRINT 1 TO 2: COLOR 15, 4: CLS :
RETURN

question:
LOCATE 1, 1: PRINT SPACE$(80); : LOCATE 1, 1: PRINT prompt$ + "? -->Select ";
RETURN

errmsg:
LOCATE 2, 1: PRINT msgerr$; : a$ = UCASE$(INPUT$(1)): LOCATE 2, 1: PRINT SPACE$(80)
errata = 0
RETURN

END FUNCTION

SUB loadkwds 'load kwds from DATA, sorts, counts and search for duplicates

'LOAD KWD DATA

'SNIPPET READ STRINGS FROM DATA WITH SENTINEL

RESTORE QData
words = 0
DO WHILE a$ <> "@@@"
	 words = words + 1: READ a$
LOOP
words = words - 1
REDIM qword$(1 TO words)
RESTORE QData
FOR i = 1 TO words
  READ qword$(i)
NEXT

'END SNIPPET

'SNIPPET BUBBLESORT

FOR i = 2 TO words
   J = i
   DO WHILE qword$(J) < qword$(J - 1)
	  SWAP qword$(J), qword$(J - 1)
	  J = J - 1
	  IF J < 2 THEN EXIT DO
   LOOP
NEXT

'END SNIPPET

CLS : COLOR 15

'snippet find equal
FOR i = 2 TO words
 IF qword$(i) = qword$(i - 1) THEN PRINT "ERROR line "; i; ": "; qword$(i); "= "; qword$(i - 1)
NEXT
PRINT i; " Keywords in list": PRINT
'end snippet

FOR i = 1 TO words: PRINT qword$(i); " "; : NEXT
a$ = INPUT$(1)


END SUB

FUNCTION parsebas2$ (line$) STATIC 'parses bas line coloring kwds, nrs, text
'----------------------------------------------------------------------
'
'----------------------------------------------------------------------
 
  PB$ = "": COLR = col.Default: t$ = RTRIM$(line$): endl = LEN(t$): ptr = 1
  found = FALSE: ptr2 = -1
 
  DO WHILE ptr <= endl
	a$ = MID$(t$, ptr, 1)
	SELECT CASE a$
	CASE "'": SWAP w$, a$: GOTO remparse
	CASE " ": SWAP w$, a$:   GOSUB add1
	CASE CHR$(9): SWAP w$, a$: GOSUB add1
	CASE ".", "(", ")", ";", ",", ":": COLR = col.sign: SWAP w$, a$: GOSUB add1
	CASE "!", "#", "%", "&", "$": COLR = col.type: SWAP w$, a$: GOSUB add1
	CASE "/", "-": COLR = col.math: SWAP w$, a$: GOSUB add1
	CASE CHR$(34):
		COLR = col.cstring: ptr2 = INSTR(ptr + 1, t$, CHR$(34))
		IF ptr2 THEN w$ = MID$(t$, ptr, ptr2 - ptr + 1) ELSE w$ = MID$(t$, ptr)
		GOSUB add1: GOTO nextchar
	END SELECT
nextloop:
	hex = FALSE
parseword:
	ptr2 = endl + 1
	x = INSTR(ptr, t$, CHR$(9)): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, " "): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, "("): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, ")"): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, ";"): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, ","): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, "/"): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, "."): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x1 = INSTR(ptr, t$, ":"): IF x1 THEN IF x1 < ptr2 THEN ptr2 = x1
	x3 = INSTR(ptr, t$, "&"): IF x3 THEN IF x3 < ptr2 THEN ptr2 = x3
	x = INSTR(ptr, t$, "!"): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x2 = INSTR(ptr, t$, "$"): IF x2 THEN IF x2 < ptr2 THEN ptr2 = x2
	x = INSTR(ptr, t$, "#"): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, "%"): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, "'"): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, CHR$(34)): IF x THEN IF x < ptr2 THEN SWAP ptr2, x
	x = INSTR(ptr, t$, "-"): IF x THEN IF ptr2 <> ptr THEN IF x < ptr2 THEN ptr2 = x
	   
	IF hex = FALSE THEN IF ptr = x3 THEN ptr = ptr + 1: hex = true: GOTO parseword
	IF hex = true THEN ptr = ptr - 1: hex = FALSE
	   
	w$ = MID$(t$, ptr, ptr2 - ptr)
	
	
'symbols
	SELECT CASE w$
	CASE ""
	CASE "MOD", "XOR", "NOT", "AND", "EQV": COLR = col.math: : GOSUB add1: GOTO nextchar
	CASE "REM": GOTO remparse
	CASE "<>", ">=", "<=", "OR": COLR = col.math:  GOSUB add1: GOTO nextchar
	CASE ">", "<", "+", "^", "*", "/", "\", "=": COLR = col.math: GOSUB add1: GOTO nextchar
	CASE ELSE:
		IF x2 THEN IF x2 = ptr2 THEN w$ = w$ + "$"

'SNIPPET keyword binary table search
		found = FALSE
		IF w$ <> UCASE$(w$) GOTO nokwd
		IF w$ < qword$(1) GOTO nokwd
		IF w$ > qword$(words) GOTO nokwd
		P1 = 1: P2 = words
		DO
			p3 = (P1 + P2) \ 2: a$ = qword$(p3)
			IF w$ = a$ THEN found = true: EXIT DO
			IF w$ < a$ THEN P2 = p3 - 1:  ELSE P1 = p3 + 1
		LOOP UNTIL P1 > P2
nokwd:
'END SNIPPET
	   
		IF found THEN COLR = col.statement: GOSUB add1: GOTO nextchar
		
		IF x2 THEN IF RIGHT$(w$, 1) = "$" THEN w$ = LEFT$(w$, LEN(w$) - 1)
'LABEL
		IF ptr = 1 THEN IF x1 THEN IF x1 = ptr2 THEN w$ = w$ + ":": COLR = col.label: GOSUB add1: GOTO finlin
		
'NUMBER
		IF VAL(w$) THEN COLR = col.number: GOSUB add1: GOTO nextchar
		IF w$ = "0" THEN COLR = col.number: GOSUB add1: GOTO nextchar
		IF w$ = "&H0" THEN COLR = col.number: GOSUB add1: GOTO nextchar
		IF w$ = "&O0" THEN COLR = col.number: GOSUB add1: GOTO nextchar
		'ANYTHING ELSE
		COLR = col.Default: GOSUB add1
	END SELECT
nextchar:
LOOP
finlin:
parsebas2$ = PB$
EXIT FUNCTION


add1:
IF oldcolr = COLR OR w$ = " " THEN
	PB$ = PB$ + w$
ELSE
	PB$ = PB$ + esc$ + CHR$(COLR + 64) + w$
	SWAP oldcolr, COLR
END IF
 ptr = ptr + LEN(w$): COLR = col.Default
RETURN


remparse:
  l1 = 0
  IF ptr = 1 THEN l1 = true
  COLR = col.statement: GOSUB add1:
  IF l1 THEN IF LEFT$(LTRIM$(MID$(t$, ptr)), 1) = "$" THEN l1 = 2
  w$ = MID$(t$, ptr)
  IF l1 = 2 THEN COLR = col.meta ELSE COLR = col.comment
  GOSUB add1
GOTO finlin




END FUNCTION