diff --git a/source/utilities/QB45BIN.bas b/source/utilities/QB45BIN.bas deleted file mode 100644 index a20c9daee..000000000 --- a/source/utilities/QB45BIN.bas +++ /dev/null @@ -1,3230 +0,0 @@ -'QB45BIN.BAS - written by qarnos -'Used by permission: http://www.qb64.net/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 [-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 IsLineNumber(SubstTxt) THEN SubstTxt = SubstTxt + " " ELSE 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 diff --git a/source/utilities/color0.bi b/source/utilities/color0.bi deleted file mode 100644 index d57de4ee5..000000000 --- a/source/utilities/color0.bi +++ /dev/null @@ -1,20 +0,0 @@ -'$COLOR:0 -'Color constants for text mode. -CONST Black~%% = 0 -CONST Blue~%% = 1 -CONST Green~%% = 2 -CONST Cyan~%% = 3 -CONST Red~%% = 4 -CONST Magenta~%% = 5 -CONST Brown~%% = 6 -CONST White~%% = 7 -CONST Gray~%% = 8 -CONST LightBlue~%% = 9 -CONST LightGreen~%% = 10 -CONST LightCyan~%% = 11 -CONST LightRed~%% = 12 -CONST LightMagenta~%% = 13 -CONST Yellow~%% = 14 -CONST BrightWhite~%% = 15 -CONST Blink~%% = 16 - diff --git a/source/utilities/color32.bi b/source/utilities/color32.bi deleted file mode 100644 index 024c3aeba..000000000 --- a/source/utilities/color32.bi +++ /dev/null @@ -1,272 +0,0 @@ -'$COLOR:32 -'Color constants for 32bit mode, based on HTML color names. -CONST AliceBlue~& = 4293982463 -CONST Almond~& = 4293910221 -CONST AntiqueBrass~& = 4291663221 -CONST AntiqueWhite~& = 4294634455 -CONST Apricot~& = 4294826421 -CONST Aqua~& = 4278255615 -CONST Aquamarine~& = 4286578644 -CONST Asparagus~& = 4287080811 -CONST AtomicTangerine~& = 4294943860 -CONST Azure~& = 4293984255 -CONST BananaMania~& = 4294633397 -CONST Beaver~& = 4288643440 -CONST Beige~& = 4294309340 -CONST Bisque~& = 4294960324 -CONST Bittersweet~& = 4294802542 -CONST Black~& = 4278190080 -CONST BlanchedAlmond~& = 4294962125 -CONST BlizzardBlue~& = 4289521134 -CONST Blue~& = 4278190335 -CONST BlueBell~& = 4288848592 -CONST BlueGray~& = 4284914124 -CONST BlueGreen~& = 4279081146 -CONST BlueViolet~& = 4287245282 -CONST Blush~& = 4292763011 -CONST BrickRed~& = 4291510612 -CONST Brown~& = 4289014314 -CONST BurlyWood~& = 4292786311 -CONST BurntOrange~& = 4294934345 -CONST BurntSienna~& = 4293557853 -CONST CadetBlue~& = 4284456608 -CONST Canary~& = 4294967193 -CONST CaribbeanGreen~& = 4280079266 -CONST CarnationPink~& = 4294945484 -CONST Cerise~& = 4292691090 -CONST Cerulean~& = 4280134870 -CONST ChartReuse~& = 4286578432 -CONST Chestnut~& = 4290534744 -CONST Chocolate~& = 4291979550 -CONST Copper~& = 4292711541 -CONST Coral~& = 4294934352 -CONST Cornflower~& = 4288335595 -CONST CornflowerBlue~& = 4284782061 -CONST Cornsilk~& = 4294965468 -CONST CottonCandy~& = 4294950105 -CONST CrayolaAquamarine~& = 4286110690 -CONST CrayolaBlue~& = 4280251902 -CONST CrayolaBlueViolet~& = 4285753021 -CONST CrayolaBrown~& = 4290013005 -CONST CrayolaCadetBlue~& = 4289771462 -CONST CrayolaForestGreen~& = 4285378177 -CONST CrayolaGold~& = 4293379735 -CONST CrayolaGoldenrod~& = 4294760821 -CONST CrayolaGray~& = 4287992204 -CONST CrayolaGreen~& = 4280069240 -CONST CrayolaGreenYellow~& = 4293978257 -CONST CrayolaIndigo~& = 4284315339 -CONST CrayolaLavender~& = 4294751445 -CONST CrayolaMagenta~& = 4294337711 -CONST CrayolaMaroon~& = 4291311706 -CONST CrayolaMidnightBlue~& = 4279912566 -CONST CrayolaOrange~& = 4294931768 -CONST CrayolaOrangeRed~& = 4294912811 -CONST CrayolaOrchid~& = 4293306583 -CONST CrayolaPlum~& = 4287513989 -CONST CrayolaRed~& = 4293795917 -CONST CrayolaSalmon~& = 4294941610 -CONST CrayolaSeaGreen~& = 4288668351 -CONST CrayolaSilver~& = 4291675586 -CONST CrayolaSkyBlue~& = 4286634731 -CONST CrayolaSpringGreen~& = 4293716670 -CONST CrayolaTann~& = 4294616940 -CONST CrayolaThistle~& = 4293642207 -CONST CrayolaViolet~& = 4287786670 -CONST CrayolaYellow~& = 4294764675 -CONST CrayolaYellowGreen~& = 4291158916 -CONST Crimson~& = 4292613180 -CONST Cyan~& = 4278255615 -CONST Dandelion~& = 4294826861 -CONST DarkBlue~& = 4278190219 -CONST DarkCyan~& = 4278225803 -CONST DarkGoldenRod~& = 4290283019 -CONST DarkGray~& = 4289309097 -CONST DarkGreen~& = 4278215680 -CONST DarkKhaki~& = 4290623339 -CONST DarkMagenta~& = 4287299723 -CONST DarkOliveGreen~& = 4283788079 -CONST DarkOrange~& = 4294937600 -CONST DarkOrchid~& = 4288230092 -CONST DarkRed~& = 4287299584 -CONST DarkSalmon~& = 4293498490 -CONST DarkSeaGreen~& = 4287609999 -CONST DarkSlateBlue~& = 4282924427 -CONST DarkSlateGray~& = 4281290575 -CONST DarkTurquoise~& = 4278243025 -CONST DarkViolet~& = 4287889619 -CONST DeepPink~& = 4294907027 -CONST DeepSkyBlue~& = 4278239231 -CONST Denim~& = 4281035972 -CONST DesertSand~& = 4293905848 -CONST DimGray~& = 4285098345 -CONST DodgerBlue~& = 4280193279 -CONST Eggplant~& = 4285419872 -CONST ElectricLime~& = 4291755805 -CONST Fern~& = 4285643896 -CONST FireBrick~& = 4289864226 -CONST Floralwhite~& = 4294966000 -CONST ForestGreen~& = 4280453922 -CONST Fuchsia~& = 4290995397 -CONST FuzzyWuzzy~& = 4291585638 -CONST Gainsboro~& = 4292664540 -CONST GhostWhite~& = 4294506751 -CONST Gold~& = 4294956800 -CONST GoldenRod~& = 4292519200 -CONST GrannySmithApple~& = 4289258656 -CONST Gray~& = 4286611584 -CONST Green~& = 4278222848 -CONST GreenBlue~& = 4279329972 -CONST GreenYellow~& = 4289593135 -CONST HoneyDew~& = 4293984240 -CONST HotMagenta~& = 4294909390 -CONST HotPink~& = 4294928820 -CONST Inchworm~& = 4289915997 -CONST IndianRed~& = 4291648604 -CONST Indigo~& = 4283105410 -CONST Ivory~& = 4294967280 -CONST JazzberryJam~& = 4291442535 -CONST JungleGreen~& = 4282101903 -CONST Khaki~& = 4293977740 -CONST LaserLemon~& = 4294901282 -CONST Lavender~& = 4293322490 -CONST LavenderBlush~& = 4294963445 -CONST LawnGreen~& = 4286381056 -CONST LemonChiffon~& = 4294965965 -CONST LemonYellow~& = 4294964303 -CONST LightBlue~& = 4289583334 -CONST LightCoral~& = 4293951616 -CONST LightCyan~& = 4292935679 -CONST LightGoldenRodYellow~& = 4294638290 -CONST LightGray~& = 4292072403 -CONST LightGreen~& = 4287688336 -CONST LightPink~& = 4294948545 -CONST LightSalmon~& = 4294942842 -CONST LightSeaGreen~& = 4280332970 -CONST LightSkyBlue~& = 4287090426 -CONST LightSlateGray~& = 4286023833 -CONST LightSteelBlue~& = 4289774814 -CONST LightYellow~& = 4294967264 -CONST Lime~& = 4278255360 -CONST LimeGreen~& = 4281519410 -CONST Linen~& = 4294635750 -CONST MacaroniAndCheese~& = 4294950280 -CONST Magenta~& = 4294902015 -CONST MagicMint~& = 4289392849 -CONST Mahogany~& = 4291643980 -CONST Maize~& = 4293775772 -CONST Manatee~& = 4288125610 -CONST MangoTango~& = 4294935107 -CONST Maroon~& = 4286578688 -CONST Mauvelous~& = 4293892266 -CONST MediumAquamarine~& = 4284927402 -CONST MediumBlue~& = 4278190285 -CONST MediumOrchid~& = 4290401747 -CONST MediumPurple~& = 4287852763 -CONST MediumSeaGreen~& = 4282168177 -CONST MediumSlateBlue~& = 4286277870 -CONST MediumSpringGreen~& = 4278254234 -CONST MediumTurquoise~& = 4282962380 -CONST MediumVioletRed~& = 4291237253 -CONST Melon~& = 4294818996 -CONST MidnightBlue~& = 4279834992 -CONST MintCream~& = 4294311930 -CONST MistyRose~& = 4294960353 -CONST Moccasin~& = 4294960309 -CONST MountainMeadow~& = 4281383567 -CONST Mulberry~& = 4291120012 -CONST NavajoWhite~& = 4294958765 -CONST Navy~& = 4278190208 -CONST NavyBlue~& = 4279858386 -CONST NeonCarrot~& = 4294943555 -CONST OldLace~& = 4294833638 -CONST Olive~& = 4286611456 -CONST OliveDrab~& = 4285238819 -CONST OliveGreen~& = 4290426988 -CONST Orange~& = 4294944000 -CONST OrangeRed~& = 4294919424 -CONST OrangeYellow~& = 4294497640 -CONST Orchid~& = 4292505814 -CONST OuterSpace~& = 4282468940 -CONST OutrageousOrange~& = 4294929994 -CONST PacificBlue~& = 4280068553 -CONST PaleGoldenRod~& = 4293847210 -CONST PaleGreen~& = 4288215960 -CONST PaleTurquoise~& = 4289720046 -CONST PaleVioletRed~& = 4292571283 -CONST PapayaWhip~& = 4294963157 -CONST Peach~& = 4294954923 -CONST PeachPuff~& = 4294957753 -CONST Periwinkle~& = 4291154150 -CONST Peru~& = 4291659071 -CONST PiggyPink~& = 4294827494 -CONST PineGreen~& = 4279599224 -CONST Pink~& = 4294951115 -CONST PinkFlamingo~& = 4294735101 -CONST PinkSherbet~& = 4294414247 -CONST Plum~& = 4292714717 -CONST PowderBlue~& = 4289781990 -CONST Purple~& = 4286578816 -CONST PurpleHeart~& = 4285809352 -CONST PurpleMountainsMajesty~& = 4288512442 -CONST PurplePizzazz~& = 4294856410 -CONST RadicalRed~& = 4294920556 -CONST RawSienna~& = 4292250201 -CONST RawUmber~& = 4285614883 -CONST RazzleDazzleRose~& = 4294920400 -CONST Razzmatazz~& = 4293076331 -CONST Red~& = 4294901760 -CONST RedOrange~& = 4294923081 -CONST RedViolet~& = 4290790543 -CONST RobinsEggBlue~& = 4280274635 -CONST RosyBrown~& = 4290547599 -CONST RoyalBlue~& = 4282477025 -CONST RoyalPurple~& = 4286075305 -CONST SaddleBrown~& = 4287317267 -CONST Salmon~& = 4294606962 -CONST SandyBrown~& = 4294222944 -CONST Scarlet~& = 4294715463 -CONST ScreaminGreen~& = 4285988730 -CONST SeaGreen~& = 4281240407 -CONST SeaShell~& = 4294964718 -CONST Sepia~& = 4289030479 -CONST Shadow~& = 4287265117 -CONST Shamrock~& = 4282764962 -CONST ShockingPink~& = 4294672125 -CONST Sienna~& = 4288696877 -CONST Silver~& = 4290822336 -CONST SkyBlue~& = 4287090411 -CONST SlateBlue~& = 4285160141 -CONST SlateGray~& = 4285563024 -CONST Snow~& = 4294966010 -CONST SpringGreen~& = 4278255487 -CONST SteelBlue~& = 4282811060 -CONST Sunglow~& = 4294954824 -CONST SunsetOrange~& = 4294794835 -CONST Tann~& = 4291998860 -CONST Teal~& = 4278222976 -CONST TealBlue~& = 4279805877 -CONST Thistle~& = 4292394968 -CONST TickleMePink~& = 4294740396 -CONST Timberwolf~& = 4292597714 -CONST Tomato~& = 4294927175 -CONST TropicalRainForest~& = 4279730285 -CONST Tumbleweed~& = 4292782728 -CONST Turquoise~& = 4282441936 -CONST TurquoiseBlue~& = 4286045671 -CONST UnmellowYellow~& = 4294967142 -CONST Violet~& = 4293821166 -CONST VioletBlue~& = 4281486002 -CONST VioletRed~& = 4294398868 -CONST VividTangerine~& = 4294942857 -CONST VividViolet~& = 4287582365 -CONST Wheat~& = 4294303411 -CONST White~& = 4294967295 -CONST Whitesmoke~& = 4294309365 -CONST WildBlueYonder~& = 4288851408 -CONST WildStrawberry~& = 4294919076 -CONST WildWatermelon~& = 4294732933 -CONST Wisteria~& = 4291667166 -CONST Yellow~& = 4294967040 -CONST YellowGreen~& = 4288335154 -CONST YellowOrange~& = 4294946370 diff --git a/source/utilities/vwatch/vwatch.bi b/source/utilities/vwatch/vwatch.bi deleted file mode 100644 index 5bb830bfa..000000000 --- a/source/utilities/vwatch/vwatch.bi +++ /dev/null @@ -1,14 +0,0 @@ -$CHECKING:OFF -DIM SHARED AS LONG vwatch_linenumber, vwatch_sublevel, vwatch_goto -DIM SHARED AS STRING vwatch_subname, vwatch_callstack -REDIM SHARED vwatch_breakpoints(0) AS _BYTE -REDIM SHARED vwatch_skiplines(0) AS _BYTE -'next lines are just to avoid "unused variable" warnings: -vwatch_linenumber = 0 -vwatch_sublevel = 0 -vwatch_goto = 0 -vwatch_breakpoints(0) = 0 -vwatch_skiplines(0) = 0 -vwatch_subname = "" -vwatch_callstack = "" -$CHECKING:ON diff --git a/source/utilities/vwatch/vwatch.bm b/source/utilities/vwatch/vwatch.bm deleted file mode 100644 index 31ca30aa6..000000000 --- a/source/utilities/vwatch/vwatch.bm +++ /dev/null @@ -1,285 +0,0 @@ -$CHECKING:OFF - -SUB vwatch (localVariables AS _OFFSET) - STATIC AS LONG ideHost, breakpointCount, skipCount, timeout, startLevel, lastLine - STATIC AS LONG callStackLength, runToLine - STATIC AS _BYTE pauseMode, stepOver, bypass, setNextLine - STATIC buffer$, endc$ - DIM AS LONG i - DIM AS _OFFSET address - DIM AS _MEM m - DIM start!, temp$, cmd$, value$, k& - - DECLARE LIBRARY - SUB vwatch_stoptimers ALIAS stop_timers - SUB vwatch_starttimers ALIAS start_timers - SUB unlockvWatchHandle - END DECLARE - - IF bypass THEN EXIT SUB - - vwatch_goto = 0 - - IF ideHost = 0 THEN - timeout = 10 - endc$ = "" - - 'initial setup - GOSUB Connect - - 'send this binary's path/exe name - cmd$ = "me:" + COMMAND$(0) - GOSUB SendCommand - - DO - GOSUB GetCommand - SELECT CASE cmd$ - CASE "vwatch" - IF value$ <> "ok" THEN - unlockvWatchHandle: CLOSE #ideHost - bypass = -1 - EXIT SUB - END IF - CASE "line count" - REDIM vwatch_breakpoints(CVL(value$)) AS _BYTE - REDIM vwatch_skiplines(CVL(value$)) AS _BYTE - CASE "breakpoint count" - breakpointCount = CVL(value$) - CASE "breakpoint list" - IF LEN(value$) \ 4 <> breakpointCount THEN - cmd$ = "quit:Communication error." - GOSUB SendCommand - unlockvWatchHandle: CLOSE #ideHost - bypass = -1 - EXIT SUB - END IF - FOR i = 1 TO breakpointCount - temp$ = MID$(value$, i * 4 - 3, 4) - vwatch_breakpoints(CVL(temp$)) = -1 - NEXT - CASE "skip count" - skipCount = CVL(value$) - CASE "skip list" - IF LEN(value$) \ 4 <> skipCount THEN - cmd$ = "quit:Communication error." - GOSUB SendCommand - unlockvWatchHandle: CLOSE #ideHost - bypass = -1 - EXIT SUB - END IF - FOR i = 1 TO skipCount - temp$ = MID$(value$, i * 4 - 3, 4) - vwatch_skiplines(CVL(temp$)) = -1 - NEXT - CASE "run" - IF vwatch_breakpoints(vwatch_linenumber) THEN EXIT DO - pauseMode = 0 - EXIT SUB - CASE "break" - pauseMode = -1 - EXIT DO - END SELECT - LOOP - END IF - - IF vwatch_linenumber = 0 THEN - GOSUB SendCallStack - cmd$ = "quit:Program ended." - GOSUB SendCommand - unlockvWatchHandle: CLOSE #ideHost - bypass = -1 - ideHost = 0 - EXIT SUB - ELSEIF vwatch_linenumber = -1 THEN - 'report an error in the most recent line - GOSUB SendCallStack - cmd$ = "error:" + MKL$(lastLine) - GOSUB SendCommand - EXIT SUB - ELSEIF vwatch_linenumber = -2 THEN - 'report a new sub/function has been "entered" - IF LEN(vwatch_callstack) > 100000 THEN - vwatch_callstack = "" - callStackLength = 0 - END IF - callStackLength = callStackLength + 1 - IF LEN(vwatch_callstack) THEN vwatch_callstack = vwatch_callstack + CHR$(0) - vwatch_callstack = vwatch_callstack + vwatch_subname$ + ", line" + STR$(lastLine) - EXIT SUB - ELSEIF vwatch_linenumber = -3 THEN - 'handle STOP - instead of quitting, pause execution - pauseMode = -1 - stepOver = 0 - EXIT SUB - END IF - - IF vwatch_linenumber = lastLine AND setNextLine = 0 THEN EXIT SUB - setNextLine = 0 - lastLine = vwatch_linenumber - - GOSUB GetCommand - SELECT CASE cmd$ - CASE "break" - pauseMode = -1 - stepOver = 0 - runToLine = 0 - cmd$ = "" - CASE "set breakpoint" - vwatch_breakpoints(CVL(value$)) = -1 - vwatch_skiplines(CVL(value$)) = 0 - CASE "clear breakpoint" - vwatch_breakpoints(CVL(value$)) = 0 - CASE "set skip line" - vwatch_skiplines(CVL(value$)) = -1 - vwatch_breakpoints(CVL(value$)) = 0 - CASE "clear skip line" - vwatch_skiplines(CVL(value$)) = 0 - CASE "clear all breakpoints" - REDIM vwatch_breakpoints(UBOUND(vwatch_breakpoints)) AS _BYTE - CASE "clear all skips" - REDIM vwatch_skiplines(UBOUND(vwatch_skiplines)) AS _BYTE - END SELECT - - IF vwatch_skiplines(vwatch_linenumber) THEN vwatch_goto = -vwatch_linenumber: EXIT SUB - - IF stepOver = -1 AND vwatch_sublevel > startLevel AND vwatch_breakpoints(vwatch_linenumber) = 0 THEN - EXIT SUB - ELSEIF stepOver = -1 AND vwatch_sublevel = startLevel THEN - stepOver = 0 - pauseMode = -1 - END IF - - IF runToLine > 0 AND runToLine <> vwatch_linenumber THEN - EXIT SUB - ELSEIF runToLine > 0 AND runToLine = vwatch_linenumber THEN - pauseMode = -1 - runToLine = 0 - END IF - - IF vwatch_breakpoints(vwatch_linenumber) = 0 AND pauseMode = 0 THEN - EXIT SUB - END IF - - vwatch_stoptimers - cmd$ = "line number:" - IF vwatch_breakpoints(vwatch_linenumber) THEN cmd$ = "breakpoint:" - cmd$ = cmd$ + MKL$(vwatch_linenumber) - GOSUB SendCommand - - DO 'main loop - SELECT CASE cmd$ - CASE "run" - pauseMode = 0 - stepOver = 0 - vwatch_starttimers - EXIT SUB - CASE "run to line" - pauseMode = 0 - stepOver = 0 - runToLine = CVL(value$) - vwatch_starttimers - EXIT SUB - CASE "step" - pauseMode = -1 - stepOver = 0 - EXIT SUB - CASE "step over" - pauseMode = -1 - stepOver = -1 - startLevel = vwatch_sublevel - vwatch_starttimers - EXIT SUB - CASE "step out" - pauseMode = -1 - stepOver = -1 - startLevel = vwatch_sublevel - 1 - vwatch_starttimers - EXIT SUB - CASE "free" - unlockvWatchHandle: CLOSE #ideHost - ideHost = 0 - bypass = -1 - vwatch_starttimers - EXIT SUB - CASE "set breakpoint" - vwatch_breakpoints(CVL(value$)) = -1 - vwatch_skiplines(CVL(value$)) = 0 - CASE "clear breakpoint" - vwatch_breakpoints(CVL(value$)) = 0 - CASE "clear all breakpoints" - REDIM vwatch_breakpoints(UBOUND(vwatch_breakpoints)) AS _BYTE - CASE "clear all skips" - REDIM vwatch_skiplines(UBOUND(vwatch_skiplines)) AS _BYTE - CASE "call stack" - 'send call stack history" - GOSUB SendCallStack - CASE "local" - i = CVL(value$) - address = localVariables + LEN(address) * i - PRINT "Local"; i; "is at"; _MEMGET(m, address, _OFFSET) - CASE "set next line" - pauseMode = -1 - stepOver = 0 - setNextLine = -1 - vwatch_goto = CVL(value$) - EXIT SUB - CASE "set skip line" - vwatch_skiplines(CVL(value$)) = -1 - vwatch_breakpoints(CVL(value$)) = 0 - CASE "clear skip line" - vwatch_skiplines(CVL(value$)) = 0 - END SELECT - - GOSUB GetCommand - _LIMIT 100 - LOOP - - vwatch_starttimers - EXIT SUB - - Connect: - DIM ideport$ - ideport$ = ENVIRON$("QB64DEBUGPORT") - IF ideport$ = "" THEN bypass = -1: EXIT SUB - - start! = TIMER - DO - k& = _KEYHIT - ideHost = _OPENCLIENT("QB64IDE:" + ideport$ + ":localhost") - _LIMIT 30 - LOOP UNTIL k& = 27 OR ideHost <> 0 OR TIMER - start! > timeout - IF ideHost = 0 THEN bypass = -1: EXIT SUB - RETURN - - GetCommand: - GET #ideHost, , temp$ - buffer$ = buffer$ + temp$ - - IF INSTR(buffer$, endc$) THEN - cmd$ = LEFT$(buffer$, INSTR(buffer$, endc$) - 1) - buffer$ = MID$(buffer$, INSTR(buffer$, endc$) + LEN(endc$)) - - IF INSTR(cmd$, ":") THEN - value$ = MID$(cmd$, INSTR(cmd$, ":") + 1) - cmd$ = LEFT$(cmd$, INSTR(cmd$, ":") - 1) - ELSE - value$ = "" - END IF - ELSE - cmd$ = "": value$ = "" - END IF - RETURN - - SendCallStack: - cmd$ = "call stack size:" + MKL$(callStackLength) - GOSUB SendCommand - cmd$ = "call stack:" + vwatch_callstack - GOSUB SendCommand - RETURN - - SendCommand: - cmd$ = cmd$ + endc$ - PUT #ideHost, , cmd$ - cmd$ = "" - RETURN -END SUB diff --git a/source/utilities/vwatch/vwatch_stub.bm b/source/utilities/vwatch/vwatch_stub.bm deleted file mode 100644 index f78094759..000000000 --- a/source/utilities/vwatch/vwatch_stub.bm +++ /dev/null @@ -1,2 +0,0 @@ -SUB vwatch () -END SUB