Author Topic: Extended syntax highlighting added (Read 5943 times)

odin · « **on:** April 27, 2019, 08:01:37 pm »

To post code on this forum, one should use the [code] tag:

[code]
PRINT "my code"
[/code]

Which results in:

Code: [Select]

PRINT "my code"
Beginning today we have added extended syntax highlighting, which can be used by modifying the code tag as follows:

[code=qb64]
PRINT "my code"
[/code]

Which results in:

Code: QB64: [Select]

PRINT "my code"

That gives your code syntax highlighting, line numbers and the keywords will even link to the wiki, so they can be clicked for reference.

~~The only drawback is that there's no easy way to "[Select]" code.~~ No more drawbacks. See below.

Example of code box with a larger piece of code:

Code: QB64: [Select]

'QB45BIN.BAS - written by qarnos
'Used by permission: http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=1771.msg16215#msg16215
'Command line interface adapted by FellippeHeitor
 
REM $DYNAMIC
 
DEFINT A-Z
'----------------------------------------------------------------------------
' Used for sorting alphabetically.
'----------------------------------------------------------------------------
DIM SHARED QBBinProcedureIndex AS STRING
 
'----------------------------------------------------------------------------
' Internal constants used by parse rule decoder
'----------------------------------------------------------------------------
CONST TagType.Recursive = 1
CONST TagType.TokenData = 2
CONST TagType.StackABS = 3
CONST TagType.StackREL = 4
 
'----------------------------------------------------------------------------
' Constants returned by the Meta field of QBBinReadLine. I will probably
' use the high 16-bits for flags, so best to mask them out for now.
'----------------------------------------------------------------------------
CONST QBBinMeta.SUB = 1
CONST QBBinMeta.FUNCTION = 2
 
'----------------------------------------------------------------------------
' Not yet used since it only supports QB45 atm.
'----------------------------------------------------------------------------
CONST QBBinFileMode.QB45 = 1
 
'----------------------------------------------------------------------------
' Option variable declarations
'----------------------------------------------------------------------------
DIM SHARED QBBinOption.OmitIncludedLines AS INTEGER
DIM SHARED QBBinOption.SortProceduresAZ AS INTEGER
 
'----------------------------------------------------------------------------
' Option variable initialisation
'----------------------------------------------------------------------------
QBBinOption.OmitIncludedLines = -1
QBBinOption.SortProceduresAZ = -1
 
'----------------------------------------------------------------------------
' Errors only half-implemented so far.
'----------------------------------------------------------------------------
CONST QBErrBadFormat = 255
CONST QBErrBadToken = 254
CONST QBErrInsane = 253
 
'----------------------------------------------------------------------------
' You may use QBBinEOF, for now, to determine when EOF has been reached.
' QBBinDefType contains the current DEFxxx setting for each letter of the
' alphabet (1 = INT, 2 = LNG, 3 = SNG, 4 = DBL, 5 = STR).
'----------------------------------------------------------------------------
DIM SHARED QBBinDefType(1 TO 26) AS INTEGER
DIM SHARED QBBinLineReady AS INTEGER ' get rid of this
DIM SHARED QBBinProgramLine AS STRING ' and this
DIM SHARED QBBinFile AS INTEGER
DIM SHARED QBBinEOF AS INTEGER
 
'----------------------------------------------------------------------------
' A hash table is used for symbols defined in the parse rules. There aren't
' many of them, so a small table will do.
'----------------------------------------------------------------------------
CONST SymbolHashBuckets = 43
DIM SHARED SymbolHashTable(0 TO SymbolHashBuckets - 1) AS STRING
DIM SHARED SymbolHashEntries AS INTEGER
 
'----------------------------------------------------------------------------
' Not worth commenting on... oops.
'----------------------------------------------------------------------------
DIM SHARED TypeSpecifiers(0 TO 5, 1 TO 3) AS STRING
DIM SHARED ParseRules(0) AS STRING
 
'----------------------------------------------------------------------------
' We don't need a very big stack. I haven't seen it go beyond 8 or 9 entries
' so 255 is plenty. Also, STACK(0) is a special entry. IF SP = 0 then there
' is nothing on the stack.
'----------------------------------------------------------------------------
DIM SHARED STACK(0 TO 255) AS STRING
DIM SHARED SP AS INTEGER
 
'----------------------------------------------------------------------------
' Define global symbol table, code space and instruction pointer
'----------------------------------------------------------------------------
DIM SHARED SYMTBL(0) AS INTEGER
DIM SHARED CODE(0) AS INTEGER
DIM SHARED IP AS LONG
 
'----------------------------------------------------------------------------
' PCODE always contains the ID of the current token (the low 10 bits of the
'       input word.
'
' HPARAM contains the high 6 bits of the input word and is used by some
'        tokens. IE: Identifiers use it for the type suffix and integers
'        smaller than 10 are encoded this way.
'
' TOKEN is a string containing the binary data for the current token (PCODE
'       and HPARAM in the first word, the rest of the data follows). All the
'       FetchXXX functions work on this variable
'----------------------------------------------------------------------------
DIM SHARED PCODE AS INTEGER
DIM SHARED HPARAM AS INTEGER
DIM SHARED TOKEN AS STRING
 
'----------------------------------------------------------------------------
' LastProcType is just a hack to keep track of the current SUB or FUNCTION
' status since END SUB and END FUNCTION share the same token.
'----------------------------------------------------------------------------
DIM SHARED LastProcType AS STRING ' Current procedure type
DIM SHARED QBTxtFile AS INTEGER
 
'----------------------------------------------------------------------------
' These variables contain the current prodecure name and type the parser
' is decoding.
'
' QBBinProcedureType = MAIN | SUB | FUNCTON | DEF
'----------------------------------------------------------------------------
DIM SHARED QBBinProcedureName AS STRING
DIM SHARED QBBinProcedureType AS STRING
 
 
'----------------------------------------------------------------------------
' Variables used to store common token codes referenced in the code. Faster
' than doing GetHashedSymbol("tokenname") every time, and flexible since the
' QB40 token codes are different from QB45.
'----------------------------------------------------------------------------
DIM SHARED QBBinTok.SUBDEF AS INTEGER
DIM SHARED QBBinTok.FUNCDEF AS INTEGER
DIM SHARED QBBinTok.DEFTYPE AS INTEGER
 
DIM SHARED OutputContents$
 
$CONSOLE:ONLY
_DEST _CONSOLE
 
'----------------------------------------------------------------------------
' Initialisation will eventually be automatic in QBBinOpenFile
'----------------------------------------------------------------------------
RESTORE TSPECS
FOR i = 0 TO 17: READ TypeSpecifiers(i \ 3, i MOD 3 + 1): NEXT i
 
'----------------------------------------------------------------------------
' Get file names, etc.
'----------------------------------------------------------------------------
'ON ERROR GOTO ErrorHandler
 
GetInputFileName:
 
IF _COMMANDCOUNT = 0 THEN
    PRINT "QB45BIN"
    PRINT
    PRINT "Conversion utility from QuickBASIC 4.5 binary to plain text."
    PRINT "by qarnos"
    PRINT
    PRINT "    Syntax: QB45BIN <source.bas> [-o output.bas]"
    PRINT
    PRINT "If no output is specified, a backup file is saved and the original"
    PRINT "file is overwritten."
    PRINT
    SYSTEM 1
END IF
 
IF _FILEEXISTS(COMMAND$(1)) = 0 THEN
    IF INSTR(InputFile$, ".") = 0 THEN InputFile$ = InputFile$ + ".BAS"
 
    PRINT "File not found: "; COMMAND$(1)
    SYSTEM 1
ELSE
    InputFile$ = COMMAND$(1)
END IF
 
IF LCASE$(COMMAND$(2)) = "-o" THEN
    IF LEN(COMMAND$(3)) THEN
        OutputFile$ = COMMAND$(3)
    END IF
END IF
 
IF OutputFile$ = "" THEN
    IF INSTR(InputFile$, "\") > 0 OR INSTR(InputFile$, "/") > 0 THEN
        FOR i = LEN(InputFile$) TO 1 STEP -1
            IF MID$(InputFile$, i, 1) = "/" OR MID$(InputFile$, i, 1) = "\" THEN
                path$ = LEFT$(InputFile$, i)
                InputFile$ = MID$(InputFile$, i + 1)
                EXIT FOR
            END IF
        NEXT
    END IF
    OutputFile$ = path$ + InputFile$ + ".converted.bas"
END IF
 
PRINT UCASE$(InputFile$)
 
PRINT
PRINT "Loading parse rules... ";
LoadParseRules
PRINT "Done!": PRINT
 
QBBinOpenFile path$ + InputFile$
 
'---------------------------------------------------------------------------
' The main loop is pretty straight-forward these days.
'---------------------------------------------------------------------------
StartProcessing! = TIMER
DO WHILE NOT QBBinEOF
 
    ProgramLine$ = QBBinReadLine$(Meta&)
 
    '-----------------------------------------------------------------------
    ' Just an example of meta-data usage. Pretty limited at the moment,
    ' but could be helpful to QB64 IDE when building SUB/FUNCTION list.
    '-----------------------------------------------------------------------
    'IF Meta& = QBBinMeta.SUB THEN PRINT "----- SUBROUTINE -----"
    'IF Meta& = QBBinMeta.FUNCTION THEN PRINT "----- FUNCTION -----"
 
    '-----------------------------------------------------------------------
    ' AOutput has become a pretty-print function. All program lines are now
    ' retrieved by calling QBBinReadLine.
    '-----------------------------------------------------------------------
    AOutput ProgramLine$
 
    'Quit after a number of seconds - likely an invalid file causing an endless loop
    CONST TIMEOUT = 30
    IF StartProcessing! > TIMER THEN StartProcessing! = StartProcessing! - 86400
    IF TIMER - StartProcessing! > TIMEOUT THEN PRINT "Conversion failed.": SYSTEM 1
 
LOOP
 
'If we've made it this far, output the resulting file:
QBTxtFile = FREEFILE
OPEN OutputFile$ FOR BINARY AS #QBTxtFile
PUT #QBTxtFile, 1, OutputContents$
CLOSE #QBTxtFile
 
RESET
 
PRINT "Finished!"
 
SYSTEM 0
 
TSPECS:
DATA ANY,,
DATA INTEGER,INT,%
DATA LONG,LNG,&
DATA SINGLE,SNG,!
DATA DOUBLE,DBL,#
DATA STRING,STR,$
 
 
QB45TOKENS:
'
' Most of the tokens for QB45 are defined here, along with the length of the
' token (or '*' for variable length) and some parse rules.
'
' The first column determined the PCODE (the low 10 bits of the token)
' which the rule responds to. This is followed by the length of the token
' *data*, which may be omitted if the token has no data, or an asterisk to
' indicate a variable length token. Variable length tokens are always
' followed by a word indicating the length of the token.
'
' The final column is the parse rule itself. A token may have multiple
' parse rules. Multiple parse rules may be specified on a seperate line
' (without a PCODE or LENGTH field), or seperated by a pipe ('|') symbol.
'
' There is one important difference between the two methods. Some rules
' define a symbol which can be used to reference the rule, such as:
'
'   declmod::=SHARED
'
' If a pipe symbol is used, the next rule will inherit the "declmod" (or
' whatever symbol), unless it exlicitly defines it's own. Rules defined
' on seperate lines use the default symbol which, initially, is nothing, but
' may be overridden using the ".default" directive. This is only really used
' in the second half of the rule list, where almost every token is an
' expression ('expr').
'
' Rules are matched on a first-come first-served basis. The first rule which
' can be successfully applied (see below) is accepted.
'
' The rules can have {tags} embedded in them. There are basically two types
' of tags - stack and data/format tags. I will discuss them briefly here:
'
' STACK tags can take these basic forms:
'
'  {1}
'  {*:1}
'  {rulename:1}
'  {$+1}
'  {$-1}
'  {rulename:$+1}
'
' The first type will be substituded for the text located 1 item from the
' top of the parse stack. If the stack isn't that deep, it will be replaced
' with the null string.
'
' The second type is just like the first, except the rule will be rejected
' if the stack item doesn't exist.
'
' The third type will only accept a rule if the stack item at the specified
' offset is of the correct rule type. So {declmod:1} will reject the rule
' if the stack entry at offset 1 is not a "declemod". There is also a special
' rule name, "self", which always refers to the current rule.
'
' The final three forms, use the '$' symbol. This symbol refers to a
' "relative" stack offset - an offset from the deepest stack item referenced
' in a normal tag. This is really a bit of a hack, due to me trying to avoid
' writing a full LALR(1) parser! This feature is rarely used.
'
' DATA/FORMAT tags
'
' Data and format tags being with a '#', such as {#id:2}. These tags are used
' either to interpret data from the token or to generate a dynamic parse
' rule (another hack).
'
' In the case of data tokens, the number refers to the offset into the token
' data on which the tag is to work.
'
' Format tokens usually have two '#' symbols, such as {##id(decl)}. The
' extra '#' causes the parser to re-scan the tag for other tags once it
' has been subsituted, allowing these tags to generate stack tags which can
' then be parsed.
'
' See the function GetTaggedItem for a list of tag names which can be used.
'
'
'
 
 
REM     Token   Length  Rule(s)
REM     -------+-------+-------
 
DATA 0x000,"newline::=.{#newline}{#tabh}"
DATA 0x001,2,"newline::=.{#newline}{#tabi}"
DATA 0x002,2,"newline::=.{#newline-include}"
DATA 0x003,4,"newline::=.{#newline-include}{#indent:2} "
DATA 0x004,4,".{#newline}{#thaddr:0}{#label:2}"
DATA 0x005,6,".{#newline}{#thaddr:0}{#label:2} {#indent:4}"
DATA 0x006,": "
DATA 0x007,2,":{#tabi}"
 
'----------------------------------------------------------------------------
' 0x008 = End of procedure/module code (watch list follows)
' 0x009 = End of watch list
'----------------------------------------------------------------------------
DATA 0x008,"."
DATA 0x009,
 
DATA 0x00a,*,"{#raw:2}"
DATA 0x00b,2,"expr::={#id+}"
DATA 0x00c,2,"consts::={const:1} {#id+} = {0}"
DATA "consts::={consts:1}, {#id+} = {0}"
DATA "{#id+} = {0}"
DATA 0x00d,2,"decls::={decls:1}, {#id+:0} {astype:0}"
DATA "decls::={decls:0}, {#id+:0}"
DATA "decls::={decl:1} {#id+:0} {astype:0}"
DATA "decls::={decl:0} {#id+:0}"
DATA "{#id+:0} {astype:0}"
DATA "{#id+:0}"
DATA 0x00e,4,"expr::={##id(expr)}"
DATA 0x00f,4,"{##id(expr)} = {$+0}"
DATA 0x010,4,"decls::={##id(decl)}"
DATA 0x011,2,"expr::={0}.{#id}"
DATA 0x012,2,"{0}.{#id} = {1}"
 
' 0x015 = AS USERTYPE
' 0x016 = AS BUILTINTYPE?
DATA 0x015,4,"astype::={#tabi:2}AS {#type:0}"
DATA 0x016,4,"astype::={#tabi:2}AS {#type:0}"
 
' 0x017 - used for unkown type assignments?
DATA 0x017,0,""
 
DATA 0x018,""
 
'----------------------------------------------------------------------------
' 0x019 = user-type field declaration.
'----------------------------------------------------------------------------
DATA 0x019,2,"{#id}"
DATA 0x01a,"declmod::=SHARED"
DATA 0x01b,6,"deftype::={#thaddr:0}{#DEFxxx}"
DATA 0x01c,"{self:1}, {0}|REDIM {declmod:1} {0}|REDIM {0}"
DATA 0x01d,2,"END TYPE"
DATA 0x01e,2,"decl::=SHARED"
DATA 0x01f,2,"decl::=STATIC"
DATA 0x020,4,"TYPE {#id:2}"
DATA 0x021,*,"$STATIC{#raw}"
DATA 0x022,*,"$DYNAMIC{#raw}"
DATA 0x023,"const::=CONST"
 
'----------------------------------------------------------------------------
' 0x024 = IDE breakpoint
'----------------------------------------------------------------------------
DATA 0x024,
 
DATA 0x025,"BYVAL {0}"
DATA 0x026,*,"{deffn:1} = {0}"
DATA 0x027,"COM({0})"
DATA 0x028,2,"ON {0} GOSUB {#id}"
DATA 0x029,"KEY({0})"
DATA 0x02a,"{0} OFF"
DATA 0x02b,"{0} ON"
DATA 0x02c,"{0} STOP"
DATA 0x02d,"PEN"
DATA 0x02e,"PLAY"
DATA 0x02f,"PLAY({0})"
DATA 0x030,"SIGNAL({0})"
DATA 0x031,"STRIG({0})"
DATA 0x032,"TIMER"
DATA 0x033,"TIMER({0})"
 
'----------------------------------------------------------------------------
' Labels used in $INCLUDEd lines
'----------------------------------------------------------------------------
DATA 0x034,4,"newline::={#thaddr:0}{#label:2} "
DATA 0x035,6,"newline::={#thaddr:0}{#label:2} {#indent:4}"
 
DATA 0x037,4,"CALL {#id:2}{##call()}"
DATA 0x038,4,"{#id:2}{##call}"
DATA 0x039,4,"CALLS {#id:2}{##call()}"
DATA 0x03a,"CASE ELSE"
DATA 0x03b,"case::={case:1}, {0}|CASE {0}"
DATA 0x03c,"case::={case:2}, {1} TO {0}|CASE {1} TO {0}"
DATA 0x03d,"case::={case:1}, IS = {0}|CASE IS = {0}"
DATA 0x03e,"case::={case:1}, IS < {0}|CASE IS < {0}"
DATA 0x03f,"case::={case:1}, IS > {0}|CASE IS > {0}"
DATA 0x040,"case::={case:1}, IS <= {0}|CASE IS <= {0}"
DATA 0x041,"case::={case:1}, IS >= {0}|CASE IS >= {0}"
DATA 0x042,"case::={case:1}, IS <> {0}|CASE IS <> {0}"
 
DATA 0x043,"ON"
DATA 0x044,*,"DECLARE {#procdecl()}"
DATA 0x045,*,"deffn::={#procdecl:2}"
DATA 0x046,"DO"
DATA 0x047,"DO UNTIL {0}"
DATA 0x048,2,"DO WHILE {0}"
DATA 0x049,2,"{newline:0}ELSE| ELSE "
 
' 0x04a = implicit GOTO linenumber used in 0x04c ELSE
DATA 0x04a,2,"{#id}"
DATA 0x04c," ELSE "
 
DATA 0x04d,2,"ELSEIF {0} THEN"
DATA 0x04e,"END"
DATA 0x04f,*,"END DEF"
DATA 0x050,"END IF"
DATA 0x051,"END {#proctype}"
DATA 0x052,"END SELECT"
DATA 0x053,2,"EXIT DO"
DATA 0x054,2,"EXIT FOR"
DATA 0x055,2,"EXIT {#proctype}"
DATA 0x056,4,"FOR {2} = {1} TO {0}"
DATA 0x057,4,"FOR {3} = {2} TO {1} STEP {0}"
DATA 0x058,*,"funcdef::={#procdecl}"
DATA 0x059,2,"GOSUB {#id}"
'       0x05a   2,      "GOSUB {#id}"
DATA 0x05b,2,"GOTO {#id}"
'       0x05c   2,      "GOTO {#id}"
DATA 0x05d,2,"IF {0} THEN "
DATA 0x05e,2,"IF {0} THEN {#id}"
'       0x05f,  2,      "IF {0} THEN "
DATA 0x060,2,"IF {0} GOTO {#id}"
DATA 0x061,2,"IF {0} THEN"
DATA 0x062,2,"LOOP"
DATA 0x063,2,"LOOP UNTIL {0}"
DATA 0x064,2,"LOOP WHILE {0}"
DATA 0x065,4,"NEXT"
DATA 0x066,4,"{self:1}, {0}|NEXT {0}"
DATA 0x067,2,"ON ERROR GOTO {#id}"
DATA 0x068,*,"ON {0} GOSUB {#id-list}"
DATA 0x069,*,"ON {0} GOTO {#id-list}"
DATA 0x06a,"RESTORE"
DATA 0x06b,2,"RESTORE {#id}"
DATA 0x06c,"RESUME"
DATA 0x06d,2,"RESUME {#id}"
DATA 0x06e,"RESUME NEXT"
DATA 0x06f,"RETURN"
DATA 0x070,2,"RETURN {#id}"
DATA 0x071,"RUN {0}"
DATA 0x072,2,"RUN {#id}"
DATA 0x073,"RUN"
DATA 0x074,2,"SELECT CASE {0}"
DATA 0x075,2,"STOP"
DATA 0x076,*,"subdef::={#procdecl}"
DATA 0x077,"WAIT {1}, {0}"
DATA 0x078,"WAIT {2}, {1}, {0}"
DATA 0x079,2,"WEND"
DATA 0x07a,2,"WHILE {0}"
 
'----------------------------------------------------------------------------
' 0x07b used in IDE watch mode. Probably 0x07c, too.
'----------------------------------------------------------------------------
DATA 0x07b,
DATA 0x07c,
 
DATA 0x07d,"prnmod::={prnmod:1} {0},|PRINT {0},"
 
'----------------------------------------------------------------------------
' 3 dummy tokens used in LINE statements
'----------------------------------------------------------------------------
DATA 0x07e,"{0}"
DATA 0x07f,"{0}"
DATA 0x080,"{0}"
 
'----------------------------------------------------------------------------
' graphics co-ordinates
'----------------------------------------------------------------------------
DATA 0x081,"1st-coord::=({1}, {0})"
DATA 0x082,"1st-coord::=STEP({1}, {0})"
DATA 0x083,"{1st-coord:2}-({1}, {0})|({1}, {0})"
DATA 0x084,"{1st-coord:2}-STEP({1}, {0})|-STEP({1}, {0})"
 
DATA 0x085,"FIELD {0}"
DATA 0x086,", {1} AS {0}"
DATA 0x087,"finput::=INPUT {0},"
DATA 0x088,"{input:1} {inputs:0}"
DATA 0x089,*,"input::=INPUT {##input-args}"
DATA 0x08a,"#{0}"
 
'----------------------------------------------------------------------------
' These two consume data, but I have no idea what they do. I haven't seen
' one in the wild.
'----------------------------------------------------------------------------
DATA 0x08c,2,""
'       0x08d,  4,      ""
 
'----------------------------------------------------------------------------
' Most of the PRINT stuff is here. The rules are pretty finicky. These
' sequences also apply to LPRINT and WRITE.
'----------------------------------------------------------------------------
DATA 0x08f,"prnsmc::={self|prncma|prnsrl:1} SPC({0});"
DATA "prnsmc::=SPC({0});"
DATA 0x090,"prnsmc::={self|prncma|prnsrl:1} TAB({0});"
DATA "prnsmc::=TAB({0});"
 
DATA 0x091,"prncma::={self|prnsmc|prnsrl:0} ,|,"
 
DATA 0x092,"prnsmc::={self:0}|{prncma|prnsrl:0} ;|;"
 
DATA 0x093,"{prnmod:2} {prnuse:1} {prnsrl|prnsmc|prncma:0}"
DATA "{prnmod:1} {prnsrl|prnsmc|prncma:0}"
DATA "{prnmod:1} {prnuse:0}"
DATA "{prnmod:1}"
DATA "PRINT {prnuse:1} {prnsrl|prnsmc|prncma:0}"
DATA "PRINT {prnsrl|prnsmc|prncma:0}"
DATA "PRINT {prnuse:0}"
DATA "PRINT"
 
DATA 0x094,"prnsrl::={prncma|prnsmc|self:1} {expr:0},|{expr:0},"
DATA 0x095,"prnsrl::={prncma|prnsmc|self:1} {expr:0};|{expr:0};"
 
DATA 0x096,"{prnmod:3} {prnuse:2} {prnsmc|prncma|prnsrl:1} {expr:0}"
DATA "{prnmod:2} {prnsmc|prncma|prnsrl:1} {expr:0}"
DATA "{prnmod:1} {prnsmc|prncma|prnsrl|expr:0}"
DATA "PRINT {prnuse:2} {prnsmc|prncma|prnsrl:1} {expr:0}"
DATA "PRINT {prnsmc|prncma|prnsrl:1} {expr:0}"
DATA "PRINT {prnsmc|prncma|prnsrl|expr:0}"
 
 
DATA 0x097,*,"{#tabi:0}'{#raw:2}"
'       0x098           nothing?
DATA 0x099,*,"$INCLUDE: '{#raw:0}"
DATA 0x09a,"BEEP"
DATA 0x09b,"BLOAD {0}"
DATA 0x09c,"BLOAD {1}, {0}"
DATA 0x09d,"BSAVE {2}, {1}, {0}"
DATA 0x09e,"CHDIR {0}"
DATA 0x09f,"CIRCLE {##circle-args}"
DATA 0x0a0,"CIRCLE {##circle-args}"
DATA 0x0a1,2,"CLEAR{##varargs}"
DATA 0x0a2,2,"CLOSE{##varargs}"
DATA 0x0a3,"CLS {expr:0}|CLS"
DATA 0x0a4,2,"COLOR{##varargs}"
 
DATA 0x0a5,4,"decl::=COMMON {declmod:0}{#blockname:2}"
DATA "decl::=COMMON{#blockname:2}"
 
DATA 0x0a6,*,"DATA{#cstr:2}"
DATA 0x0a7,"DATE$ = {0}"
DATA 0x0a8,"DEF SEG"
DATA 0x0a9,"DEF SEG = {0}"
 
DATA 0x0aa,"DRAW {0}"
DATA 0x0ab,"ENVIRON {0}"
DATA 0x0ac,2,"ERASE{##varargs}"
DATA 0x0ad,"ERROR {0}"
DATA 0x0ae,"FILES"
DATA 0x0af,"FILES {0}"
 
DATA 0x0b0,"GET {0}"
DATA 0x0b1,"GET {1}, {0}"
DATA 0x0b2,2,"GET {1}, , {0}"
DATA 0x0b3,2,"GET {2}, {1}, {0}"
DATA 0x0b4,"GET {1}, {0}"
DATA 0x0b5,2,"PUT {1}, {0}, {#action-verb}"
 
 
DATA 0x0b6,"inputs::={inputs:1}, {0}|{0}"
DATA 0x0b7,"IOCTL {1}, {0}"
DATA 0x0b8,2,"KEY {#keymode}"
DATA 0x0b9,"KEY {1}, {0}"
DATA 0x0ba,"KILL {0}"
DATA 0x0bb,2,"LINE {##line-args}"
DATA 0x0bc,2,"LINE {##line-args}"
DATA 0x0bd,2,"LINE {##line-args}"
DATA 0x0be,2,"LINE {##line-args}"
DATA 0x0bf,"LET "
 
DATA 0x0c0,2,"input::=LINE {finput:1} {0}"
DATA "input::=LINE INPUT {##input-args} {0}"
 
DATA 0x0c1,2,"LOCATE{##varargs}"
DATA 0x0c2,2,"LOCK {##lock-args}"
DATA 0x0c3,"prnmod::=LPRINT"
DATA 0x0c4,"LSET {0} = {1}"
DATA 0x0c5,"MID$({0}, {2}) = {1}"
DATA 0x0c6,"MID$({0}, {3}, {2}) = {1}"
DATA 0x0c7,"MKDIR {0}"
DATA 0x0c8,"NAME {1} AS {0}"
 
DATA 0x0c9,2,"OPEN {1} {#open-args} AS {0}"
DATA 0x0ca,2,"OPEN {2} {#open-args} AS {1} LEN = {0}"
DATA 0x0cb,"OPEN {2}, {1}, {0}"
DATA 0x0cc,"OPEN {3}, {2}, {1}, {0}"
DATA 0x0cd,"OPTION BASE 0"
DATA 0x0ce,"OPTION BASE 1"
DATA 0x0cf,"OUT {1}, {0}"
 
 
 
DATA 0x0d0,"PAINT {2}{nularg:1}{nularg:0}"
DATA "PAINT {2}, {nularg:1}, {0}"
DATA "PAINT {2}, {1}{nularg:0}"
DATA "PAINT {2}, {1}, {0}"
DATA 0x0d1,"PAINT {3}, {2}, {1}, {0}"
DATA 0x0d2,"PALETTE"
DATA 0x0d3,"PALETTE {1}, {0}"
DATA 0x0d4,"PALETTE {0}"
DATA 0x0d5,"PCOPY {1}, {0}"
DATA 0x0d6,"PLAY {0}"
 
DATA 0x0d7,"POKE {1}, {0}"
DATA 0x0d8,"PRESET {0}"
DATA 0x0d9,"PRESET {0}, {1}"
DATA 0x0da,"PSET {0}"
DATA 0x0db,"PSET {1}, {0}"
DATA 0x0dd,"PUT {1}, {0}"
DATA 0x0de,2,"PUT {1}, , {0}"
DATA 0x0df,2,"PUT {2}, {1}, {0}"
 
DATA 0x0e0,"RANDOMIZE"
DATA 0x0e1,"RANDOMIZE {0}"
DATA 0x0e2,"{self:1}, {0}|READ {0}"
DATA 0x0e3,*,"REM{#raw}"
DATA 0x0e4,"RESET"
DATA 0x0e5,"RMDIR {0}"
DATA 0x0e6,"RSET {0} = {1}"
 
DATA 0x0e7,2,"SCREEN{##varargs}"
DATA 0x0e8,"SEEK {1}, {0}"
DATA 0x0e9,"SHELL"
DATA 0x0ea,"SHELL {0}"
DATA 0x0eb,"SLEEP"
DATA 0x0ec,"SOUND {1}, {0}"
DATA 0x0ed,2,"SWAP {1}, {0}"
DATA 0x0ee,"SYSTEM"
DATA 0x0ef,"TIME$ = {0}"
DATA 0x0f0,"TROFF"
DATA 0x0f1,"TRON"
DATA 0x0f2,2,"UNLOCK {##lock-args}"
DATA 0x0f3,"VIEW ({5}, {4})-({3}, {2}){nularg:1}{nularg:0}"
DATA "VIEW ({5}, {4})-({3}, {2}), {nularg:1}, {0}"
DATA "VIEW ({5}, {4})-({3}, {2}), {1}{nularg:0}"
DATA "VIEW ({5}, {4})-({3}, {2})"
DATA 0x0f4,"VIEW"
 
DATA 0x0f5,"VIEW PRINT"
DATA 0x0f6,"VIEW PRINT {1} TO {0}"
 
DATA 0x0f7,"VIEW SCREEN ({5}, {4})-({3}, {2}){nularg:1}{nularg:0}"
DATA "VIEW SCREEN ({5}, {4})-({3}, {2}), {nularg:1}, {0}"
DATA "VIEW SCREEN ({5}, {4})-({3}, {2}), {1}{nularg:0}"
DATA "VIEW SCREEN ({5}, {4})-({3}, {2})"
DATA 0x0f8,"WIDTH {1}{nularg:0}|WIDTH {1}, {0}"
DATA 0x0f9,"WIDTH LPRINT {0}"
DATA 0x0fa,"WIDTH {1}, {0}"
DATA 0x0fb,"WINDOW ({3}, {2})-({1}, {0})"
DATA 0x0fc,"WINDOW"
DATA 0x0fd,"WINDOW SCREEN ({3}, {2})-({1}, {0})"
DATA 0x0fe,"prnmod::=WRITE"
DATA 0x0ff,"prnuse::=USING {0};"
 
DATA .default expr
 
DATA 0x100,"{1} + {0}"
DATA 0x101,"{1} AND {0}"
DATA 0x102,"{1} / {0}"
DATA 0x103,"{1} = {0}"
DATA 0x104,"{1} EQV {0}"
DATA 0x105,"ABS({0})"
DATA 0x106,"ASC({0})"
DATA 0x107,"ATN({0})"
DATA 0x108,"C{#type-abbr}({0})"
DATA 0x109,"CHR$({0})"
DATA 0x10a,"COMMAND$"
DATA 0x10b,"COS({0})"
DATA 0x10c,"CSRLIN"
DATA 0x10d,"CVD({0})"
DATA 0x10e,"CVDMBD({0})"
DATA 0x10f,"CVI({0})"
DATA 0x110,"CVL({0})"
DATA 0x111,"CVS({0})"
DATA 0x112,"CVSMBF({0})"
DATA 0x113,"DATE$"
DATA 0x114,"ENVIRON$({0})"
DATA 0x115,"EOF({0})"
DATA 0x116,"ERDEV"
DATA 0x117,"ERDEV$"
DATA 0x118,"ERL"
DATA 0x119,"ERR"
DATA 0x11a,"EXP({0})"
DATA 0x11b,"FILEATTR({1}, {0})"
DATA 0x11c,"FIX({0})"
DATA 0x11d,"FRE({0})"
DATA 0x11e,"FREEFILE"
DATA 0x11f,"HEX$({0})"
DATA 0x120,"INKEY$"
DATA 0x121,"INP({0})"
DATA 0x122,"INPUT$({0})"
DATA 0x123,"INPUT$({1}, {0})"
DATA 0x124,"INSTR({1}, {0})"
DATA 0x125,"INSTR({2}, {1}, {0})"
DATA 0x126,"INT({0})"
DATA 0x127,"IOCTL$({0})"
DATA 0x128,"LBOUND({0})"
DATA 0x129,"LBOUND({1}, {0})"
DATA 0x12a,"LCASE$({0})"
DATA 0x12b,"LTRIM$({0})"
DATA 0x12c,"LEFT$({1}, {0})"
DATA 0x12d,2,"LEN({0})"
DATA 0x12e,"LOC({0})"
DATA 0x12f,"LOF({0})"
DATA 0x130,"LOG({0})"
DATA 0x131,"LPOS({0})"
DATA 0x132,"MID$({1}, {0})"
DATA 0x133,"MID$({2}, {1}, {0})"
DATA 0x134,"MKD$({0})"
DATA 0x135,"MKDMBF$({0})"
DATA 0x136,"MKI$({0})"
DATA 0x137,"MKL$({0})"
DATA 0x138,"MKS$({0})"
DATA 0x139,"MKSMBF({0})"
DATA 0x13a,"OCT$({0})"
DATA 0x13b,"PEEK({0})"
DATA 0x13c,"PEN"
DATA 0x13d,"PLAY"
DATA 0x13e,"PMAP({1}, {0})"
DATA 0x13f,"POINT({0})"
DATA 0x140,"POINT({1}, {0})"
DATA 0x141,"POS({0})"
DATA 0x142,"RIGHT$({1}, {0})"
DATA 0x143,"RND"
DATA 0x144,"RND({0})"
DATA 0x145,"RTRIM$({0})"
DATA 0x146,"SADD({0})"
DATA 0x147,"SCREEN({1}, {0})"
DATA 0x148,"SCREEN({2}, {1}, {0})"
DATA 0x149,"SEEK({0})"
DATA 0x14a,"SETMEM({0})"
DATA 0x14b,"SGN({0})"
DATA 0x14c,"SHELL({0})"
DATA 0x14d,"SIN({0})"
DATA 0x14e,"SPACE$({0})"
DATA 0x14f,"SQR({0})"
DATA 0x150,"STICK({0})"
DATA 0x151,"STR$({0})"
DATA 0x152,"STRIG({0})"
DATA 0x153,"STRING$({1}, {0})"
DATA 0x154,"TAN({0})"
DATA 0x155,"TIME$"
DATA 0x156,"TIMER"
DATA 0x157,"UBOUND({0})"
DATA 0x158,"UBOUND({1}, {0})"
DATA 0x159,"UCASE$({0})"
DATA 0x15a,"VAL({0})"
DATA 0x15b,"VARPTR({0})"
DATA 0x15c,2,"VARPTR$({0})"
DATA 0x15d,"VARSEG({0})"
DATA 0x15e,"{1} >= {0}"
DATA 0x15f,"{1} > {0}"
DATA 0x160,"{1} \ {0}"
DATA 0x161,"{1} IMP {0}"
DATA 0x162,"{1} <= {0}"
DATA 0x163,"{1} < {0}"
DATA 0x164,"{#hprm}"
DATA 0x165,2,"{#int}"
DATA 0x166,4,"{#lng}"
DATA 0x167,2,"{#int&h}"
DATA 0x168,4,"{#lng&h}"
DATA 0x169,2,"{#int&o}"
DATA 0x16a,4,"{#lng&o}"
DATA 0x16b,4,"{#sng}"
DATA 0x16c,8,"{#dbl}"
DATA 0x16d,*,"{#qstr}"
DATA 0x16e,"({0})"
DATA 0x16f,"{1} MOD {0}"
DATA 0x170,"{1} * {0}"
DATA 0x171,"{1} <> {0}"
DATA 0x172,"{#nul}"
DATA 0x173,"nularg::={#nul}"
DATA 0x174,"NOT {0}"
DATA 0x175,"{1} OR {0}"
DATA 0x176,"{1} ^ {0}"
DATA 0x177,"{1} - {0}"
DATA 0x178,"-{0}"
DATA 0x179,"{1} XOR {0}"
 
DATA .default
 
DATA 0x17a,"UEVENT"
DATA 0x17b,"SLEEP {0}"
DATA 0x17c,6,"astype::={#tabi:4}AS STRING * {#int:2}"
DATA 0x17d,2,"decl::=DIM {declmod:0}|DIM"
 
DATA .
 
REM $STATIC
'
' This subroutine is called whenever a program line has been decoded.
'
SUB AOutput (ProgramLine AS STRING)
 
    STATIC OutputLines
 
    OutputLines = OutputLines + 1
 
    IF LEN(OutputContents$) THEN
        OutputContents$ = OutputContents$ + CHR$(10) + ProgramLine
    ELSE
        OutputContents$ = ProgramLine
    END IF
 
END SUB
 
SUB DbgOutput (DbgTxt AS STRING)
 
    EXIT SUB
 
    PRINT #5, DbgTxt
 
END SUB
 
FUNCTION DbgPlainText$ (Txt2$)
 
    Txt$ = Txt2$
 
    DO
        Marker = INSTR(Txt$, MKL$(0))
        IF Marker = 0 THEN EXIT DO
 
        TagTxtLen = CVI(MID$(Txt$, Marker + 4, 2))
        TagParam = CVI(MID$(Txt$, Marker + 6, 2))
        TagTxt$ = MID$(Txt$, Marker + 8, TagTxtLen)
 
        TagParam$ = ITOA(TagParam)
        IF TagParam > 0 THEN TagParam$ = "+" + TagParam$
        TagParam$ = "$" + TagParam$
        IF TagTxt$ <> "" THEN TagParam$ = TagTxt$ + ":" + TagParam$
 
 
        Txt$ = LEFT$(Txt$, Marker - 1) + "{" + TagParam$ + "}" + MID$(Txt$, Marker + 8 + TagTxtLen)
 
    LOOP
 
 
    DO
        Marker = INSTR(Txt$, CHR$(&HD))
        IF Marker = 0 THEN EXIT DO
 
        IF CVI(MID$(Txt$, Marker, 2)) = &HD THEN
            Txt$ = LEFT$(Txt$, Marker - 1) + "®newline¯" + MID$(Txt$, Marker + 2)
        ELSEIF CVI(MID$(Txt$, Marker, 2)) = &H10D THEN
            Txt$ = LEFT$(Txt$, Marker - 1) + "®indent¯" + MID$(Txt$, Marker + 4)
        ELSE
            Txt$ = LEFT$(Txt$, Marker - 1) + "®rle¯" + MID$(Txt$, Marker + 3)
        END IF
 
    LOOP
 
    DbgPlainText$ = Txt$
 
END FUNCTION
 
'
' Iterates through the various rules for a token contained in the ParseRules
' array and stops when one of them works.
'
SUB DefaultParseRule
 
    DIM ParseRule AS STRING
 
    IF PCODE < LBOUND(ParseRules) OR PCODE > UBOUND(ParseRules) THEN EXIT SUB
    ParseRule = ParseRules(PCODE)
 
    IF ParseRule = "" THEN EXIT SUB
 
    DbgOutput ""
    DbgOutput "PCODE = 0x" + HEX$(PCODE)
    DbgOutput "HPARAM = 0x" + HEX$(HPARAM)
    DbgOutput ""
    'DumpStack
 
    FOR RuleBegin = 3 TO LEN(ParseRule) STEP 4
 
        RuleLn = CVI(MID$(ParseRule, RuleBegin + 0, 2))
        RuleID = CVI(MID$(ParseRule, RuleBegin + 2, 2))
 
        RuleTxt$ = MID$(ParseRule, RuleBegin + 4, RuleLn)
 
        IF ExecuteParseRule(RuleID, RuleTxt$) THEN EXIT FOR
 
        RuleBegin = RuleBegin + RuleLn
 
    NEXT RuleBegin
 
END SUB
 
'
' Returns the string of the first rule in a compound|parse|rule, and removes
' it from the input string.
'
' If the rule does not have a rule id (ident::=), DefaultRuleID is assigned.
'
FUNCTION DelimitParseRule$ (ParseRule AS STRING, DefaultRuleID AS STRING)
 
    DIM FirstRule AS STRING
 
    '----------------------------------------------------------------------------
    ' Locate the first instance of the rule delimiter "|" that does not occur
    ' inside a rule {tag}
    '----------------------------------------------------------------------------
    RuleOffset = 1
    RuleEnd = LEN(ParseRule) + 1
 
    DO
   
        BraceOffset = INSTR(RuleOffset, ParseRule, "{")
        IF BraceOffset = 0 THEN BraceOffset = RuleEnd
 
        PipeOffset = INSTR(RuleOffset, ParseRule, "|")
 
        RuleOffset = INSTR(BraceOffset, ParseRule, "}")
        IF RuleOffset = 0 THEN RuleOffset = RuleEnd
 
    LOOP UNTIL PipeOffset < BraceOffset
 
    IF PipeOffset = 0 THEN PipeOffset = RuleEnd
 
 
    '----------------------------------------------------------------------------
    ' Extract the first rule and return if there is nothing left.
    '----------------------------------------------------------------------------
    FirstRule = LEFT$(ParseRule, PipeOffset - 1)
    ParseRule = MID$(ParseRule, PipeOffset + 1)
 
 
    '----------------------------------------------------------------------------
    ' If the first rule has a symbol on the left-hand side and the next rule
    ' does not, the next rule inherits the symbol.
    '----------------------------------------------------------------------------
    RuleLHS$ = GetParseRuleLHS(FirstRule)
 
    IF RuleLHS$ = "" AND DefaultRuleID <> "" THEN
        RuleLHS$ = DefaultRuleID
        FirstRule = DefaultRuleID + "::=" + FirstRule
    END IF
 
    DelimitParseRule = FirstRule
    IF ParseRule = "" THEN EXIT FUNCTION
 
    IF RuleLHS$ <> "" AND GetParseRuleLHS(ParseRule) = "" THEN
        ParseRule = RuleLHS$ + "::=" + ParseRule
    END IF
 
END FUNCTION
 
'
' For debugging only
'
SUB DumpStack
 
    PRINT #5, "The stack has"; SP; "entries"
 
    FOR i = 1 TO SP
        ID = CVI(LEFT$(STACK(i), 2))
        Txt$ = MID$(STACK(i), 3)
 
 
        DO
            Marker = INSTR(Txt$, CHR$(&HD))
            IF Marker = 0 THEN EXIT DO
 
            IF CVI(MID$(Txt$, Marker, 2)) = &HD THEN
                Txt$ = LEFT$(Txt$, Marker - 1) + "®newline¯" + MID$(Txt$, Marker + 2)
            ELSEIF CVI(MID$(Txt$, Marker, 2)) = &H10D THEN
                Txt$ = LEFT$(Txt$, Marker - 1) + "®indent¯" + MID$(Txt$, Marker + 4)
            ELSE
                Txt$ = LEFT$(Txt$, Marker - 1) + "®rle¯" + MID$(Txt$, Marker + 3)
            END IF
 
        LOOP
 
        PRINT #5, ITOA$(i); ": 0x"; HEX$(ID),
 
        TRIM = 76 - POS(0) - LEN(Txt$)
        IF TRIM < 0 THEN PRINT #5, LEFT$(Txt$, LEN(Txt$) + TRIM); " ..." ELSE PRINT #5, Txt$
        '80-60-19=1
 
 
 
    NEXT i
END SUB
 
FUNCTION ExecuteParseRule% (RuleID AS INTEGER, ParseRule AS STRING)
 
    DIM RuleTxt AS STRING
    DIM TagTxt AS STRING
    DIM OutTxt AS STRING
 
    RuleOffset = 1
 
    '
    ' NOTE: Since the stack is flushed immediately upon seeing a leading period,
    ' rules should not have non-flushing alternatives.
    '
    IF LEFT$(ParseRule, 1) = "." THEN
        FlushStack
        RuleOffset = 2
    END IF
 
    InitialSP = SP
    FinalSP = SP
    RuleTxt = ParseRule
 
    DbgOutput "Trying rule: " + Quote(ParseRule)
 
    DO
 
        DbgOutput "Rule: " + ParseRule
        DbgOutput "Output: " + OutTxt
 
        TagBegin = INSTR(RuleOffset, RuleTxt, "{")
        IF TagBegin = 0 THEN TagBegin = LEN(RuleTxt) + 1
 
        TagEnd = INSTR(TagBegin, RuleTxt, "}") + 1
 
        OutTxt = OutTxt + MID$(RuleTxt, RuleOffset, TagBegin - RuleOffset)
 
        IF TagEnd <= TagBegin THEN EXIT DO
 
        TagTxt = MID$(RuleTxt, TagBegin + 1, TagEnd - TagBegin - 2)
 
        SELECT CASE TokenizeTag(TagTxt, TagParam)
 
            '------------------------------------------------------------------------
            ' If a relative stack tag is used, we will need to wait until all the
            ' absolute tags have been processed before we can calculate the tag
            ' offset, so we insert a marker into OutTxt.
            '------------------------------------------------------------------------
            CASE TagType.StackREL
                OutTxt = OutTxt + MKL$(0) + MKI$(LEN(TagTxt)) + MKI$(TagParam) + TagTxt
                RuleOffset = TagEnd
 
 
            CASE TagType.StackABS
 
                IF NOT ValidateStackTag(RuleID, TagTxt, TagParam) THEN
                    ExecuteParseRule = 0
                    DbgOutput "Rule REJECTED!"
                    EXIT FUNCTION
                ELSE
                    IF OffsetSP < SP THEN OutTxt = OutTxt + MID$(STACK(SP - TagParam), 3)
                    IF SP - TagParam - 1 < FinalSP THEN FinalSP = SP - TagParam - 1
                END IF
 
                RuleOffset = TagEnd
 
 
            CASE TagType.Recursive
                RuleTxt = LEFT$(RuleTxt, TagBegin - 1) + GetTaggedItem(TagTxt, TagParam) + MID$(RuleTxt, TagEnd)
                RuleOffset = TagBegin
 
 
            CASE TagType.TokenData
                OutTxt = OutTxt + GetTaggedItem(TagTxt, TagParam)
                RuleOffset = TagEnd
 
 
        END SELECT
 
 
 
 
    LOOP WHILE RuleOffset <= LEN(RuleTxt)
 
    DbgOutput "Rule: " + ParseRule
    DbgOutput "Output: " + OutTxt
 
    SP = FinalSP
 
    DO
        Marker = INSTR(OutTxt, MKL$(0))
        IF Marker = 0 THEN EXIT DO
 
        TagTxtLen = CVI(MID$(OutTxt, Marker + 4, 2))
        TagParam = CVI(MID$(OutTxt, Marker + 6, 2))
        TagTxt = MID$(OutTxt, Marker + 8, TagTxtLen)
 
        IF NOT (ValidateStackTag(RuleID, TagTxt, TagParam)) THEN
            SP = InitialSP
            ExecuteParseRule = 0
            DbgOutput "Rule REJECTED!"
            EXIT FUNCTION
        END IF
 
        OutTxt = LEFT$(OutTxt, Marker - 1) + MID$(STACK(SP - TagParam), 3) + MID$(OutTxt, Marker + 8 + TagTxtLen)
        IF SP - TagParam - 1 < FinalSP THEN FinalSP = SP - TagParam - 1
    LOOP
 
    FOR SP = InitialSP TO FinalSP + 1 STEP -1: STACK(SP) = "": NEXT SP
    SP = FinalSP
 
    PUSH RuleID, OutTxt
    ExecuteParseRule = -1
 
    DbgOutput "Rule ACCEPTED!"
 
    'PCODE = RuleID
 
END FUNCTION
 
FUNCTION ExtractProgramLine% (ProgramLine AS STRING)
 
END FUNCTION
 
'
' Generates a /blockname/ as used in COMMON statements, using the ID at
' CODE(DP)
'
FUNCTION FetchBlockName$ (DP AS INTEGER)
 
    ID = FetchINT(DP)
    IF ID <> -1 THEN x$ = " /" + GetID(ID) + "/" ELSE x$ = ""
 
END FUNCTION
 
'
' Reads a null-terminate string. These are only found in DATA statements
' and the null always seems to be at the end of the string anyway, but we
' will process it properly to be sure.
'
FUNCTION FetchCSTR$ (DP AS INTEGER)
 
    CSTR$ = FetchRAW(DP)
 
    null = INSTR(CSTR$, CHR$(0))
 
    IF null THEN CSTR$ = LEFT$(CSTR$, null - 1)
 
    FetchCSTR$ = CSTR$
 
END FUNCTION
 
'
' Fetches an identifier from the current TOKEN data by performing a symbol
' table lookup on the word at the specified offset.
'
FUNCTION FetchID$ (Offset AS INTEGER)
 
    FetchID$ = ""
 
    IF Offset < 0 OR Offset > LEN(TOKEN) - 4 THEN EXIT FUNCTION
 
    FetchID$ = GetID(CVI(MID$(TOKEN, Offset + 3, 2)))
 
END FUNCTION
 
FUNCTION FetchIDList$ (DP AS INTEGER)
 
 
    TkLen = LEN(TOKEN)
    IF DP < 0 OR DP > TkLen - 2 THEN EXIT FUNCTION
 
    FOR i = DP + 3 TO TkLen - 1 STEP 2
 
        ID$ = GetID(CVI(MID$(TOKEN, i, 2)))
 
        IF IdList$ <> "" THEN IdList$ = IdList$ + ", "
        IdList$ = IdList$ + ID$
 
    NEXT i
 
    FetchIDList = IdList$
 
END FUNCTION
 
'
' Returns the integer at the specified zero-based offset from the start
' of the token data.
'
FUNCTION FetchINT% (Offset AS INTEGER)
 
    FetchINT = -1
 
    IF Offset < 0 OR Offset > LEN(TOKEN) - 4 THEN EXIT FUNCTION
 
    FetchINT = CVI(MID$(TOKEN, Offset + 3, 2))
 
END FUNCTION
 
'
' Returns the integer at the specified zero-based offset from the start
' of the token data as a LONG value.
'
FUNCTION FetchINTASLONG& (Offset AS INTEGER)
 
    FetchINTASLONG = -1
 
    IF Offset < 0 OR Offset > LEN(TOKEN) - 4 THEN EXIT FUNCTION
 
    FetchINTASLONG = CVI(MID$(TOKEN, Offset + 3, 2)) AND &HFFFF&
 
END FUNCTION
 
'
' Reads a literal 64-bit float from the p-code and returns its string
' representation. Using the "{dbl}" tag in the SHIFT procedure is a more
' convienient method to extract literals.
'
' The IP is passed by reference, and will be incremented to the code
' following the literal. There is no radix option for floating point values.
'
FUNCTION FetchLiteralDBL$ (DP)
 
    IF DP > UBOUND(CODE) THEN
        FetchLiteralDBL$ = "0#"
        EXIT FUNCTION
    END IF
 
    Value# = CVD(MID$(TOKEN, DP + 3, 8))
    Txt$ = LTRIM$(STR$(Value#))
 
 
    ' If the single and double precision representations are equal, we will
    ' insert a # to indicate double precision.
 
    IF Value# = CSNG(Value#) THEN Txt$ = Txt$ + "#"
 
    FetchLiteralDBL$ = Txt$
 
END FUNCTION
 
'
' Reads a literal 16-bit integer from the code and returns its string
' representation. Using the "{int}" tag in ExecuteParseRule is a more
' convienient method to extract literals.
'
' The Radix parameter may be 8, 10 or 16 to produce
' the desired number format, or use the "{int&o}" and "{int&h}" tags.
'
FUNCTION FetchLiteralINT$ (Offset AS INTEGER, Radix AS INTEGER)
 
    DIM Value AS INTEGER
 
    IF Offset < 0 OR Offset > LEN(TOKEN) - 4 THEN
        FetchLiteralINT$ = "0"
        EXIT FUNCTION
    END IF
 
    Value = CVI(MID$(TOKEN, Offset + 3, 2))
 
    SELECT CASE Radix
 
        CASE 8: Txt$ = "&O" + OCT$(Value)
        CASE 10: Txt$ = ITOA$(Value)
        CASE 16: Txt$ = "&H" + HEX$(Value)
 
        CASE ELSE: Txt$ = "[bad radix]"
 
    END SELECT
 
    FetchLiteralINT$ = Txt$
 
END FUNCTION
 
'
' Reads a literal 32-bit integer from the code and returns its string
' representation. Using the "{lng}" tag in ExecuteParseRule is a more
' convienient method to extract literals.
'
' The Radix parameter may be 8, 10 or 16 to produce the desired number
' format, or use the "{lng&o}" and "{lng&h}" tags.
'
FUNCTION FetchLiteralLNG$ (Offset AS INTEGER, Radix AS INTEGER)
 
    DIM Value AS LONG
 
    IF Offset < 0 OR Offset > LEN(TOKEN) - 6 THEN
        FetchLiteralLNG$ = "0"
        EXIT FUNCTION
    END IF
 
    Value = CVL(MID$(TOKEN, Offset + 3, 4))
 
    SELECT CASE Radix
 
        CASE 8: Txt$ = "&O" + OCT$(Value)
        CASE 10: Txt$ = LTOA$(Value)
        CASE 16: Txt$ = "&H" + HEX$(Value)
 
        CASE ELSE: Txt$ = "[bad radix]"
 
    END SELECT
 
    IF Value < 65536 THEN Txt$ = Txt$ + "&"
 
    FetchLiteralLNG$ = Txt$
 
END FUNCTION
 
'
' Reads a literal 32-bit float from the p-code and returns its string
' representation. Using the "{sng}" tag in the SHIFT procedure is a more
' convienient method to extract literals.
'
' The IP is passed by reference, and will be incremented to the code
' following the literal. There is no radix option for floating point values.
'
FUNCTION FetchLiteralSNG$ (DP)
 
    IF OffsetIP > UBOUND(CODE) THEN
        FetchLiteralSNG$ = "0"
        EXIT FUNCTION
    END IF
 
    Value! = CVS(MID$(TOKEN, DP + 3, 4))
 
    Txt$ = LTRIM$(STR$(Value!))
 
    FetchLiteralSNG$ = Txt$
 
END FUNCTION
 
FUNCTION FetchLNG& (Offset AS INTEGER)
 
    FetchLNG = -1
 
    IF Offset < 0 OR Offset > LEN(TOKEN) - 6 THEN EXIT FUNCTION
 
    FetchLNG = CVL(MID$(TOKEN, Offset + 3, 4))
 
END FUNCTION
 
FUNCTION FetchRAW$ (Offset AS INTEGER)
 
    IF Offset < 0 OR Offset > LEN(TOKEN) - 2 THEN EXIT FUNCTION
 
    FetchRAW$ = MID$(TOKEN, 3 + Offset)
 
END FUNCTION
 
FUNCTION FindRuleDelimiter% (ParseRule AS STRING)
 
    RuleOffset = 1
    RuleEnd = LEN(ParseRule) + 1
 
    DO WHILE RuleOffset < RuleEnd
   
        BraceOffset = INSTR(RuleOffset, ParseRule, "{")
        PipeOffset = INSTR(RuleOffset, ParseRule, "|")
   
        IF BraceOffset = 0 OR PipeOffset <= BraceOffset THEN EXIT DO
 
        RuleOffset = INSTR(BraceOffset + 1, ParseRule, "}")
        IF RuleOffset = 1 THEN EXIT DO
 
    LOOP
 
    FindRuleDelimiter = PipeOffset
 
END FUNCTION
 
'
' Flushes all stack entries to STACK(0), ready for final processing into
' a program line.
'
SUB FlushStack
 
    FOR i = 1 TO SP
        STACK(0) = STACK(0) + MID$(STACK(i), 3)
        STACK(i) = ""
    NEXT i
 
    SP = 0
 
END SUB
 
'
' Returns an integer identifier for a parse rule symbol
'
FUNCTION GetHashedSymbol (ParseRuleSymbol AS STRING)
    DIM LookupSymbol AS STRING
 
    SymbolID$ = LTRIM$(RTRIM$(ParseRuleSymbol))
 
    '----------------------------------------------------------------------------
    ' Parse rule symbols my be literal integers
    '----------------------------------------------------------------------------
    IF StringToINT(SymbolID$, SymbolID%) THEN
        GetHashedSymbol% = SymbolID%
        EXIT FUNCTION
    END IF
    
    Hash = HashPJW(SymbolID$)
 
    LookupSymbol = "[" + SymbolID$ + "]"
 
    SymbolOffset = INSTR(SymbolHashTable(Hash), LookupSymbol)
 
    IF SymbolOffset = 0 THEN
 
        SymbolID% = SymbolHashEntries
        SymbolID% = SymbolID% + UBOUND(ParseRules) + 1
        SymbolID$ = RIGHT$(SymbolHashTable(Hash), 2)
        IF SymbolID$ <> "" THEN SymbolID% = CVI(SymbolID$) + 1
 
        SymbolID$ = MKI$(SymbolID%)
 
        SymbolHashTable(Hash) = SymbolHashTable(Hash) + LookupSymbol + SymbolID$
 
        SymbolHashEntries = SymbolHashEntries + 1
 
    ELSE
 
        SymbolOffset = SymbolOffset + LEN(LookupSymbol)
 
        SymbolID$ = MID$(SymbolHashTable(Hash), SymbolOffset, 2)
        SymbolID% = CVI(SymbolID$)
 
    END IF
 
    GetHashedSymbol% = SymbolID% '+ UBOUND(ParseRules) + 1
 
 
END FUNCTION
 
'
' Reads an identifier from the symbol table data stored in the SYMTBL
' array.
'
FUNCTION GetID$ (SymTblOffset AS INTEGER)
 
    '----------------------------------------------------------------------------
    ' Convert offset to LONG to we can read above 32767
    '----------------------------------------------------------------------------
    SymTblOfs& = SymTblOffset AND &HFFFF&
 
    '----------------------------------------------------------------------------
    ' offset FFFF is used as a shortcut for "0" in statements such as
    ' ON ERROR GOTO 0
    '----------------------------------------------------------------------------
    IF SymTblOfs& = &HFFFF& THEN
        GetID$ = "0"
        EXIT FUNCTION
    END IF
 
 
    '----------------------------------------------------------------------------
    ' Make sure we can at least read the first 4 bytes
    '----------------------------------------------------------------------------
    IF SymTblOfs& \ 2 > UBOUND(SYMTBL) - 2 THEN
        GetID$ = "®QB45BIN:SymbolTableError¯"
        EXIT FUNCTION
    END IF
 
    DEF SEG = VARSEG(SYMTBL(1))
    Offset = VARPTR(SYMTBL(1))
 
    Symbol& = (Offset AND &HFFFF&) + SymTblOfs&
 
    SymbolFlags = PEEK(Symbol& + 2)
 
    IF SymbolFlags AND 2 THEN
 
        ' Short line numbers are stored as integers.
 
        NumericID& = PEEK(Symbol& + 4) OR PEEK(Symbol& + 5) * &H100&
        GetID$ = LTRIM$(STR$(NumericID&))
    ELSE
 
        ' Identifier is a text string - extract it. Note the string may be
        ' a line number.
 
        Length = PEEK(Symbol& + 3)
 
        IF SymTblOfs& \ 2 > UBOUND(SYMTBL) - (Length + 1) \ 2 THEN
            GetID$ = "SymbolTableError"
            EXIT FUNCTION
        END IF
 
        ID$ = STRING$(Length, CHR$(0))
        FOR i = 1 TO Length
            MID$(ID$, i, 1) = CHR$(PEEK(Symbol& + 3 + i))
        NEXT i
 
        GetID$ = ID$
    END IF
 
 
END FUNCTION
 
'
' Removes the parse rule id::= from a string and returns its numeric ID.
'
FUNCTION GetParseRuleID% (ParseRule AS STRING, TokenID AS INTEGER)
 
    '----------------------------------------------------------------------------
    ' The default rule ID is always the PCODE
    '----------------------------------------------------------------------------
 
    FOR i = 1 TO LEN(ParseRule)
 
        IF INSTR("{}|", MID$(ParseRule, i, 1)) THEN EXIT FOR
 
        IF MID$(ParseRule, i, 3) = "::=" THEN
            GetParseRuleID = SetHashedSymbol(LEFT$(ParseRule, i - 1), TokenID)
            ParseRule = MID$(ParseRule, i + 3)
            EXIT FUNCTION
        END IF
 
    NEXT i
 
    GetParseRuleID = -1
 
END FUNCTION
 
FUNCTION GetParseRuleLHS$ (ParseRule AS STRING)
 
    FOR i = 1 TO LEN(ParseRule)
 
        IF INSTR("{}|", MID$(ParseRule, i, 1)) THEN EXIT FOR
 
        IF MID$(ParseRule, i, 3) = "::=" THEN
            GetParseRuleLHS = LEFT$(ParseRule, i - 1)
            EXIT FUNCTION
        END IF
 
    NEXT i
 
END FUNCTION
 
FUNCTION GetTaggedItem$ (TagTxt AS STRING, DP AS INTEGER)
 
    DIM SubstTxt AS STRING
 
    SELECT CASE LCASE$(TagTxt)
     
        CASE "blockname": SubstTxt = FetchBlockName(DP)
        CASE "circle-args": SubstTxt = SubstTagCIRCLE
        CASE "input-args": SubstTxt = SubstTagINPUT
        CASE "line-args": SubstTxt = SubstTagLINE
        CASE "lock-args": SubstTxt = SubstTagLOCK
 
        CASE "open-args": SubstTxt = SubstTagOPEN
        CASE "action-verb": SubstTxt = SubstTagVERB
        CASE "keymode": SubstTxt = SubstTagKEY
        CASE "type-abbr": SubstTxt = GetTypeAbbr(HPARAM)
 
        CASE "call": SubstTxt = ParseCALL(0)
        CASE "call()": SubstTxt = ParseCALL(-1)
 
        CASE "defxxx": SubstTxt = SubstTagDEFxxx(QBBinDefType())
        CASE "newline": SubstTxt = MKI$(&H10D)
 
        CASE "newline-include": SubstTxt = MKI$(&H20D)
 
        CASE "tabh": SubstTxt = MKI$(&HD) + MKI$(HPARAM)
        CASE "tabi": SubstTxt = MKI$(&HD) + MKI$(FetchINT(DP))
        CASE "indent": SubstTxt = SPACE$(FetchINT(DP) AND &HFFFF&)
        CASE "type": SubstTxt = GetTypeName$(FetchINT(DP))
        CASE "id": SubstTxt = GetID(FetchINT(DP))
        CASE "id+": SubstTxt = GetID(FetchINT(DP)) + GetTypeSuffix(HPARAM)
        CASE "id-list": SubstTxt = FetchIDList(DP)
        CASE "id(decl)": SubstTxt = ParseArrayDecl
        CASE "id(expr)": SubstTxt = ParseArrayExpr
 
        CASE "hprm": SubstTxt = ITOA$(HPARAM)
        CASE "int": SubstTxt = FetchLiteralINT(DP, 10)
        CASE "int&h": SubstTxt = FetchLiteralINT(DP, 16)
        CASE "int&o": SubstTxt = FetchLiteralINT(DP, 8)
        CASE "label": SubstTxt = FetchID(DP): IF NOT IsLineNumber(SubstTxt) THEN SubstTxt = SubstTxt + ":"
 
        CASE "lng": SubstTxt = FetchLiteralLNG(DP, 10)
        CASE "lng&h": SubstTxt = FetchLiteralLNG(DP, 16)
        CASE "lng&o": SubstTxt = FetchLiteralLNG(DP, 8)
        CASE "nul": SubstTxt = ""
        CASE "sng": SubstTxt = FetchLiteralSNG(DP)
        CASE "dbl": SubstTxt = FetchLiteralDBL(DP)
        CASE "qstr": SubstTxt = Quote(FetchRAW(DP))
        CASE "cstr": SubstTxt = FetchCSTR(DP)
        CASE "raw": SubstTxt = FetchRAW(DP)
        CASE "varargs": SubstTxt = ParseVarArgs
        CASE "optargs":
        CASE "procdecl": SubstTxt = ParseProcDecl$(DP, 0)
        CASE "procdecl()": SubstTxt = ParseProcDecl$(DP, -1)
        CASE "proctype": SubstTxt = QBBinProcedureType
 
        CASE "thaddr": SanityCheck DP
 
        CASE ELSE:
            SubstTxt = "®QB45BIN:bad tag¯"
    END SELECT
 
    GetTaggedItem$ = SubstTxt
 
END FUNCTION
 
FUNCTION GetTotalLines%
 
    DIM TotalLines AS LONG
    DIM IncludeLines AS LONG
 
    TotalLines = 0
    IncludeLines = 0
 
    FTell& = LOC(QBBinFile) + 1
 
    GET #QBBinFile, 27, SymTblLen%
    ModuleLOC& = LOC(QBBinFile) + (SymTblLen% AND &HFFFF&) + 1
 
    SEEK #QBBinFile, ModuleLOC&
 
    DO
        GET #QBBinFile, , ModuleLen%
        SEEK #QBBinFile, LOC(QBBinFile) + (ModuleLen% AND &HFFFF&) + 9
 
        GET #QBBinFile, , NumTotLines%
        GET #QBBinFile, , NumIncLines%
 
        TotalLines = TotalLines + (NumTotLines% AND &HFFFF&)
        IncludeLines = IncludeLines + (NumIncLines% AND &HFFFF&)
 
 
        SEEK #QBBinFile, LOC(QBBinFile) + 5
        Byte$ = CHR$(0)
        GET #QBBinFile, , Byte$
 
        IF EOF(QBBinFile) THEN EXIT DO
 
        ProcedureCOUNT = ProcedureCOUNT + 1
 
        GET #QBBinFile, , NameLen%
        SEEK #QBBinFile, LOC(QBBinFile) + (NameLen% AND &HFFFF&) + 4
 
    LOOP
 
    REDIM ProcedureNAME(1 TO ProcedureCOUNT + 1) AS STRING
    REDIM ProcedureLOC(1 TO ProcedureCOUNT + 1) AS LONG
 
    SEEK #QBBinFile, ModuleLOC&
 
    FOR i = 1 TO ProcedureCOUNT
 
        GET #QBBinFile, , ModuleLen%
 
        ProcedureLOC(i) = LOC(QBBinFile) + (ModuleLen% AND &HFFFF&) + 17
        SEEK #QBBinFile, ProcedureLOC(i) + 1
 
        GET #QBBinFile, , ProcedureNameLEN%
        ProcedureNAME(i) = STRING$(ProcedureNameLEN%, 0)
        GET #QBBinFile, , ProcedureNAME(i)
        ProcedureNAME(i) = UCASE$(ProcedureNAME(i))
 
        '------------------------------------------------------------------------
        ' Incremental bubble sort of procedure names
        '------------------------------------------------------------------------
        IF QBBinOption.SortProceduresAZ THEN
            FOR j = i - 1 TO 1 STEP -1
                IF ProcedureNAME(j + 1) > ProcedureNAME(j) THEN EXIT FOR
                SWAP ProcedureNAME(j + 1), ProcedureNAME(j)
                SWAP ProcedureLOC(j + 1), ProcedureLOC(j)
            NEXT j
        END IF
 
        SEEK #QBBinFile, LOC(QBBinFile) + 4
    NEXT i
 
    FOR i = 1 TO ProcedureCOUNT
        'PRINT ProcedureNAME(i)
        QBBinProcedureIndex = QBBinProcedureIndex + MKL$(ProcedureLOC(i))
    NEXT i
 
    ERASE ProcedureNAME, ProcedureLOC
 
    SEEK #QBBinFile, FTell&
 
    IF QBBinOption.OmitIncludedLines THEN
        GetTotalLines = TotalLines - IncludedLines
    ELSE
        GetTotalLines = TotalLines
    END IF
 
END FUNCTION
 
'
' Returns the abbreviated name for a built-in type (ie: LNG or DBL).
'
FUNCTION GetTypeAbbr$ (TypeID AS INTEGER)
 
    GetTypeAbbr$ = TypeSpecifiers(LIMIT(TypeID, 0, 5), 2)
 
END FUNCTION
 
FUNCTION GetTypeName$ (TypeID AS INTEGER)
 
    LTypeID& = TypeID AND &HFFFF&
 
    IF LTypeID& > 5 THEN
        GetTypeName$ = GetID$(TypeID) ' User-define type
    ELSE
        GetTypeName$ = TypeSpecifiers(LTypeID&, 1)
    END IF
 
END FUNCTION
 
FUNCTION GetTypeSuffix$ (TypeID AS INTEGER)
 
    GetTypeSuffix$ = TypeSpecifiers(LIMIT(TypeID, 0, 5), 3)
 
END FUNCTION
 
'
' Implementation of PJW hash, written to avoid 32-bit overflow.
'
FUNCTION HashPJW% (Identifier AS STRING)
 
    DIM h AS LONG, g AS LONG, k AS LONG
 
 
    FOR i = 1 TO LEN(Identifier)
 
        k = ASC(MID$(Identifier, i, 1))
 
        h = h + (k \ 16)
 
        g = (h AND &HF000000) \ 2 ^ 20
 
        h = (h AND &HFFFFFF) * 16 + (k AND 15)
 
        IF g THEN h = h XOR (g \ 2 ^ 20)
 
    NEXT i
 
    HashPJW% = h MOD SymbolHashBuckets
 
END FUNCTION
 
FUNCTION IsLineNumber (ID AS STRING)
 
    Ch$ = LEFT$(ID, 1)
    IF Ch$ = "" THEN EXIT FUNCTION
    IF ASC(Ch$) >= 48 AND ASC(Ch$) < 57 THEN IsLineNumber = -1
 
END FUNCTION
 
FUNCTION ITOA$ (Value AS INTEGER)
 
    ITOA$ = LTRIM$(RTRIM$(STR$(Value)))
 
END FUNCTION
 
FUNCTION LIMIT (x, xMin, xMax)
 
    IF x < xMin THEN
        LIMIT = xMin
 
    ELSEIF x > xMax THEN
        LIMIT = xMax
 
    ELSE
        LIMIT = x
    END IF
 
END FUNCTION
 
FUNCTION LoadMainModule
 
    '----------------------------------------------------------------------------
    ' Read module size and convert to long to lose sign bit. Note that modules
    ' should always be a multiple of two in size since all the tokens are 16
    ' bits.
    '----------------------------------------------------------------------------
    IF EOF(QBBinFile) THEN EXIT FUNCTION
 
    GET #QBBinFile, , szModule%
    szModule& = (szModule% AND &HFFFF&)
    szModule% = (szModule& + 1) \ 2
 
    REDIM CODE(1 TO szModule%) AS INTEGER
    ReadToArrayINT QBBinFile, CODE(), szModule&
 
    '----------------------------------------------------------------------------
    ' There is always 16 bytes of data after a code block
    '----------------------------------------------------------------------------
    DIM Footer AS STRING * 16
    GET #QBBinFile, , Footer
 
    IF EOF(QBBinFile) THEN
        QBBinCloseFile
        EXIT FUNCTION
    END IF
 
    LoadMainModule = -1
    IP = LBOUND(CODE)
 
END FUNCTION
 
FUNCTION LoadNextProcedure
 
 
    IF QBBinProcedureIndex = "" THEN
        QBBinCloseFile
        EXIT FUNCTION
    END IF
 
    
    
    ProcedureLOC& = CVL(LEFT$(QBBinProcedureIndex, 4))
    QBBinProcedureIndex = MID$(QBBinProcedureIndex, 5)
    SEEK #QBBinFile, ProcedureLOC&
 
    DIM Junk AS STRING
 
 
 
    Junk = CHR$(0)
    GET #QBBinFile, , Junk
 
    IF EOF(QBBinFile) THEN
        QBBinCloseFile
        EXIT FUNCTION
    END IF
    
    GET #QBBinFile, , ProcNameLen%
 
    QBBinProcedureName = STRING$(ProcNameLen% AND &HFFFF&, 0)
    GET #QBBinFile, , QBBinProcedureName
    Junk = STRING$(3, 0)
    GET #QBBinFile, , Junk
 
    GET #QBBinFile, , ProcCodeLen%
 
    ReadToArrayINT QBBinFile, CODE(), ProcCodeLen% AND &HFFFF&
 
    DIM Footer AS STRING * 16
    GET #QBBinFile, , Footer
 
    LoadNextProcedure = -1
    IP = LBOUND(CODE)
 
END FUNCTION
 
SUB LoadParseRules
 
    DIM ParseRule AS STRING
 
    TokenLBound = &H7FFF
    TokenUBound = 0
    TokenLength = 0
 
    '----------------------------------------------------------------------------
    ' Clear the symbol hash table
    '----------------------------------------------------------------------------
    FOR i = 0 TO SymbolHashBuckets - 1: SymbolHashTable(i) = "": NEXT i
    SymbolHashEntries = 0
 
    '----------------------------------------------------------------------------
    ' PASS 1: Enumerate all tokens
    '----------------------------------------------------------------------------
    RestoreParseRules
 
    DO WHILE ReadParseRule(TokenPCODE, TokenLength, ParseRule)
 
        TokenLBound = MIN(TokenPCODE, TokenLBound)
        TokenUBound = MAX(TokenPCODE, TokenLBound)
 
    LOOP
 
    REDIM ParseRules(TokenLBound TO TokenUBound) AS STRING
 
 
    '----------------------------------------------------------------------------
    ' PASS 2: Generate token strings
    '----------------------------------------------------------------------------
    RestoreParseRules
 
    DO WHILE ReadParseRule(TokenPCODE, TokenLength, ParseRule)
 
        '------------------------------------------------------------------------
        ' If this is the first rule for this PCODE, then we'll write the
        ' length of the token data as the first word.
        '------------------------------------------------------------------------
        IF ParseRules(TokenPCODE) = "" THEN
            ParseRules(TokenPCODE) = MKI$(TokenLength)
        END IF
 
        RuleID = GetParseRuleID(ParseRule, TokenPCODE)
        IF RuleID = -1 THEN RuleID = TokenPCODE
 
        ParseRule = MKI$(LEN(ParseRule)) + MKI$(RuleID) + ParseRule
        ParseRules(TokenPCODE) = ParseRules(TokenPCODE) + ParseRule
 
    LOOP
 
    QBBinTok.SUBDEF = GetHashedSymbol("subdef")
    QBBinTok.FUNCDEF = GetHashedSymbol("funcdef")
    QBBinTok.DEFTYPE = GetHashedSymbol("deftype")
 
END SUB
 
'
' Returns the token id of the next unprocessed token without modifying IP.
' Neccessary for REDIM, which causes an array expression to behave like
' an array declaration, for reasons best known to the QB45 dev team.
'
FUNCTION LookAhead
 
 
    IF IP < LBOUND(CODE) OR IP > UBOUND(CODE) THEN
        LookAhead = -1
    ELSE
        LookAhead = CODE(IP) AND &H3FF
    END IF
 
END FUNCTION
 
FUNCTION LTOA$ (Value AS LONG)
 
    LTOA$ = LTRIM$(RTRIM$(STR$(Value)))
 
END FUNCTION
 
FUNCTION MAX% (x AS INTEGER, Y AS INTEGER)
 
    IF x > Y THEN MAX = x ELSE MAX = Y
 
END FUNCTION
 
FUNCTION MIN% (x AS INTEGER, Y AS INTEGER)
 
    IF x < Y THEN MIN = x ELSE MIN = Y
 
END FUNCTION
 
FUNCTION ParseArrayDecl$
 
    STATIC RuleIDLoaded AS INTEGER
    STATIC RuleAsTypeID AS INTEGER
    STATIC RuleDeclID AS INTEGER
    STATIC RuleDeclsID AS INTEGER
 
    IF NOT RuleIDLoaded THEN
        RuleAsTypeID = GetHashedSymbol("astype")
        RuleDeclID = GetHashedSymbol("decl")
        RuleDeclsID = GetHashedSymbol("decls")
    END IF
 
 
    nElmts = FetchINT(0)
    ID$ = FetchID(2) + GetTypeSuffix(HPARAM)
 
    IF StackPeek(0) = RuleAsTypeID THEN
        ArgC = 1
        AsType$ = "{0}"
    END IF
 
    WHILE nElmts > 0
 
        nElmts = nElmts - 1
 
        Indices$ = STAG(ArgC) + Indices$
        ArgC = ArgC + 1
 
        IF nElmts AND 1 THEN
            IF StackPeek(ArgC) <> &H18 THEN Indices$ = " TO " + Indices$
        ELSE
            IF nElmts THEN Indices$ = ", " + Indices$
        END IF
 
    WEND
 
    IF Indices$ <> "" THEN Indices$ = "(" + Indices$ + ")"
 
    IF StackPeek(ArgC) = RuleDeclsID THEN
        ParseArrayDecl$ = STAG(ArgC) + ", " + ID$ + Indices$ + AsType$
    ELSEIF StackPeek(ArgC) = RuleDeclID THEN
        ParseArrayDecl$ = STAG(ArgC) + " " + ID$ + Indices$ + AsType$
    ELSE
        ParseArrayDecl$ = ID$ + Indices$ + AsType$
    END IF
 
END FUNCTION
 
'
' Generates a parse rule for an array expression.
'
FUNCTION ParseArrayExpr$
 
    IF LookAhead = 28 THEN
        ParseArrayExpr = ParseArrayDecl
        EXIT FUNCTION
    END IF
 
    'IF PCODE = 15 THEN ArgC = 1
 
    nElmts = FetchINT(0)
    ID$ = FetchID(2) + GetTypeSuffix(HPARAM)
 
    IF NOT nElmts AND &H8000 THEN
 
        FOR i = nElmts - 1 TO 0 STEP -1
 
            IF i THEN
                Indices$ = ", " + STAG(ArgC) + Indices$
            ELSE
                Indices$ = STAG(ArgC) + Indices$
            END IF
 
            ArgC = ArgC + 1
 
        NEXT i
 
        Indices$ = "(" + Indices$ + ")"
 
    END IF
 
    ParseArrayExpr = ID$ + Indices$
 
END FUNCTION
 
'
' Generates parse rule fragment for a procedure call
'
FUNCTION ParseCALL$ (Parenthesis AS INTEGER)
 
    ArgC = FetchINT(0)
 
    FOR ArgI = 0 TO ArgC - 1
 
        IF ArgI THEN
            ArgV$ = STAG(ArgI) + ", " + ArgV$
        ELSE
            ArgV$ = STAG(ArgI) + ArgV$
        END IF
 
    NEXT ArgI
 
    IF ArgC > 0 THEN
        IF Parenthesis THEN ArgV$ = "(" + ArgV$ + ")" ELSE ArgV$ = " " + ArgV$
    END IF
 
    ParseCALL$ = ArgV$
 
END FUNCTION
 
'
' This helper function parses a SUB or FUNCTION declaration, or a
' SUB/FUNCTION/DEF FN definition.
'
FUNCTION ParseProcDecl$ (DP AS INTEGER, Parenthesis AS INTEGER)
 
    DIM Flags AS LONG
    DIM ArgC AS LONG
 
    CONST fCDECL = &H8000
    CONST fALIAS = &H400
 
    ID$ = GetID(FetchINT(DP + 0))
    Flags = FetchINTASLONG(DP + 2)
    ArgC = FetchINTASLONG(DP + 4)
 
    LenALIAS = Flags \ &H400 AND &H1F
 
    IF Flags AND &H80 THEN TS$ = GetTypeSuffix(Flags AND 7)
    Arguments$ = ""
 
    ProcType = (Flags AND &H300) \ 256
 
    SELECT CASE ProcType
        CASE 1: ID$ = "SUB " + ID$ + TS$: QBBinProcedureType = "SUB"
        CASE 2: ID$ = "FUNCTION " + ID$ + TS$: QBBinProcedureType = "FUNCTION"
        CASE 3: ID$ = "DEF " + ID$ + TS$: QBBinProcedureType = "DEF"
    END SELECT
 
 
    '
    ' Process arguments list
    '
    FOR ArgI = 1 TO ArgC
 
        ArgName$ = GetID(FetchINT(DP + ArgI * 6 + 0))
        ArgFlags = FetchINT(DP + ArgI * 6 + 2)
        ArgType = FetchINT(DP + ArgI * 6 + 4)
 
        '------------------------------------------------------------------------
        ' Process special argument flags. Not all of these can be combined,
        ' but we'll just assume the file contains a valid combination.
        '------------------------------------------------------------------------
        IF ArgFlags AND &H200 THEN ArgName$ = ArgName$ + GetTypeSuffix(ArgType)
        IF ArgFlags AND &H400 THEN ArgName$ = ArgName$ + "()"
        IF ArgFlags AND &H800 THEN ArgName$ = "SEG " + ArgName$
        IF ArgFlags AND &H1000 THEN ArgName$ = "BYVAL " + ArgName$
        IF ArgFlags AND &H2000 THEN ArgName$ = ArgName$ + " AS " + GetTypeName(ArgType)
 
        IF ArgI = 1 THEN
            Arguments$ = ArgName$
        ELSE
            Arguments$ = Arguments$ + ", " + ArgName$
        END IF
 
    NEXT ArgI
 
    IF Parenthesis OR Arguments$ <> "" THEN Arguments$ = " (" + Arguments$ + ")"
 
 
    '
    ' Process CDECL and ALIAS modifiers
    '
    IF Flags AND fCDECL THEN ID$ = ID$ + " CDECL"
 
    AliasName$ = LEFT$(FetchRAW(DP + ArgI * 6), LenALIAS)
    IF LenALIAS THEN ID$ = ID$ + " ALIAS " + AliasName$
 
    ParseProcDecl$ = ID$ + Arguments$
 
END FUNCTION
 
'
'
'
FUNCTION ParseVarArgs$
 
    ArgC = FetchINT(0)
 
    STATIC NULARG
 
    IF NULARG = 0 THEN NULARG = GetHashedSymbol("nularg")
 
    FOR ArgI = 0 TO ArgC - 1
 
        IF StackPeek(ArgI) <> NULARG THEN ArgV$ = ", " + ArgV$
 
        ArgV$ = STAG(ArgI) + ArgV$
 
    NEXT ArgI
 
 
    '----------------------------------------------------------------------------
    ' Trim trailing commas
    '----------------------------------------------------------------------------
    FOR i = LEN(ArgV$) TO 1 STEP -1
        Ch$ = MID$(ArgV$, i, 1)
        IF Ch$ <> " " AND Ch$ <> "," THEN EXIT FOR
    NEXT i
 
    ArgV$ = LEFT$(ArgV$, i)
 
    IF ArgV$ <> "" THEN ArgV$ = " " + ArgV$
 
    ParseVarArgs$ = ArgV$
 
END FUNCTION
 
FUNCTION POP$
 
    IF SP = LBOUND(STACK) THEN EXIT FUNCTION
 
    POP$ = MID$(STACK(SP), 3)
    SP = SP - 1
 
END FUNCTION
 
'
' The following special codes may be embedded in a string:
'
' 0xccnn0D      - RLE encoding (used by QB45 comments)
' 0xnnnn000D    - Indentation marker
' 0x101D        - NEWLINE marker 1
' 0x201D        - NEWLINE marker 2
'
SUB PostProcess
 
    DIM OutText AS STRING
    DIM OutTxt AS STRING
    DIM Marker AS LONG
    DIM LineColumn AS LONG
    DIM OffsetFromNewline AS LONG
    DIM TextBegin AS LONG
 
    TextBegin = 1
 
    DO
        '------------------------------------------------------------------------
        ' Look for special symbol marker
        '------------------------------------------------------------------------
        Marker = INSTR(TextBegin, STACK(0), CHR$(&HD))
        IF Marker = 0 THEN Marker = LEN(STACK(0)) + 1
 
        '------------------------------------------------------------------------
        ' Copy leading text to output string
        '------------------------------------------------------------------------
        OutTxt = OutTxt + MID$(STACK(0), TextBegin, Marker - TextBegin)
        IF Marker > LEN(STACK(0)) THEN
            TextBegin = Marker
            EXIT DO
        END IF
 
        OffsetFromNewline = OffsetFromNewline + Marker - TextBegin
 
        SELECT CASE MID$(STACK(0), Marker + 1, 1)
       
            CASE CHR$(0):
                '----------------------------------------------------------------
                ' Indentation
                '----------------------------------------------------------------
                RunLn& = CVI(MID$(STACK(0), Marker + 2)) AND &HFFFF&
                RunLn& = RunLn& - CLNG(OffsetFromNewline)
 
                IF (RunLn& < 0) THEN RunLn& = 1
 
                OffsetFromNewline = OffsetFromNewline + RunLn&
                OutTxt = OutTxt + SPACE$(RunLn&)
                TextBegin = Marker + 4
        
            CASE CHR$(1):
                '----------------------------------------------------------------
                ' Newline
                '----------------------------------------------------------------
                IF FlushToOutput THEN EXIT DO
                DiscardLine = 0
                FlushToOutput = -1
                OffsetFromNewline = 0
                TextBegin = Marker + 2
 
            CASE CHR$(2):
                '----------------------------------------------------------------
                ' Newline - $INCLUDEd file
                '----------------------------------------------------------------
                DiscardLine = QBBinOption.OmitIncludedLines
                          
                FlushToOutput = -1
                OffsetFromNewline = 0
                TextBegin = Marker + 2
 
            CASE ELSE:
                '----------------------------------------------------------------
                ' RLE encoded comment
                '----------------------------------------------------------------
                RunLn& = ASC(MID$(STACK(0), Marker + 1))
                RunCh$ = MID$(STACK(0), Marker + 2)
 
                OutTxt = OutTxt + STRING$(RunLn&, RunCh$)
 
                OffsetFromNewline = OffsetFromNewline + RunLn&
                TextBegin = Marker + 3
   
        END SELECT
 
    LOOP
 
    IF FlushToOutput THEN
        IF OutTxt <> SPACE$(LEN(OutTxt)) THEN OutTxt = RTRIM$(OutTxt)
        QBBinProgramLine = OutTxt
        QBBinLineReady = NOT DiscardLine
    
        OutTxt = ""
    END IF
 
    STACK(0) = OutTxt + MID$(STACK(0), Marker)
 
END SUB
 
SUB ProcessProcDefType
 
    ' Procedure DEFTYPE defaults to SINGLE
 
    DIM ProcDefType(1 TO 26) AS INTEGER
    DIM OutTxt AS STRING
 
    FOR i = 1 TO 26: ProcDefType(i) = 3: NEXT i
 
    DO WHILE LookAhead = 0
        IF NOT ReadToken THEN EXIT SUB
 
        IF LookAhead <> QBBinTok.DEFTYPE THEN
            IP = IP - 1
            EXIT DO
        END IF
   
        IF NOT ReadToken THEN EXIT DO
 
        UnwantedReturnValue$ = SubstTagDEFxxx(ProcDefType())
    
    LOOP
 
    'FOR i = 1 TO 26: PRINT GetTypeSuffix(ProcDefType(i)); : NEXT i: PRINT
 
    'PRINT QBBinProcedureName
 
    FOR i = 1 TO 5
   
        'IF i = 3 THEN i = i + 1
 
        AnythingOutput = 0
        InitialLetter = 0
        OutTxt = ""
 
        FOR j = 1 TO 27
 
 
            BITSET = 0
 
            IF j < 27 THEN
                BITSET = ProcDefType(j) = i
                BITSET = BITSET AND QBBinDefType(j) <> i
            END IF
 
            IF BITSET AND InitialLetter = 0 THEN
 
                InitialLetter = j + 64
 
            ELSEIF InitialLetter AND NOT BITSET THEN
 
                IF AnythingOutput THEN OutTxt = OutTxt + ", "
 
                OutTxt = OutTxt + CHR$(InitialLetter)
 
                Range = j + 64 - InitialLetter
                IF Range > 1 THEN OutTxt = OutTxt + "-" + CHR$(j + 63)
 
                AnythingOutput = -1
                InitialLetter = 0
            END IF
        NEXT j
 
        IF AnythingOutput THEN
            PUSH 0, MKI$(&H10D)
            PUSH QBBinTok.DEFTYPE, "DEF" + GetTypeAbbr(i) + " " + OutTxt
            FlushStack
        END IF
    
    NEXT i
 
    FOR i = 1 TO 26: QBBinDefType(i) = ProcDefType(i): NEXT i
 
END SUB
 
FUNCTION ProcessToken
 
    ProcessToken = 0
    IF NOT ReadToken THEN EXIT FUNCTION
 
    IF PCODE = 8 THEN EXIT FUNCTION
 
    ProcessToken = -1
    DefaultParseRule
 
END FUNCTION
 
SUB PUSH (ID AS INTEGER, Txt AS STRING)
 
    IF SP = UBOUND(STACK) THEN EXIT SUB
 
    SP = SP + 1
    STACK(SP) = MKI$(ID) + Txt
 
END SUB
 
SUB QBBinCloseFile
 
    CLOSE #QBBinFile
    QBBinFile = 0
    QBBinEOF = -1
 
END SUB
 
DEFSNG A-Z
FUNCTION QBBinGetFileType
 
END FUNCTION
 
DEFINT A-Z
'
FUNCTION QBBinGetProcName$
 
END FUNCTION
 
SUB QBBinOpenFile (FileName AS STRING)
 
    QBBinFile = FREEFILE
    QBBinEOF = 0
 
    OPEN FileName FOR BINARY AS #QBBinFile
 
    GET #QBBinFile, , Magic%
    GET #QBBinFile, , Version%
 
    '----------------------------------------------------------------------------
    ' Only QB45 is currently supported
    '----------------------------------------------------------------------------
    IF (Magic% <> &HFC) OR (Version% <> 1) THEN
        RESET
        PRINT "ERROR: The file you provided does not have a valid QB45 header."
        SYSTEM 1
    END IF
 
    ' Don't delete this - alpha sorter needs it!
    x = GetTotalLines
 
    '----------------------------------------------------------------------------
    ' Read symbol table size and convert to long to lose sign bit
    '----------------------------------------------------------------------------
    GET #QBBinFile, 27, szSymTbl%
    szSymTbl& = szSymTbl% AND &HFFFF&
 
    '----------------------------------------------------------------------------
    ' Load symbol table to memory and return file number
    '----------------------------------------------------------------------------
    REDIM SYMTBL(1 TO (szSymTbl& + 1) \ 2) AS INTEGER
    ReadToArrayINT QBBinFile, SYMTBL(), szSymTbl&
 
    IF NOT LoadMainModule THEN EXIT SUB
 
    '----------------------------------------------------------------------------
    ' If main module is empty, look for non-empty procedure
    '----------------------------------------------------------------------------
    WHILE CODE(IP) = 8
        IF NOT LoadNextProcedure THEN EXIT SUB
    WEND
 
END SUB
 
FUNCTION QBBinReadLine$ (Meta AS LONG)
 
 
    STATIC NewProc
 
    Meta = 0
 
    PostProcess
 
    IF QBBinLineReady THEN
        QBBinReadLine = QBBinProgramLine
        QBBinLineReady = 0
        QBBinProgramLine = ""
        EXIT FUNCTION
    END IF
 
    IF QBBinEOF THEN EXIT FUNCTION
 
    DO
        IF NoMoreTokens THEN
            QBBinCloseFile
            EXIT FUNCTION
        END IF
 
        IF NOT ReadToken THEN EXIT FUNCTION
        DefaultParseRule
 
        '------------------------------------------------------------------------
        ' Trap some special tokens
        '------------------------------------------------------------------------
        SELECT CASE PCODE
                                                                       
            '------------------------------------------------------------------------
            ' Token 0x008 appears at the end of the code (before the watch list)
            '------------------------------------------------------------------------
            CASE 8:
                IF NOT LoadNextProcedure THEN
                    NoMoreTokens = -1
                ELSE
                    PUSH 0, MKI$(&H10D) ' Force blank line before SUB/FUNCTION
                    ProcessProcDefType
                    NewProc = -1
 
            
                    'ProcessProcDefType
 
                END IF
 
                'END SELECT
 
                'SELECT CASE StackPeek(0)
       
            CASE QBBinTok.SUBDEF: Meta = QBBinMeta.SUB
            CASE QBBinTok.FUNCDEF: Meta = QBBinMeta.FUNCTION
 
        END SELECT
 
        PostProcess
 
    LOOP WHILE NOT QBBinLineReady
 
    QBBinReadLine = QBBinProgramLine
    QBBinLineReady = 0
    QBBinProgramLine = ""
 
END FUNCTION
 
SUB QBBinSetOption (OptionName AS STRING, OptionValue AS INTEGER)
END SUB
 
FUNCTION Quote$ (Txt AS STRING)
 
    Quote$ = CHR$(34) + Txt + CHR$(34)
 
END FUNCTION
 
FUNCTION ReadKey$
    DO: LOOP WHILE INKEY$ <> ""
    DO: Key$ = INKEY$: LOOP WHILE Key$ = ""
 
    ReadKey = UCASE$(Key$)
 
END FUNCTION
 
FUNCTION ReadParseRule (TokenID AS INTEGER, OpLen AS INTEGER, ParseRule AS STRING)
 
    '------------------------------------------------------------------------
    ' Ugh... static. I'm being lazy.
    '------------------------------------------------------------------------
    STATIC RuleItem AS STRING
    STATIC DefaultRuleID AS STRING
 
    '------------------------------------------------------------------------
    ' If RuleItem isn't empty, extract the next rule.
    '------------------------------------------------------------------------
    IF RuleItem <> "" THEN
        ParseRule = DelimitParseRule(RuleItem, DefaultRuleID)
        ReadParseRule = -1
        EXIT FUNCTION
    END IF
 
    ReadParseRule = 0
 
    READ RuleItem
 
    '------------------------------------------------------------------------
    ' Loop until we have something which isn't the .default directive
    '------------------------------------------------------------------------
    WHILE MID$(RuleItem, 1, 8) = ".default"
 
        DefaultRuleID = LTRIM$(RTRIM$(MID$(RuleItem, 9)))
        READ RuleItem
 
    WEND
 
    '------------------------------------------------------------------------
    ' The rule list is terminated by a period.
    '------------------------------------------------------------------------
    IF RuleItem = "." THEN
        RuleItem = ""
        DefaultRuleID = ""
        EXIT FUNCTION
    END IF
 
    '------------------------------------------------------------------------
    ' If RuleItem is a number, then assume it is the start of a new token.
    ' Otherwise, we assume it is an additional rule of the previous token.
    '------------------------------------------------------------------------
    IF (StringToINT(RuleItem, TokenID)) THEN
 
        READ RuleItem
 
        '--------------------------------------------------------------------
        ' If the token length is not omitted, then we need to read again
        ' to fetch the token parse rule. Also, an asterisk may be used to
        ' represent a variable length token, so we need to check for that.
        '--------------------------------------------------------------------
        IF StringToINT(RuleItem, OpLen) THEN
            READ RuleItem
 
        ELSEIF RuleItem$ = "*" THEN
            OpLen = -1
            READ RuleItem
 
        ELSE
            OpLen = 0
        END IF
 
    END IF
 
 
    '------------------------------------------------------------------------
    ' Extract rule and return
    '------------------------------------------------------------------------
    ParseRule = DelimitParseRule(RuleItem, DefaultRuleID)
    ReadParseRule = -1
 
END FUNCTION
 
SUB ReadToArrayINT (FileNumber AS INTEGER, Array() AS INTEGER, ByteCount AS LONG)
 
    CONST BlockReadSize = 1024 ' must be a multiple of 2
 
    IF BlockReadSize AND 1 THEN PRINT "BlockReadSize error.": SYSTEM 1 'ERROR 255
 
    DIM i AS LONG
    DIM BytesToRead AS LONG
 
    '----------------------------------------------------------------------------
    ' REDIM the array if necessary, but keep the lower bound in place
    '----------------------------------------------------------------------------
    IF (UBOUND(Array) - LBOUND(Array)) * 2 < ByteCount THEN
        REDIM Array(LBOUND(Array) TO LBOUND(Array) + (ByteCount + 1) \ 2) AS INTEGER
    END IF
 
    FOR i = 0 TO ByteCount - 1 STEP BlockReadSize
 
        BytesToRead = ByteCount - i
 
        IF BytesToRead > BlockReadSize THEN BytesToRead = BlockReadSize
 
        Buffer$ = STRING$(BytesToRead, 0)
        GET FileNumber, , Buffer$
 
        '------------------------------------------------------------------------
        ' Copy data from string to integer array (even number of bytes only)
        '------------------------------------------------------------------------
        FOR j = 1 TO BytesToRead - 1 STEP 2
            Index = LBOUND(Array) + i \ 2 + j \ 2
            Array(Index) = CVI(MID$(Buffer$, j, 2))
        NEXT j
 
        '------------------------------------------------------------------------
        ' The final block may have had an odd number of bytes
        '------------------------------------------------------------------------
        IF BytesToRead AND 1 THEN
            Index = LBOUND(Array) + i \ 2 + j \ 2
            Array(Index) = ASC(RIGHT$(Buffer$, 1))
        END IF
 
    NEXT i
 
 
END SUB
 
'
' Reads a token into the globals PCODE and HPARAM. IP is updated to point
' To the next token, and DP points to the start of the token data.
'
FUNCTION ReadToken
 
    DIM TokLen AS LONG
 
    ReadToken = 0
 
    IF IP < LBOUND(CODE) OR IP > UBOUND(CODE) THEN EXIT FUNCTION
 
    '----------------------------------------------------------------------------
    ' Fetch basic token information
    '----------------------------------------------------------------------------
    TOKEN = MKI$(CODE(IP))
    PCODE = CODE(IP) AND &H3FF
    HPARAM = (CODE(IP) AND &HFC00&) \ 1024
    ReadToken = -1
 
 
    '----------------------------------------------------------------------------
    ' If the token is outside the known token range, we have a problem.
    '----------------------------------------------------------------------------
    IF PCODE < LBOUND(ParseRules) OR PCODE > UBOUND(ParseRules) THEN
        IP = IP + 1
        PRINT "Bad token found.": SYSTEM 1 'ERROR QBErrBadToken
        PCODE = 0: HPARAM = 0: TOKEN = MKI$(0)
        EXIT FUNCTION
    END IF
 
    '----------------------------------------------------------------------------
    ' If the token has no information in the parse rules, then we clearly don't
    ' understand what it does, so increment IP and return. We will try to
    ' soldier on and parse the rest of the file
    '----------------------------------------------------------------------------
    IF ParseRules(PCODE) = "" THEN
        AOutput "REM ®QB45BIN¯ Unkown token - " + HEX$(PCODE)
        IP = IP + 1
        EXIT FUNCTION
    END IF
 
    '----------------------------------------------------------------------------
    ' Fetch the token data length from the parse rules to determine if the token
    ' is fixed or variable length
    '----------------------------------------------------------------------------
    IF PCODE >= LBOUND(ParseRules) AND PCODE <= UBOUND(ParseRules) THEN
        IF LEN(ParseRules(PCODE)) > 2 THEN
            TokLen = CVI(LEFT$(ParseRules(PCODE), 2)) AND &HFFFF&
        END IF
    END IF
 
    '----------------------------------------------------------------------------
    ' If the token is variable length it will be followed by the size word, so
    ' read it now.
    '----------------------------------------------------------------------------
    IF TokLen = &HFFFF& THEN
        IP = IP + 1
        TokLen = CODE(IP) AND &HFFFF&
    END IF
 
    '----------------------------------------------------------------------------
    ' Read the token data into the TOKEN string. Note that due to a bug in QB64,
    ' we can not use IP as the control variable.
    '----------------------------------------------------------------------------
    FOR DP = IP + 1 TO IP + (TokLen + 1) \ 2
        TOKEN = TOKEN + MKI$(CODE(DP))
    NEXT DP
    IP = DP
 
    TOKEN = LEFT$(TOKEN, TokLen + 2)
 
END FUNCTION
 
SUB RestoreParseRules
 
    '
    ' This is so I can change parse rules later if I add QB40 support.
    '
    RESTORE QB45TOKENS
 
END SUB
 
SUB SanityCheck (DP AS INTEGER)
 
    DIM ThAddr AS LONG
 
    ThAddr = FetchINTASLONG(DP)
 
    IF ThAddr = &HFFFF& THEN EXIT SUB
 
    ThAddr = ThAddr \ 2 - 1
 
    IF ThAddr >= LBOUND(CODE) AND ThAddr <= UBOUND(CODE) - 1 THEN
 
        IF (CODE(LBOUND(CODE) + ThAddr) AND &H1FF) = PCODE THEN EXIT SUB
 
    END IF
 
    'ERROR QBBinErrInsane
END SUB
 
FUNCTION SetHashedSymbol% (ParseRuleSymbol AS STRING, SymbolID AS INTEGER)
    DIM LookupSymbol AS STRING
 
    SymbolName$ = LTRIM$(RTRIM$(ParseRuleSymbol))
 
    '----------------------------------------------------------------------------
    ' Parse rule symbols my be literal integers
    '----------------------------------------------------------------------------
    IF StringToINT(SymbolName$, SymbolID%) THEN EXIT FUNCTION
 
    Hash = HashPJW(SymbolName$)
 
    LookupSymbol = "[" + SymbolName$ + "]"
 
    SymbolOffset = INSTR(SymbolHashTable(Hash), LookupSymbol)
 
    IF SymbolOffset = 0 THEN
 
        SymbolHashTable(Hash) = SymbolHashTable(Hash) + LookupSymbol + MKI$(SymbolID)
 
        SetHashedSymbol = SymbolID
 
    ELSE
 
        SymbolOffset = SymbolOffset + LEN(LookupSymbol)
 
        ID$ = MID$(SymbolHashTable(Hash), SymbolOffset, 2)
        SetHashedSymbol = CVI(ID$)
 
    END IF
 
    'GetHashedSymbol% = SymbolID% + UBOUND(ParseRules) + 1
 
 
 
END FUNCTION
 
'
' Peeks at the ID of a stack item
'
FUNCTION StackPeek (OffsetSP)
 
    StackPeek = -1
 
    IF OffsetSP < 0 OR OffsetSP >= SP THEN EXIT FUNCTION
 
    StackPeek = CVI(LEFT$(STACK(SP - OffsetSP), 2))
 
END FUNCTION
 
'
' STAG is a shortcut function for creating numeric stack tags dynamically
' such as {1}.
'
FUNCTION STAG$ (n)
 
    STAG$ = "{" + LTRIM$(RTRIM$(STR$(n))) + "}"
 
END FUNCTION
 
'
' Parses a STRING into an INTEGER, returning 0 if the string contained
' any invalid characters (not including leading and trailing whitespace).
' Only positive integers are recognised (no negative numbers!).
'
' The actual numeric value is returned in OutVal
'
FUNCTION StringToINT (Txt AS STRING, OutVal AS INTEGER)
 
    x$ = UCASE$(LTRIM$(RTRIM$(Txt)))
 
    SignCharacter$ = LEFT$(x$, 1)
    SignMultiplier = 1
 
    IF (SignCharacter$ = "+" OR SignCharacter$ = "-") THEN
        SignMultiplier = 45 - ASC(SignCharacter$)
        x$ = MID$(x$, 2)
    END IF
 
    FoundBadDigit = LEN(x$) = 0
 
    SELECT CASE LEFT$(x$, 2)
        CASE "&H", "0X": nBase = 16: FirstDigitPos = 3
        CASE "&O": nBase = 8: FirstDigitPos = 3
        CASE ELSE: nBase = 10: FirstDigitPos = 1
    END SELECT
 
    IF nBase THEN
 
        FOR i = FirstDigitPos TO LEN(x$)
            Digit = ASC(MID$(x$, i, 1)) - 48
            IF Digit > 16 THEN Digit = Digit - 7
            IF Digit < 0 OR Digit >= nBase THEN FoundBadDigit = -1
 
            IF NOT FoundBadDigit THEN
                Value = Value * nBase
                Value = Value + Digit
            END IF
 
        NEXT i
    END IF
 
    StringToINT = NOT FoundBadDigit
    IF NOT FoundBadDigit THEN OutVal = Value * SignMultiplier
 
END FUNCTION
 
FUNCTION SubstTagCIRCLE$
 
    DIM ParseRule AS STRING
 
    ParseRule = "{?}, {?}, {?}, {?}, {?}, {?}"
 
    ArgC = 0
    ArgI = 0
 
    '
    ' The last 3 arguments are optional.
    '
    FOR i = 0 TO 2
 
        IF StackPeek(ArgC) = &H7E + i THEN
 
            IF ArgI = 0 THEN ArgI = 28 - i * 5
 
            MID$(ParseRule, 27 - i * 5, 1) = CHR$(ArgC + 48)
            ArgC = ArgC + 1
 
        END IF
 
    NEXT i
 
    ' PCODE 0x09f means no colour argument
    IF PCODE <> &H9F THEN
        IF ArgI = 0 THEN ArgI = 13
        MID$(ParseRule, 12, 1) = CHR$(ArgC + 48)
        ArgC = ArgC + 1
    END IF
 
    ' The last 3 arguments are required
    IF ArgI = 0 THEN ArgI = 8
    MID$(ParseRule, 7, 1) = CHR$(ArgC + 48): ArgC = ArgC + 1
    MID$(ParseRule, 2, 1) = CHR$(ArgC + 48): ArgC = ArgC + 1
 
    ' Remove unused arguments
 
    ParseRule = LEFT$(ParseRule, ArgI)
 
    DO
        ArgI = INSTR(ParseRule, "?")
        IF ArgI <= 1 THEN EXIT DO
        ParseRule = LEFT$(ParseRule, ArgI - 2) + MID$(ParseRule, ArgI + 2)
    LOOP
 
    SubstTagCIRCLE = ParseRule
 
END FUNCTION
 
'
' 0x01B : DEF(INT|LNG|SNG|DBL|STR) letterrange
'
' The DEFxxx token is followed by 6 bytes of data. The first two bytes give
' the absolute offset in the p-code to the correspdoning bytes of the next
' DEFxxx statement (!), or 0xFFFF if there are no more DEFxxx statements.
'
' Naturally, we can ignore these two bytes.
'
' The next 4 bytes form a 32-bit integer. The low 3 bits give the data-type
' for the DEFxxx. The upper 26 bits represent each letter or the alphabet,
' with A occupying the highest bit, and Z the lowest.
'
FUNCTION SubstTagDEFxxx$ (DefTypeArray() AS INTEGER)
 
    DIM AlphaMask AS LONG
    DIM OutTxt AS STRING
 
    AlphaMask = FetchLNG(2)
    DefType = LIMIT(AlphaMask AND 7, 0, 5)
    OutTxt = "DEF" + GetTypeAbbr(DefType) + " "
 
    ' Shift the mask right once to avoid overflow problems.
    AlphaMask = AlphaMask \ 2
    InitialLetter = 0
    AnythingOutput = 0
 
    ' We will loop one extra time to avoid code redendancy after the loop to
    ' clean up the Z. To ensure everything works out, we just need to make
    ' sure the bit after the Z is clear. We also need to clear the high 2 bits
    ' every time to avoid overflow ploblems.
 
    FOR i = 0 TO 26
 
        ' Get the next bit and shift the mask
        BITSET = (AlphaMask AND &H40000000) <> 0
        AlphaMask = AlphaMask AND &H3FFFFFE0
        AlphaMask = AlphaMask * 2
 
        '------------------------------------------------------------------------
        ' Update current DEFtype state
        '------------------------------------------------------------------------
        IF i < 26 AND BITSET THEN DefTypeArray(i + 1) = DefType
 
        IF BITSET AND InitialLetter = 0 THEN
 
            InitialLetter = i + 65
 
        ELSEIF InitialLetter AND NOT BITSET THEN
 
            IF AnythingOutput THEN OutTxt = OutTxt + ", "
 
            OutTxt = OutTxt + CHR$(InitialLetter)
 
            Range = i + 65 - InitialLetter
            IF Range > 1 THEN OutTxt = OutTxt + "-" + CHR$(i + 64)
 
            AnythingOutput = -1
            InitialLetter = 0
        END IF
 
    NEXT i
 
    SubstTagDEFxxx$ = OutTxt
 
END FUNCTION
 
FUNCTION SubstTagINPUT$
 
    CONST fPrompt = &H4
    CONST fSemiColon = &H2
    CONST fComma = &H1
 
    Flags = ASC(MID$(TOKEN, 3, 1))
 
    IF Flags AND fSemiColon THEN OutTxt$ = "; "
 
    IF Flags AND fPrompt THEN
        Tail = 59 - (((Flags AND fComma) = 1) AND 15)
        OutTxt$ = OutTxt$ + "{$+0}" + CHR$(Tail)
    END IF
 
    SubstTagINPUT = OutTxt$
 
END FUNCTION
 
FUNCTION SubstTagKEY$
 
    SELECT CASE CVI(MID$(TOKEN, 3, 2))
        CASE 1: SubstTagKEY$ = "ON"
        CASE 2: SubstTagKEY$ = "LIST"
        CASE ELSE: SubstTagKEY$ = "OFF"
    END SELECT
 
END FUNCTION
 
FUNCTION SubstTagLINE$
 
    LineForm = PCODE - &HBB
 
    SELECT CASE FetchINT(0) AND 3
 
        CASE 1: BF$ = "B"
        CASE 2: BF$ = "BF"
        CASE ELSE: BF$ = ""
 
    END SELECT
 
    ' 0x0bb : LINE x-x, ,[b[f]]
    ' 0x0bc : LINE x-x,n,[b[f]]
    ' 0x0bd : LINE x-x,n,[b[f]],n
    ' 0x0be : LINE x-x, ,[b[f]],n
 
 
    IF BF$ <> "" THEN
 
        SELECT CASE LineForm
 
            CASE 0: Rule$ = "{0}, , " + BF$
            CASE 1: Rule$ = "{1}, {0}, " + BF$
            CASE 2: Rule$ = "{2}, {1}, " + BF$ + ", {0}"
            CASE 3: Rule$ = "{1}, , " + BF$ + ", {0}"
 
        END SELECT
 
    ELSE
 
        SELECT CASE LineForm
 
            CASE 0: Rule$ = "{0}"
            CASE 1: Rule$ = "{1}, {0}"
            CASE 2: Rule$ = "{2}, {1}, , {0}"
            CASE 3: Rule$ = "{1}, , , {0}"
 
        END SELECT
 
    END IF
 
    SubstTagLINE = Rule$
 
END FUNCTION
 
FUNCTION SubstTagLOCK$
 
    DIM Flags AS LONG
 
    Flags = FetchINTASLONG(0) AND &HFFFF&
 
    IF (Flags AND 2) = 0 THEN
        SubstTagLOCK$ = "{0}"
    ELSE
    
        ' check high 2 bits
        SELECT CASE Flags \ &H4000
            CASE 0: SubstTagLOCK$ = "{2}, {1} TO {0}"
            CASE 1: SubstTagLOCK$ = "{2}, TO {0}"
            CASE 2: SubstTagLOCK$ = "{1}, {0}"
        END SELECT
 
    END IF
 
END FUNCTION
 
FUNCTION SubstTagOPEN$
 
    DIM ModeFlags AS LONG
    DIM ForMode AS STRING
    DIM AccessMode AS STRING
    DIM LockMode AS STRING
    DIM OutTxt AS STRING
 
    ModeFlags = FetchINT(0) AND &HFFFF&
 
    SELECT CASE ModeFlags AND &H3F
        CASE &H1: ForMode = "FOR INPUT"
        CASE &H2: ForMode = "FOR OUTPUT"
        CASE &H4: ForMode = "FOR RANDOM"
        CASE &H8: ForMode = "FOR APPEND"
        CASE &H20: ForMode = "FOR BINARY"
    END SELECT
 
    SELECT CASE ModeFlags \ 256 AND 3
        CASE 1: AccessMode = "ACCESS READ"
        CASE 2: AccessMode = "ACCESS WRITE"
        CASE 3: AccessMode = "ACCESS READ WRITE"
    END SELECT
 
    SELECT CASE ModeFlags \ &H1000 AND &H7
        CASE 1: LockMode = "LOCK READ WRITE"
        CASE 2: LockMode = "LOCK WRITE"
        CASE 3: LockMode = "LOCK READ"
        CASE 4: LockMode = "SHARED"
    END SELECT
 
    OutTxt = ForMode
    IF (OutTxt <> "" AND AccessMode <> "") THEN OutTxt = OutTxt + " "
    OutTxt = OutTxt + AccessMode
    IF (OutTxt <> "" AND LockMode <> "") THEN OutTxt = OutTxt + " "
    OutTxt = OutTxt + LockMode
 
    SubstTagOPEN = OutTxt
 
END FUNCTION
 
FUNCTION SubstTagVERB$
 
    Verbs$ = "0OR|1AND|2PRESET|3PSET|4XOR|"
 
    VerbBegin = INSTR(Verbs$, CHR$(48 + LIMIT(FetchINT(0), 0, 4))) + 1
    VerbEnd = INSTR(VerbBegin, Verbs$, "|")
 
    SubstTagVERB$ = MID$(Verbs$, VerbBegin, VerbEnd - VerbBegin)
 
END FUNCTION
 
'
' Splits a {ruletag} into it's constituent components.
'
FUNCTION TokenizeTag (TagTxt AS STRING, TagParam AS INTEGER)
 
    DIM ParamTxt AS STRING
 
    Delimiter = INSTR(TagTxt, ":")
 
    ParamTxt = LTRIM$(MID$(TagTxt, Delimiter + 1))
 
    IF LEFT$(ParamTxt, 1) = "$" THEN
 
        TokenizeTag = TagType.StackREL
 
        IF NOT StringToINT(MID$(ParamTxt, 2), TagParam) THEN
            Delimiter = LEN(TagTxt) + 1
            TagParam = 0
        END IF
 
    ELSE
 
        TokenizeTag = TagType.StackABS
 
        IF NOT StringToINT(MID$(ParamTxt, 1), TagParam) THEN
            Delimiter = LEN(TagTxt) + 1
            TagParam = 0
        END IF
 
    END IF
 
    IF Delimiter THEN Delimiter = Delimiter - 1
 
    TagTxt = LTRIM$(RTRIM$(LEFT$(TagTxt, Delimiter)))
 
    IF LEFT$(TagTxt, 2) = "##" THEN
 
        TokenizeTag = TagType.Recursive
        TagTxt = MID$(TagTxt, 3)
 
    ELSEIF LEFT$(TagTxt, 1) = "#" THEN
 
        TokenizeTag = TagType.TokenData
        TagTxt = MID$(TagTxt, 2)
 
    END IF
 
 
END FUNCTION
 
FUNCTION ValidateStackTag (RuleID AS INTEGER, TagTxt AS STRING, OffsetSP AS INTEGER)
 
 
    DIM RuleSymbol AS STRING
 
    '------------------------------------------------------------------------
    ' If the specified stack offset is invalid, only the null tag will do.
    '------------------------------------------------------------------------
    IF (OffsetSP < 0 OR OffsetSP >= SP) THEN
        ValidateStackTag = (TagTxt = "")
        EXIT FUNCTION
    END IF
 
    TagLen = LEN(TagTxt)
    TagOffset = 1
 
    DO WHILE TagOffset <= TagLen
     
        Delimiter = INSTR(TagOffset, TagTxt, "|")
        IF Delimiter = 0 THEN Delimiter = TagLen + 1
 
        RuleSymbol = MID$(TagTxt, TagOffset, Delimiter - TagOffset)
        RuleSymbol = LTRIM$(RTRIM$(RuleSymbol))
 
        IF NOT StringToINT(RuleSymbol, RuleSymbolID) THEN
            RuleSymbolID = GetHashedSymbol(RuleSymbol)
        END IF
 
        IF RuleSymbol = "*" THEN EXIT DO
        IF RuleSymbol = "self" THEN RuleSymbolID = RuleID
 
        IF StackPeek(OffsetSP) = RuleSymbolID THEN EXIT DO
 
        TagOffset = Delimiter + 1
 
    LOOP
 
    ValidateStackTag = NOT (TagLen AND TagOffset > TagLen)
 
    IF TagLen AND TagOffset > TagLen THEN
        ValidateStackTag = 0
    ELSE
        ValidateStackTag = -1
    END IF
 
 
END FUNCTION

Pete · « **Reply #1 on:** April 27, 2019, 08:12:35 pm »

Was this a request? Anyway, I hope it didn't take too much time or effort. I figure if I'm interested in the code, I'm going to run it, not just look at it. So it either winds up in NotePad in black on white, or the IDE, which I don't color code, so white on blue. Hopefully you'll find other fans for this forum color code addition. Although I personally don't think it was needed, I love ambition. As long as it made whoever wrote it happy. That's a win, period; although it would be twice as cool if it had a code-qb64 code button next to the standard code button.

Pete

FellippeHeitor · « **Reply #2 on:** April 27, 2019, 08:15:24 pm »

It was a request by me :-)

Anyway, it was just a matter of linking to the proper syntax highlighting library (GeSHI in this case) and adding in the keywords. Took 20 minutes.

RhoSigma · « **Reply #3 on:** April 27, 2019, 08:36:58 pm »

Nice new feature, and i see there is an extra "colorful" code button for it in the editor page, but why are IF, THEN, ELSE, TO, FUNCTION and others in different color and not linked to its respective wiki pages?

odin · « **Reply #4 on:** April 27, 2019, 08:43:27 pm »

Quote from: Pete on April 27, 2019, 08:12:35 pm

it would be twice as cool if it had a code-qb64 code button next to the standard code button.

[ You are not allowed to view this attachment ]

Quote from: RhoSigma on April 27, 2019, 08:36:58 pm

Nice new feature, and i see there is an extra "colorful" code button for it in the editor page, but why are IF, THEN, ELSE, TO, FUNCTION and others in different color and not linked to its respective wiki pages?

Check again :-)

RhoSigma · « **Reply #5 on:** April 27, 2019, 08:51:26 pm »

Grr, look at lines 1091 or 1127 of your sample code. Can wordwrap be deactivated? It will trash the code layout.

Raven_Singularity · « **Reply #6 on:** April 27, 2019, 08:52:38 pm »

Thanks for your work. Looks nice, I love syntax highlighting. Saves a lot of brain power when skimming code! Nice to see you've already fixed a minor implementation bug and implemented a new feature request. :-P

Pete · « **Reply #7 on:** April 27, 2019, 09:10:47 pm »

Code: QB64: [Select]

REM OK, you added the button.
' Not bad for 20-minutes work, and whatever the button addition took.
PRINT "Nice Job!"
END

FellippeHeitor · « **Reply #8 on:** April 27, 2019, 09:39:58 pm »

Quote from: RhoSigma on April 27, 2019, 08:51:26 pm

Grr, look at lines 1091 or 1127 of your sample code. Can wordwrap be deactivated? It will trash the code layout.

Haven't found a way to disable line wrapping for now.

Edit: I think I just found the way. Please check.

FellippeHeitor · « **Reply #9 on:** April 27, 2019, 09:49:51 pm »

Line-wrapping seems to have been properly disabled:

Code: QB64: [Select]

noGo$ = "@DO@LOOP@WHILE@WEND@THEN@ELSE@ELSEIF@IF@FOR@TO@NEXT@STEP@GOTO@GOSUB@CALL@CALLS@SUB@FUNCTION@RETURN@RESUME@SELECT@CASE@UNTIL@"
 
kw$ = "@?@$CHECKING@$CONSOLE@ONLY@$DYNAMIC@$ELSE@$ELSEIF@$END@$ENDIF@$EXEICON@$IF@$INCLUDE@$LET@$RESIZE@$SCREENHIDE@$SCREENSHOW@$STATIC@$VERSIONINFO@$VIRTUALKEYBOARD@ABS@ABSOLUTE@ACCESS@ALIAS@AND@APPEND@AS@ASC@ATN@BASE@BEEP@BINARY@BLOAD@BSAVE@BYVAL@CALL@CALLS@CASE@IS@CDBL@CDECL@CHAIN@CHDIR@CHR$@CINT@CIRCLE@CLEAR@CLNG@CLOSE@CLS@COLOR@COM@COMMAND$@COMMON@CONST@COS@CSNG@CSRLIN@CUSTOMTYPE@CVD@CVDMBF@CVI@CVL@CVS@CVSMBF@DATA@DATE$@DECLARE@DEF@DEFDBL@DEFINT@DEFLNG@DEFSNG@DEFSTR@DIM@DO@DOUBLE@DRAW@DYNAMIC@ELSE@ELSEIF@END@ENDIF@ENVIRON@ENVIRON$@EOF@EQV@ERASE@ERDEV@ERDEV$@ERL@ERR@ERROR@EVERYCASE@EXIT@EXP@FIELD@FILEATTR@FILES@FIX@FN@FOR@FRE@FREE@FREEFILE@FUNCTION@GET@GOSUB@GOTO@HEX$@IF@IMP@INKEY$@INP@INPUT@INPUT$@INSTR@INT@INTEGER@INTERRUPT@INTERRUPTX@IOCTL@IOCTL$@KEY@KILL@LBOUND@LCASE$@LEFT$@LEN@LET@LIBRARY@LINE@LIST@LOC@LOCATE@LOCK@LOF@LOG@LONG@LOOP@LPOS@LPRINT@LSET@LTRIM$@MID$@MKD$@MKDIR@MKDMBF$@MKI$@MKL$@MKS$@MKSMBF$@MOD@NAME@NEXT@NOT@OCT$@OFF@ON@OPEN@OPTION@OR@OUT@OUTPUT@PAINT@PALETTE@PCOPY@PEEK@PEN@PLAY@PMAP@POINT@POKE@POS@PRESET@PRINT@PSET@PUT@RANDOM@RANDOMIZE@READ@REDIM@REM@RESET@RESTORE@RESUME@RETURN@RIGHT$@RMDIR@RND@RSET@RTRIM$@RUN@SADD@SCREEN@SEEK@SEG@SELECT@SETMEM@SGN@SHARED@SHELL@SIGNAL@SIN@SINGLE@SLEEP@SOUND@SPACE$@SPC@SQR@STATIC@STEP@STICK@STOP@STR$@STRIG@STRING@STRING$@SUB@SWAP@SYSTEM@TAB@TAN@THEN@TIME$@TIMER@TO@TROFF@TRON@TYPE@UBOUND@UCASE$@UEVENT@UNLOCK@UNTIL@USING@VAL@VARPTR@VARPTR$@VARSEG@VIEW@WAIT@WEND@WHILE@WIDTH@WINDOW@WRITE@XOR@_ACOS@_ACOSH@_ALPHA@_ALPHA32@_ARCCOT@_ARCCSC@_ARCSEC@_ASIN@_ASINH@_ATAN2@_ATANH@_AUTODISPLAY@_AXIS@_BACKGROUNDCOLOR@_BIT@_BLEND@_BLINK@_BLUE@_BLUE32@_BUTTON@_BUTTONCHANGE@_BYTE@_CEIL@_CLEARCOLOR@_CLIP@_CLIPBOARD$@_CLIPBOARDIMAGE@_COMMANDCOUNT@_CONNECTED@_CONNECTIONADDRESS$@_CONNECTIONADDRESS@_CONSOLE@_CONSOLETITLE@_CONTINUE@_CONTROLCHR@_COPYIMAGE@_COPYPALETTE@_COSH@_COT@_COTH@_CSC@_CSCH@_CV@_CWD$@_D2G@_D2R@_DEFAULTCOLOR@_DEFINE@_DELAY@_DEPTHBUFFER@_DESKTOPHEIGHT@_DESKTOPWIDTH@_DEST@_DEVICE$@_DEVICEINPUT@_DEVICES@_DIR$@_DIREXISTS@_DISPLAY@_DISPLAYORDER@_DONTBLEND@_DONTWAIT@"
kw$ = kw$ + "_ERRORLINE@_EXIT@_EXPLICIT@_FILEEXISTS@_FLOAT@_FONT@_FONTHEIGHT@_FONTWIDTH@_FREEFONT@_FREEIMAGE@_FREETIMER@_FULLSCREEN@_G2D@_G2R@_GLRENDER@_GREEN@_GREEN32@_HEIGHT@_HIDE@_HYPOT@_ICON@_INCLERRORFILE$@_INCLERRORLINE@_INTEGER64@_KEYCLEAR@_KEYDOWN@_KEYHIT@_LASTAXIS@_LASTBUTTON@_LASTWHEEL@_LIMIT@_LOADFONT@_LOADIMAGE@_MAPTRIANGLE@_MAPUNICODE@_MEM@_MEMCOPY@_MEMELEMENT@_MEMEXISTS@_MEMFILL@_MEMFREE@_MEMGET@_MEMIMAGE@_MEMNEW@_MEMPUT@_MIDDLE@_MK$@_MOUSEBUTTON@_MOUSEHIDE@_MOUSEINPUT@_MOUSEMOVE@_MOUSEMOVEMENTX@_MOUSEMOVEMENTY@_MOUSEPIPEOPEN@_MOUSESHOW@_MOUSEWHEEL@_MOUSEX@_MOUSEY@_NEWIMAGE@_OFFSET@_OPENCLIENT@_OPENCONNECTION@_OPENHOST@_OS$@_PALETTECOLOR@_PI@_PIXELSIZE@_PRESERVE@_PRINTIMAGE@_PRINTMODE@_PRINTSTRING@_PRINTWIDTH@_PUTIMAGE@_R2D@_R2G@_RED@_RED32@_RESIZE@_RESIZEHEIGHT@_RESIZEWIDTH@_RGB@_RGB32@_RGBA@_RGBA32@_ROUND@_SCREENCLICK@_SCREENEXISTS@_SCREENHIDE@_SCREENICON@_SCREENIMAGE@_SCREENMOVE@_SCREENPRINT@_SCREENSHOW@_SCREENX@_SCREENY@_SEC@_SECH@_SETALPHA@_SHELLHIDE@_SINH@_SNDBAL@_SNDCLOSE@_SNDCOPY@_SNDGETPOS@_SNDLEN@_SNDLIMIT@_SNDLOOP@_SNDOPEN@_SNDOPENRAW@_SNDPAUSE@_SNDPAUSED@_SNDPLAY@_SNDPLAYCOPY@_SNDPLAYFILE@_SNDPLAYING@_SNDRATE@_SNDRAW@_SNDRAWDONE@_SNDRAWLEN@_SNDSETPOS@_SNDSTOP@_SNDVOL@_SOURCE@_STARTDIR$@_STRCMP@_STRICMP@_TANH@_TITLE@_TITLE$@_UNSIGNED@_WHEEL@_WIDTH@_WINDOWHANDLE@_WINDOWHASFOCUS@_GLACCUM@_GLALPHAFUNC@_GLARETEXTURESRESIDENT@_GLARRAYELEMENT@_GLBEGIN@_GLBINDTEXTURE@_GLBITMAP@_GLBLENDFUNC@_GLCALLLIST@_GLCALLLISTS@_GLCLEAR@_GLCLEARACCUM@_GLCLEARCOLOR@_GLCLEARDEPTH@_GLCLEARINDEX@_GLCLEARSTENCIL@_GLCLIPPLANE@_GLCOLOR3B@_GLCOLOR3BV@_GLCOLOR3D@_GLCOLOR3DV@_GLCOLOR3F@_GLCOLOR3FV@_GLCOLOR3I@_GLCOLOR3IV@_GLCOLOR3S@_GLCOLOR3SV@_GLCOLOR3UB@_GLCOLOR3UBV@_GLCOLOR3UI@_GLCOLOR3UIV@_GLCOLOR3US@_GLCOLOR3USV@_GLCOLOR4B@_GLCOLOR4BV@_GLCOLOR4D@_GLCOLOR4DV@_GLCOLOR4F@_GLCOLOR4FV@_GLCOLOR4I@_GLCOLOR4IV@_GLCOLOR4S@_GLCOLOR4SV@_GLCOLOR4UB@_GLCOLOR4UBV@_GLCOLOR4UI@_GLCOLOR4UIV@_GLCOLOR4US@_GLCOLOR4USV@_GLCOLORMASK@_GLCOLORMATERIAL@_GLCOLORPOINTER@_GLCOPYPIXELS@_GLCOPYTEXIMAGE1D@_GLCOPYTEXIMAGE2D@_GLCOPYTEXSUBIMAGE1D@"
kw$ = kw$ + "_GLCOPYTEXSUBIMAGE2D@_GLCULLFACE@_GLDELETELISTS@_GLDELETETEXTURES@_GLDEPTHFUNC@_GLDEPTHMASK@_GLDEPTHRANGE@_GLDISABLE@_GLDISABLECLIENTSTATE@_GLDRAWARRAYS@_GLDRAWBUFFER@_GLDRAWELEMENTS@_GLDRAWPIXELS@_GLEDGEFLAG@_GLEDGEFLAGPOINTER@_GLEDGEFLAGV@_GLENABLE@_GLENABLECLIENTSTATE@_GLEND@_GLENDLIST@_GLEVALCOORD1D@_GLEVALCOORD1DV@_GLEVALCOORD1F@_GLEVALCOORD1FV@_GLEVALCOORD2D@_GLEVALCOORD2DV@_GLEVALCOORD2F@_GLEVALCOORD2FV@_GLEVALMESH1@_GLEVALMESH2@_GLEVALPOINT1@_GLEVALPOINT2@_GLFEEDBACKBUFFER@_GLFINISH@_GLFLUSH@_GLFOGF@_GLFOGFV@_GLFOGI@_GLFOGIV@_GLFRONTFACE@_GLFRUSTUM@_GLGENLISTS@_GLGENTEXTURES@_GLGETBOOLEANV@_GLGETCLIPPLANE@_GLGETDOUBLEV@_GLGETERROR@_GLGETFLOATV@_GLGETINTEGERV@_GLGETLIGHTFV@_GLGETLIGHTIV@_GLGETMAPDV@_GLGETMAPFV@_GLGETMAPIV@_GLGETMATERIALFV@_GLGETMATERIALIV@_GLGETPIXELMAPFV@_GLGETPIXELMAPUIV@_GLGETPIXELMAPUSV@_GLGETPOINTERV@_GLGETPOLYGONSTIPPLE@_GLGETSTRING@_GLGETTEXENVFV@_GLGETTEXENVIV@_GLGETTEXGENDV@_GLGETTEXGENFV@_GLGETTEXGENIV@_GLGETTEXIMAGE@_GLGETTEXLEVELPARAMETERFV@_GLGETTEXLEVELPARAMETERIV@_GLGETTEXPARAMETERFV@_GLGETTEXPARAMETERIV@_GLHINT@_GLINDEXMASK@_GLINDEXPOINTER@_GLINDEXD@_GLINDEXDV@_GLINDEXF@_GLINDEXFV@_GLINDEXI@_GLINDEXIV@_GLINDEXS@_GLINDEXSV@_GLINDEXUB@_GLINDEXUBV@_GLINITNAMES@_GLINTERLEAVEDARRAYS@_GLISENABLED@_GLISLIST@_GLISTEXTURE@_GLLIGHTMODELF@_GLLIGHTMODELFV@_GLLIGHTMODELI@_GLLIGHTMODELIV@_GLLIGHTF@_GLLIGHTFV@_GLLIGHTI@_GLLIGHTIV@_GLLINESTIPPLE@_GLLINEWIDTH@_GLLISTBASE@_GLLOADIDENTITY@_GLLOADMATRIXD@_GLLOADMATRIXF@_GLLOADNAME@_GLLOGICOP@_GLMAP1D@_GLMAP1F@_GLMAP2D@_GLMAP2F@_GLMAPGRID1D@_GLMAPGRID1F@_GLMAPGRID2D@_GLMAPGRID2F@_GLMATERIALF@_GLMATERIALFV@_GLMATERIALI@_GLMATERIALIV@_GLMATRIXMODE@_GLMULTMATRIXD@_GLMULTMATRIXF@_GLNEWLIST@_GLNORMAL3B@_GLNORMAL3BV@_GLNORMAL3D@_GLNORMAL3DV@_GLNORMAL3F@_GLNORMAL3FV@_GLNORMAL3I@_GLNORMAL3IV@_GLNORMAL3S@_GLNORMAL3SV@_GLNORMALPOINTER@_GLORTHO@_GLPASSTHROUGH@_GLPIXELMAPFV@_GLPIXELMAPUIV@_GLPIXELMAPUSV@_GLPIXELSTOREF@_GLPIXELSTOREI@_GLPIXELTRANSFERF@_GLPIXELTRANSFERI@_GLPIXELZOOM@_GLPOINTSIZE@_GLPOLYGONMODE@_GLPOLYGONOFFSET@_GLPOLYGONSTIPPLE@"
kw$ = kw$ + "_GLPOPATTRIB@_GLPOPCLIENTATTRIB@_GLPOPMATRIX@_GLPOPNAME@_GLPRIORITIZETEXTURES@_GLPUSHATTRIB@_GLPUSHCLIENTATTRIB@_GLPUSHMATRIX@_GLPUSHNAME@_GLRASTERPOS2D@_GLRASTERPOS2DV@_GLRASTERPOS2F@_GLRASTERPOS2FV@_GLRASTERPOS2I@_GLRASTERPOS2IV@_GLRASTERPOS2S@_GLRASTERPOS2SV@_GLRASTERPOS3D@_GLRASTERPOS3DV@_GLRASTERPOS3F@_GLRASTERPOS3FV@_GLRASTERPOS3I@_GLRASTERPOS3IV@_GLRASTERPOS3S@_GLRASTERPOS3SV@_GLRASTERPOS4D@_GLRASTERPOS4DV@_GLRASTERPOS4F@_GLRASTERPOS4FV@_GLRASTERPOS4I@_GLRASTERPOS4IV@_GLRASTERPOS4S@_GLRASTERPOS4SV@_GLREADBUFFER@_GLREADPIXELS@_GLRECTD@_GLRECTDV@_GLRECTF@_GLRECTFV@_GLRECTI@_GLRECTIV@_GLRECTS@_GLRECTSV@_GLRENDERMODE@_GLROTATED@_GLROTATEF@_GLSCALED@_GLSCALEF@_GLSCISSOR@_GLSELECTBUFFER@_GLSHADEMODEL@_GLSTENCILFUNC@_GLSTENCILMASK@_GLSTENCILOP@_GLTEXCOORD1D@_GLTEXCOORD1DV@_GLTEXCOORD1F@_GLTEXCOORD1FV@_GLTEXCOORD1I@_GLTEXCOORD1IV@_GLTEXCOORD1S@_GLTEXCOORD1SV@_GLTEXCOORD2D@_GLTEXCOORD2DV@_GLTEXCOORD2F@_GLTEXCOORD2FV@_GLTEXCOORD2I@_GLTEXCOORD2IV@_GLTEXCOORD2S@_GLTEXCOORD2SV@_GLTEXCOORD3D@_GLTEXCOORD3DV@_GLTEXCOORD3F@_GLTEXCOORD3FV@_GLTEXCOORD3I@_GLTEXCOORD3IV@_GLTEXCOORD3S@_GLTEXCOORD3SV@_GLTEXCOORD4D@_GLTEXCOORD4DV@_GLTEXCOORD4F@_GLTEXCOORD4FV@_GLTEXCOORD4I@_GLTEXCOORD4IV@_GLTEXCOORD4S@_GLTEXCOORD4SV@_GLTEXCOORDPOINTER@_GLTEXENVF@_GLTEXENVFV@_GLTEXENVI@_GLTEXENVIV@_GLTEXGEND@_GLTEXGENDV@_GLTEXGENF@_GLTEXGENFV@_GLTEXGENI@_GLTEXGENIV@_GLTEXIMAGE1D@_GLTEXIMAGE2D@_GLTEXPARAMETERF@_GLTEXPARAMETERFV@_GLTEXPARAMETERI@_GLTEXPARAMETERIV@_GLTEXSUBIMAGE1D@_GLTEXSUBIMAGE2D@_GLTRANSLATED@_GLTRANSLATEF@_GLVERTEX2D@_GLVERTEX2DV@_GLVERTEX2F@_GLVERTEX2FV@_GLVERTEX2I@_GLVERTEX2IV@_GLVERTEX2S@_GLVERTEX2SV@_GLVERTEX3D@_GLVERTEX3DV@_GLVERTEX3F@_GLVERTEX3FV@_GLVERTEX3I@_GLVERTEX3IV@_GLVERTEX3S@_GLVERTEX3SV@_GLVERTEX4D@_GLVERTEX4DV@_GLVERTEX4F@_GLVERTEX4FV@_GLVERTEX4I@_GLVERTEX4IV@_GLVERTEX4S@_GLVERTEX4SV@_GLVERTEXPOINTER@_GLVIEWPORT@SMOOTH@STRETCH@_ANTICLOCKWISE@_BEHIND@_CLEAR@_FILLBACKGROUND@_GLUPERSPECTIVE@_HARDWARE@_HARDWARE1@_KEEPBACKGROUND@_NONE@_OFF@_ONLY@_ONLYBACKGROUND@_ONTOP@_SEAMLESS@_SMOOTH@_SMOOTHSHRUNK@_SMOOTHSTRETCHED@"
kw$ = kw$ + "_SOFTWARE@_SQUAREPIXELS@_STRETCH@_ALLOWFULLSCREEN@_ALL@_ECHO@_INSTRREV@_TRIM$@_ACCEPTFILEDROP@_FINISHDROP@_TOTALDROPPEDFILES@_DROPPEDFILE@_DROPPEDFILE$@_SHR@_SHL@"
 
DO
    at1 = INSTR(kw$, "@")
    at2 = INSTR(at1 + 1, kw$, "@")
    k$ = MID$(kw$, at1 + 1, at2 - at1 - 1)
 
    IF INSTR(noGo$, "@" + k$ + "@") = 0 THEN
        temp$ = temp$ + "'" + k$ + "', "
        IF LEN(temp$) > 75 THEN
            result$ = result$ + temp$ + CHR$(10)
            temp$ = ""
        END IF
    END IF
 
    kw$ = MID$(kw$, at2)
LOOP WHILE LEN(kw$) > 1
 
_CLIPBOARD$ = result$
PRINT result$

Raven_Singularity · « **Reply #10 on:** April 27, 2019, 10:00:13 pm »

For the issue of not being able to select the code, you could possibly have a plain text version of the code in a div tag that is hidden with CSS, and when the Javascript button is pushed, it copies that text to the clipboard.

That would be a "Copy" button, not a "Select" button. Which would make more sense than Select for the other code block as well.

RhoSigma · « **Reply #11 on:** April 27, 2019, 10:08:05 pm »

Nothing more to say than in this song :) https://m.youtube.com/watch?v=CKZUEpdJhO8

FellippeHeitor · « **Reply #12 on:** April 27, 2019, 10:12:28 pm »

Quote from: Raven_Singularity on April 27, 2019, 10:00:13 pm

For the issue of not being able to select the code, you could possibly have a plain text version of the code in a div tag that is hidden with CSS, and when the Javascript button is pushed, it copies that text to the clipboard.

That would be a "Copy" button, not a "Select" button. Which would make more sense than Select for the other code block as well.

Only issue is that it's beyond my skill, maybe one day ;-)

Quote from: RhoSigma on April 27, 2019, 10:08:05 pm

Nothing more to say than in this song :) https://m.youtube.com/watch?v=CKZUEpdJhO8

:-)

FellippeHeitor · « **Reply #13 on:** April 27, 2019, 11:14:43 pm »

Ok, I guess this is the final tweak for the night: You can now [Select] a code block even with the new formatting.

Code: QB64: [Select]

RANDOMIZE TIMER
SCREEN _NEWIMAGE(600, 600, 32)
_DEST _NEWIMAGE(300, 300, 32)
COLOR , 0
difficulty! = 1.5
DO
    _PRINTSTRING (0, 0), "SCORE:" + STR$(score&), 0
    letter$ = CHR$(INT(RND * 26) + 65)
    x = RND * (_WIDTH - 30)
    y = RND * (_HEIGHT - 30)
    LINE (x, y)-STEP(30, 30), _RGB32(x MOD 200 + (100 * ABS((x MOD 200) < 50)), y MOD 150 + (100 * ABS((y MOD 150) < 50)), x MOD 255 + (100 * ABS((x MOD 150) < 50))), BF
    _PRINTSTRING (x + 11, y + 7), letter$
    start! = TIMER
    DO
        k$ = UCASE$(INKEY$)
        DO WHILE TIMER - start! > difficulty!
            GOTO checkKey
        LOOP
        LINE (0, _HEIGHT - 5)-(((_WIDTH + 5) * ((TIMER - start!) / difficulty!)), _HEIGHT), _RGB32(x MOD 200 + (100 * ABS((x MOD 200) < 50)), y MOD 150 + (100 * ABS((y MOD 150) < 50)), x MOD 255 + (100 * ABS((x MOD 150) < 50))), BF
        _PUTIMAGE , _DEST, _DISPLAY
        _LIMIT 30
    LOOP WHILE k$ < "A" OR k$ > "Z"
    checkKey:
    LINE (x - (300 * (k$ = letter$)), y - (300 * (k$ = letter$)))-STEP(30, 30), _RGBA32(0, 0, 0, 200), BF
    LINE (x - (300 * (k$ <> letter$)), y - (300 * (k$ <> letter$)))-STEP(30, 30), _RGB32(255, 255, 0), B
    score& = score& + ABS(k$ = letter$) - (ABS(k$ <> letter$) * ABS(LEN(k$) > 0))
    difficulty! = difficulty! - (ABS(k$ = letter$) / 100)
LOOP UNTIL score& < 0 OR score& = 21
_PRINTSTRING (_WIDTH / 2 - (LEN("You " + LEFT$("lose...", 7 * ABS(score& < 0)) + LEFT$("win!", 4 * ABS(score& > 0))) * 8) / 2, _HEIGHT / 2 - 8), "You " + LEFT$("lose...", 7 * ABS(score& < 0)) + LEFT$("win!", 4 * ABS(score& > 0)), 0
_PUTIMAGE , _DEST, _DISPLAY

Note that even though the line numbers look selected, they won't be copied.

Raven_Singularity · « **Reply #14 on:** April 27, 2019, 11:23:30 pm »

Quote from: FellippeHeitor on April 27, 2019, 11:14:43 pm

Ok, I guess this is the final tweak for the night: You can now [Select] a code block even with the new formatting.

Excellent! I already noticed it was working when I copied the code I posted a few moments ago. :-)

Quote from: FellippeHeitor on April 27, 2019, 11:14:43 pm

Note that even though the line numbers look selected, they won't be copied.

On Windows 10 / Firefox, the line numbers are not being highlighted.

News:

Author Topic: Extended syntax highlighting added (Read 5943 times)

odin

Extended syntax highlighting added

Pete

Re: Extended syntax highlighting added

FellippeHeitor

Re: Extended syntax highlighting added

RhoSigma

Re: Extended syntax highlighting added

odin

Re: Extended syntax highlighting added

RhoSigma

Re: Extended syntax highlighting added

Raven_Singularity

Re: Extended syntax highlighting added

Pete

Re: Extended syntax highlighting added

FellippeHeitor

Re: Extended syntax highlighting added

FellippeHeitor

Re: Extended syntax highlighting added

Raven_Singularity

Re: Extended syntax highlighting added

RhoSigma

Re: Extended syntax highlighting added

FellippeHeitor

Re: Extended syntax highlighting added

FellippeHeitor

Re: Extended syntax highlighting added

Raven_Singularity

Re: Extended syntax highlighting added