Keskustelu: Koodit: QB: Syntaksiväriä QBasic koodille

'****************************************************************************
'**
'** Syntaksivärittäjä
'**
'** Ulostaa annetun BASIC-tiedoston sisällön syntaksiväritettynä
'**
'** Varattujen sanojen lista ei taida olla läheskään täydellinen,
'** eli sinne voi lisäillä sanoja, joita huomaa sieltä puuttuvan
'**
'** Kohtuu pienellä vaivalla saat liitettyä tämän vaikka omaan
'** tekstieditoriisi tjsp. jos kiinnostaa.
'**
'** Aliohjelmista/funktioista:
'**
'**     Is<jotain>          näitä käytetään syötteen luokitteluun.
'**                         esim. IsBracket(merkki$) palauttaa <> 0,
'**                         jos merkki$ on kaarisulku ( tai )
'**
'**     SyntaxPrint         tulostaan yhden rivin väritettynä
'**                         (tai useamman, jos rivi sisältää useampia
'**                         rivejä kaksoispisteellä eroteltuna)
'**
'****************************************************************************
DECLARE FUNCTION Attr% (f%, b%)
DECLARE FUNCTION IsBracket% (c$)
DECLARE FUNCTION IsAlpha% (c$)
DECLARE FUNCTION IsAlphaNum% (c$)
DECLARE FUNCTION IsSpace% (c$)
DECLARE SUB SyntaxPrint (t$)
DECLARE FUNCTION VariableType% (c$)
DECLARE FUNCTION IsKeyword% (c$)
DECLARE FUNCTION IsDigit% (c$)
DECLARE FUNCTION IsHexDigit% (c$)
DECLARE FUNCTION IsOperator% (c$)
DECLARE FUNCTION IsDelim% (c$)

' sisällön luokittelua varten
CONST TTINVALID = 0
CONST TTWHITESPACE = 10, TTKEYWORD = 11, TTVARIABLE = 12
CONST TTSTRING = 20
CONST TTHEX = 30, TTSHORTINT = 31, TTLONGINT = 32, TTFLOAT = 33, TTDOUBLE = 34, TTOCTAL = 35
CONST TTOPERATOR = 40, TTBRACKET = 41, TTCOMMENT = 42, TTDELIM = 43, TTLAST = 44

' tulostetaanko tietyn tyyppinen muuttuja tietyllä värillä,
' vai kaikki muuttujat samalla värillä?
CONST VarColorByType% = 1

DIM SHARED SyntaxColor%(TTINVALID TO TTLAST)

' näitä voi vaihdella mieleisekseen, oletuksena hieman BC++3.11 tyyliset
' värit.

CONST DefBg% = &H10 ' oletustaustaväri, sininen tausta

' väri ylemmät 4 bittiä ovat taustalle, alemmat 4 tekstille
' vari = (tausta AND 15) * 16 + (teksti AND 15)
' tai heksana: esim. &H26 on taustaväri 2, tekstinväri 6
SyntaxColor%(TTINVALID) = DefBg% OR 0
SyntaxColor%(TTWHITESPACE) = DefBg% OR  0
SyntaxColor%(TTKEYWORD) = DefBg% OR 15
SyntaxColor%(TTVARIABLE) = DefBg% OR 14
SyntaxColor%(TTSTRING) = DefBg% OR 10
SyntaxColor%(TTHEX) = DefBg% OR 10
SyntaxColor%(TTOCTAL) = DefBg% OR 12
SyntaxColor%(TTSHORTINT) = DefBg% OR 11
SyntaxColor%(TTLONGINT) = DefBg% OR 11
SyntaxColor%(TTFLOAT) = DefBg% OR 13
SyntaxColor%(TTDOUBLE) = DefBg% OR 13
SyntaxColor%(TTOPERATOR) = DefBg% OR 15
SyntaxColor%(TTBRACKET) = DefBg% OR 15
SyntaxColor%(TTCOMMENT) = DefBg% OR 7
SyntaxColor%(TTDELIM) = DefBg% OR 15

DIM SHARED KW$

' varatut sanat. tästä puuttuu ainaki muutamia. ehkä paljon. evt, evkpk.
KW$ = ""
KW$ = KW$ + "/DATA/DO/LOOP/END/EXIT/FOR/NEXT/IF"
KW$ = KW$ + "/THEN/ELSE/GOSUB/RETURN/GOTO/GOTO"
KW$ = KW$ + "/SELECT/CASE/STOP/SYSTEM/CONST/DIM"
KW$ = KW$ + "/DATA/ERASE/OPTION/BASE/READ/REDIM"
KW$ = KW$ + "/REM/RESTORE/SWAP/TYPE/CALL/DECLARE"
KW$ = KW$ + "/EXIT/FUNCTION/RUN/SHELL/SHARED/STATIC"
KW$ = KW$ + "/SUB/CLS/CSRLIN/INKEY$/INP/KEY/LINE/INPUT"
KW$ = KW$ + "/LOCATE/LPOS/LPRINT/USING/COM/OUTPOS/PRINT"
KW$ = KW$ + "/SPC/SCREEN/TAB/VIEW/WAIT/WIDTH/CIRCLE"
KW$ = KW$ + "/COLOR/GET/PAINT/PALETTE/PCOPY/PMAP/POINT"
KW$ = KW$ + "/PRESET/PSET/WINDOW/CHDIR/KILL/MKDIR/NAME"
KW$ = KW$ + "/RMDIR/CLOSE/EOF/FILEATTR/FREEFILE/INPUT$"
KW$ = KW$ + "/LOC/LOCK/LOF/OPEN/PUT/SEEK/UNLOCK"
KW$ = KW$ + "/WRITE/CLEAR/FRE/PEEK/POKE/ASC/CHR$/HEX$"
KW$ = KW$ + "/INSTR/LCASE$/LEFT$/LEN/LSET/LTRIM$/MID$"
KW$ = KW$ + "/OCT$/RIGHT$/RSET/RTRIM$/SPACE$/STR$"
KW$ = KW$ + "/STRING$/UCASE$/VAL/ABS/ASC/ATN/CDBL/CINT"
KW$ = KW$ + "/CLNG/COS/CSNG/CVDMBF/CVSMBF/EXP"
KW$ = KW$ + "/INT/LOG/RANDOMIZE/RND/SGN/SIN/SQR/TAN"
KW$ = KW$ + "/TIME$/COM/ERDEV/ERDEV$/ERL/ERR/ERROR"
KW$ = KW$ + "/KEY/ON/KEY/PEN/PLAY/STRIG/TIMER"
KW$ = KW$ + "/RESUME/RETURN/WEND/ELSEIF/AND/OR/WHILE/"
KW$ = KW$ + "/MOD/EQV/XOR/NOT/IMP/ENVIRON$/ENVIRON/"

CLOSE

' tähän voipi itse määritellä tiedoston nimen
CONST BASFilename$ = "SYNPRINT.BAS"

n% = FREEFILE

OPEN BASFilename$ FOR INPUT AS #n%
    l% = 0
    WHILE NOT EOF(n%)
        LINE INPUT #n%, K$

        CALL SyntaxPrint(LEFT$(K$ + SPACE$(80), 73))
        PRINT

        l% = l% + 1
        IF ((l% MOD 24) = 0) THEN
            COLOR 0, 6
            PRINT "-- LISSŽŽ --";
            i$ = ""
            WHILE i$ = "": i$ = INKEY$: WEND
            LOCATE CSRLIN, 1: PRINT "        ";
            LOCATE CSRLIN, 1
        END IF
    WEND
CLOSE #n%

FUNCTION IsAlpha% (c$)
    IsAlpha% = (c$ >= "a" AND c$ <= "z") OR (c$ >= "A" AND c$ <= "Z")
END FUNCTION

FUNCTION IsAlphaNum% (c$)
    IsAlphaNum% = IsAlpha%(c$) OR IsDigit%(c$)
END FUNCTION

FUNCTION IsBracket% (c$)
    IsBracket% = (c$ = "(") OR (c$ = ")")
END FUNCTION

FUNCTION IsDelim% (c$)
    IsDelim% = (c$ = ".") OR (c$ = ",") OR (c$ = ":") OR (c$ = ";") OR (c$ = "#")
END FUNCTION

FUNCTION IsDigit% (c$)
    IsDigit% = (c$ >= "0" AND c$ <= "9")
END FUNCTION

FUNCTION IsHexDigit% (c$)
    IsHexDigit% = IsDigit%(c$) OR (c$ >= "A" AND c$ <= "F") OR (c$ >= "a" AND c$ <= "f")
END FUNCTION

FUNCTION IsKeyword% (c$)
    IsKeyword% = INSTR(KW$, "/" + UCASE$(c$) + "/") > 0
END FUNCTION

FUNCTION IsOperator% (c$)
    IsOperator% = INSTR("+-/\*^<>=", c$) > 0
END FUNCTION

FUNCTION IsSpace% (c$)
    IsSpace% = (c$ = " ") OR (c$ = CHR$(9))
END FUNCTION

SUB SyntaxPrint (t$)
    Length% = LEN(t$)
    StartPos% = 1
    EndPos% = 1
    TokenType% = 0
    WHILE (EndPos% <= Length%)
        IF (IsSpace%(MID$(t$, EndPos%, 1))) THEN   ' tyhjyydet

            EndPos% = EndPos% + 1
            WHILE (EndPos% <= Length%) AND (IsSpace%(MID$(t$, EndPos%, 1)))
                EndPos% = EndPos% + 1
            WEND

            TokenType% = TTWHITESPACE

        ELSEIF (IsAlpha%(MID$(t$, EndPos%, 1))) THEN ' muuttujat/käskyt

            EndPos% = EndPos% + 1
            WHILE (EndPos% <= Length%) AND (IsAlphaNum%(MID$(t$, EndPos%, 1)))
                EndPos% = EndPos% + 1
            WEND

            TokenType% = TTVARIABLE
            IF (EndPos% <= Length%) THEN  ' muuttujan tyyppi
                V% = VariableType%(MID$(t$, EndPos%, 1))
                IF (V% <> TTVARIABLE) THEN EndPos% = EndPos% + 1
                IF (VarColorByType%) THEN TokenType% = V%
            END IF

            ' tarkista vielä, onko varattu sana
            IF (IsKeyword%(MID$(t$, StartPos%, EndPos% - StartPos%))) THEN TokenType% = TTKEYWORD

        ELSEIF (IsDigit%(MID$(t$, EndPos%, 1))) THEN '

            EndPos% = EndPos% + 1
            WHILE (EndPos% <= Length%) AND (IsDigit%(MID$(t$, EndPos%, 1)))
                EndPos% = EndPos% + 1
            WEND

            TokenType% = TTFLOAT
            IF (EndPos% <= Length%) AND (MID$(t$, EndPos%, 1) = ".") THEN
                EndPos% = EndPos% + 1
                WHILE (EndPos% <= Length%) AND (IsDigit%(MID$(t$, EndPos%, 1)))
                    EndPos% = EndPos% + 1
                WEND
            END IF

            IF (EndPos% <= Length%) THEN  ' muuttujan tyyppi
                V% = VariableType%(MID$(t$, EndPos%, 1))
                IF (V% <> TTVARIABLE) THEN
                    EndPos% = EndPos% + 1
                    TokenType% = V%
                END IF
            END IF

        ELSEIF MID$(t$, EndPos%, 1) = CHR$(34) THEN

            EndPos% = EndPos% + 1 '
            WHILE (EndPos% <= Length%) AND (MID$(t$, EndPos%, 1) <> CHR$(34))
                EndPos% = EndPos% + 1
            WEND

            EndPos% = EndPos% + 1 '
            TokenType% = TTSTRING

        ELSEIF MID$(t$, EndPos%, 1) = "'" THEN
            TokenType% = TTCOMMENT
            EndPos% = Length% + 1

        ELSEIF IsOperator%(MID$(t$, EndPos%, 1)) THEN
            EndPos% = EndPos% + 1
            TokenType% = TTOPERATOR

        ELSEIF IsDelim%(MID$(t$, EndPos%, 1)) THEN
            EndPos% = EndPos% + 1
            TokenType% = TTDELIM

        ELSEIF IsBracket%(MID$(t$, EndPos%, 1)) THEN
            EndPos% = EndPos% + 1
            TokenType% = TTBRACKET

        ELSEIF MID$(t$, EndPos%, 1) = "&" THEN
            EndPos% = EndPos% + 1
            IF (EndPos% <= Length%) THEN
                SELECT CASE UCASE$(MID$(t$, EndPos%, 1))
                    CASE "O":
                        EndPos% = EndPos% + 1
                        TokenType% = TTOCTAL
                        WHILE (EndPos% <= Length%) AND (IsDigit%(MID$(t$, EndPos%, 1)))
                            EndPos% = EndPos% + 1
                        WEND

                    CASE "H":
                        EndPos% = EndPos% + 1
                        TokenType% = TTHEX
                        WHILE (EndPos% <= Length%) AND (IsHexDigit%(MID$(t$, EndPos%, 1)))
                            EndPos% = EndPos% + 1
                        WEND
                END SELECT
            ELSE
                TokenType% = TTINVALID
            END IF

        ELSE
            TokenType% = TTINVALID
            EndPos% = EndPos% + 1
        END IF

        COLOR SyntaxColor%(TokenType%) AND &HF, (SyntaxColor%(TokenType%) AND &HF0) \ 16
        PRINT MID$(t$, StartPos%, EndPos% - StartPos%);

        StartPos% = EndPos%
    WEND
END SUB

FUNCTION VariableType% (c$)
    VariableType% = TTVARIABLE
    IF (c$ = "$") THEN VariableType% = TTSTRING
    IF (c$ = "!") THEN VariableType% = TTFLOAT
    IF (c$ = "#") THEN VariableType% = TTDOUBLE
    IF (c$ = "%") THEN VariableType% = TTSHORTINT
    IF (c$ = "&") THEN VariableType% = TTLONGINT
END FUNCTION