'Copyright 2020 Luke Ceddia ' 'Licensed under the Apache License, Version 2.0 (the "License"); 'you may not use this file except in compliance with the License. 'You may obtain a copy of the License at ' ' http://www.apache.org/licenses/LICENSE-2.0 ' 'Unless required by applicable law or agreed to in writing, software 'distributed under the License is distributed on an "AS IS" BASIS, 'WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 'See the License for the specific language governing permissions and 'limitations under the License. ' 'lbasic.bas - Main file for L-BASIC Compiler $if VERSION < 2.0 then 'We use zero-place predicate recursion which is only available in 2.0 $error QB64 V2.0 or greater required $end if 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'This file controls what output is given when debug mode is enabled. Please do not 'make commits with these set to true, to avoid releasing versions that are slower 'than they should be (debugging info is calculated even if debug mode is not enabled 'at runtime). 'You may find it useful to tell git to ignore local modifications to this file: ' git update-index --skip-worktree src/debugging_options.bm 'you can undo this with: ' git update-index --no-skip-worktree src/debugging_options.bm $let DEBUG_TIMINGS = 0 $let DEBUG_PARSE_TRACE = 1 $let DEBUG_TOKEN_STREAM = 0 $let DEBUG_CALL_RESOLUTION = 0 $let DEBUG_PARSE_RESULT = 1 $let DEBUG_MEM_TRACE = 0 $let DEBUG_HEAP = 0 $if DEBUG_TIMINGS then debug_timing_mark# = timer(0.001) $end if dim shared VERSION$ VERSION$ = "0.1.2" '$dynamic 'Setting the graphics window off by default allows running without a 'graphics environment (and prevents an annoying popup). $console $screenhide option _explicitarray _dest _console deflng a-z const FALSE = 0, TRUE = not FALSE on error goto error_handler 'If an error occurs, we use this to know where we came from so we can 'give a more meaningful error message. '0 => Unknown location '1 => Parsing code; parser line number is valid '2 => Immediate runtime (interactive) '3 => Dump code '4 => Trying to open a file '5 => Immediate runtime (non-interactive) dim shared Error_context 'Because we can only throw a numeric error code, this holds a more 'detailed explanation. dim shared Error_message$ 'Set TRUE whenever an error is triggered dim shared Error_occurred 'We distinguish the runtime platform (where L-BASIC is running) from the target 'platform (where the binaries we produce are running). type platform_t id as string posix_paths as long 'TRUE for linux/mac style paths, false for Windows style paths executable_extension as string end type dim shared as platform_t runtime_platform_settings, target_platform_settings if instr(_os$, "[WINDOWS]") then runtime_platform_settings.id = "Windows" runtime_platform_settings.posix_paths = FALSE runtime_platform_settings.executable_extension = ".exe" elseif instr(_os$, "[MACOSX]") then runtime_platform_settings.id = "MacOS" runtime_platform_settings.posix_paths = TRUE runtime_platform_settings.executable_extension = "" elseif instr(_os$, "[LINUX]") then runtime_platform_settings.id = "Linux" runtime_platform_settings.posix_paths = TRUE runtime_platform_settings.executable_extension = "" else fatalerror "Could not detect runtime platform" end if 'For now, the target platform is always the same as the runtime platform target_platform_settings = runtime_platform_settings 'This is an array so we can handle included files. 'The current "reading" file is input_files(input_files_last). type input_file_t handle as long 'Directory containing the file, further includes are relative to this dirname as string 'To be used only for diagnostic messages filename as string end type redim shared input_files(0) as input_file_t dim shared input_files_last 'The logging output is used for debugging output dim shared logging_file_handle 'Various global options read from the command line type options_t mainarg as string preload as string outputfile as string run_mode as integer interactive_mode as integer terminal_mode as integer command_mode as integer compile_mode as integer debug as integer end type dim shared options as options_t 'Allow immediate mode to access COMMAND$() without picking up interpreter options dim shared input_file_command_offset 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'cmdflags.bi - Flags for specifying aspects of a runtime function's behaviour. const STMT_INPUT_NO_NEWLINE = 1 'Semicolon after INPUT const STMT_INPUT_PROMPT = 2 'A prompt is given const STMT_INPUT_NO_QUESTION = 4 'Comma after prompt string const STMT_INPUT_LINEMODE = 8 'Actually a LINE INPUT command const PRINT_NEXT_FIELD = 1 'A comma used after a variable moves to the next 14-char-wide field const PRINT_NEWLINE = 2 'No comma or semicolon at the end of the list 'Note: a semicolon sets no flag const PUTIMAGE_STEP_SRC1 = 1 const PUTIMAGE_STEP_SRC2 = 2 const PUTIMAGE_STEP_DEST1 = 4 const PUTIMAGE_STEP_DEST2 = 8 const PUTIMAGE_SMOOTH = 16 const OPEN_INPUT = 1 const OPEN_OUTPUT = 2 const OPEN_BINARY = 4 const OPEN_RANDOM = 8 'Concurrency options, not currently used const OPEN_READ = 16 const OPEN_WRITE = 32 const OPEN_SHARED = 64 const OPEN_LOCK = 128 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'type.bi - Declarations for type management routines 'type_signatures() is a linked list. 'A function token points to a single type_signature_t, and that element may point to 'alternative signatures for that function. This allows us to support declaring a 'function multiple times with different signatures by chaining each declaration's 'signature together. 'type_signature_t.sig is an mkl$-encoded string. Its format is mkl$(return type) + 'mkl$(argument 1 type) + mkl$(argument 1 flags) + mkl$(argument 2 type) + 'mkl$(argument 2 flags) + ... 'For each flag, one or more TYPE_* flags as defined below are set. 'Don't access things directly, use the type_sig_* functions. type type_signature_t sig as string succ as long 'Can't call this "next" :( end type redim shared type_signatures(10) as type_signature_t dim shared type_last_signature as long 'Note: constants for actual data types (TYPE_LONG etc.) are defined in tokens.list 'for greater ease of handling UDTs. 'Flags for type signature flags const TYPE_OPTIONAL = 1 const TYPE_BYREF = 2 const TYPE_BYVAL = 4 'This argument can have a leading # to indicate a file handle const TYPE_FILEHANDLE = 8 'This argument is a literal token and the type refers to that token id const TYPE_TOKEN = 16 'This argument is only a syntax element and should not have an ast node generated for it const TYPE_SYNTAX_ONLY = 32 'This argument needs to be matched by textual name. This allows parameters 'that have meaning only in a specific context, like LINE's B/BF. The argument 'type' 'is the index of a constant that contains a | separated list of allowable values. const TYPE_CONTEXTUAL = 64 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'symtab.bi - Declarations for symbol table type symtab_entry_t identifier as string typ as long 'the vn are generic parameters whose meaning depends on typ. v1 as long v2 as long v3 as long v4 as long end type 'A generic entry. No vn parameters are used. const SYM_GENERIC = 1 'A function with infix notation. 'v1 -> reference to the type signature 'v2 -> binding power (controls precedence) 'v3 -> associativity (1/0 = right/left) const SYM_INFIX = 2 'A function with prefix notation (and parentheses are not required) 'v1 -> reference to the type signature 'v2 -> binding power (controls precedence) const SYM_PREFIX = 3 'A variable. 'v1 -> the data type 'v2 -> stack offset in the scope. Simple variables and references each take up 1 slot, ' arrays and UDTs take up multiple. 'v3 -> various SYM_VARIABLE_* flags const SYM_VARIABLE = 4 'A function (subs too!) 'v1 -> reference to the type signature 'v2 -> One of SYM_FUNCTION_*, see below 'v3 -> If SYM_FUNCTION_USER, the AST_PROCEDURE holding the executable code 'v4 -> IF SYM_FUNCTION_USER, the stack frame size required to hold locals, including arguments const SYM_FUNCTION = 5 'A line number or label. Labels have the : removed. 'v1 -> AST node that is labelled. 'v2 -> Label has been located (if false, label has only been referenced) const SYM_LABEL = 6 'Both internal types and UDTs 'v1 -> Fixed size of data type 'v2 -> One of SYM_TYPE_*, see below 'v3 -> If SYM_TYPE_ARRAY, type of the array element 'v4 -> If SYM_TYPE_ARRAY, number of dimensions const SYM_TYPE = 7 'An element of a udt, stored with the name "udt_name.element_name" 'v1 -> the data type 'v2 -> position of element in udt (first is 0, then incrementing by the fixed size of previous values) const SYM_UDT_ELEMENT = 8 'A metacommand, stored with its characteristic leading $ in the name const SYM_META = 9 'Further categorisation of SYM_TYPE 'e.g. INTEGER, STRING const SYM_TYPE_INTERNAL = 0 'Stored as the UDT name const SYM_TYPE_UDT = 1 'Stored as the element type followed by parentheses and the number of dimensions, e.g. INTEGER(2) const SYM_TYPE_ARRAY = 2 'Settings for SYM_VARIABLE 'This variable is a constant and cannot be reassigned const SYM_VARIABLE_CONST = 1 'This variable must be dereferenced before access (to support pass-by-reference) const SYM_VARIABLE_DEREF = 2 'This variable is stored in the main program's stack frame, not the frame of any scoping function (SHARED or STATIC) const SYM_VARIABLE_MAINFRAME = 4 'Further categorisation of SYM_FUNCTION 'Functions that are handled directly based on their name const SYM_FUNCTION_INTRINSIC = 1 'SUBs and FUNCTIONs defined by the processed source code const SYM_FUNCTION_USER = 2 dim shared symtab(1000) as symtab_entry_t dim shared symtab_last_entry dim shared symtab_map(1750) 'The symtab optionally supports transactions; calling symtab_rollback will 'remove all items added since the last call to symtab_commit. 'WARNING: transaction rollbacks only undo adding entries. Changes to entries 'are always immediately permanent. dim shared symtab_last_commit_id 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'ast.bi - Declarations for Abstract Syntax Tree 'This is a tree structure in a convoluted way 'The node definition type ast_node_t parent as long typ as long ref as long ref2 as long linenum as long 'File line this node started to appear end type 'The nodes themselves dim shared ast_nodes(0) as ast_node_t 'The children of a given node as a mkl$-encoded string dim shared ast_children(0) as string 'The id of the last node registered dim shared ast_last_node as long 'Every number and string appearing in the program gets an entry here dim shared ast_constants(0) as string dim shared ast_constant_types(0) as long dim shared ast_last_constant as long 'The ast optionally supports transactions; calling ast_rollback will 'remove all items added since the last call to ast_commit. 'WARNING: transaction rollbacks only undo adding nodes. Node changes 'are always immediately permanent. dim shared ast_last_commit_id dim shared ast_last_constant_commit_id const AST_FALSE = 1 const AST_TRUE = 2 const AST_ONE = 3 'This is an AST_BLOCK that is the main program. dim shared AST_ENTRYPOINT 'The types of node. 'Note: an "expression"/"expr" is a CALL, CONSTANT, CAST, SELECT_VALUE, any of the lvalue 'types or NONE (if allowed). 'Every SUB and FUNCTION is rooted in an AST_PROCEDURE. 'First child is AST_BLOCK. Remaining children are AST_VAR for formal parameters, left to 'right. ref is the symtab entry for the function name. 'Note: the main program is not an AST_PROCEDURE, it is just an AST_BLOCK. See ast_init. const AST_PROCEDURE = 1 'group of statements const AST_BLOCK = 2 'assign lvalue expr => lvalue = expr const AST_ASSIGN = 3 'if expr1 block1 [expr2 block2 ...] [block-n] => IF expr1 THEN block1 ELSEIF expr2 THEN 'block2 ... ELSE block-n const AST_IF = 4 'while expr block => WHILE expr: block: WEND 'Can't be an AST_DO_PRE because of EXIT const AST_WHILE = 5 'do expr block => DO WHILE expr: block: LOOP const AST_DO_PRE = 6 'do expr block => DO: block: LOOP WHILE expr const AST_DO_POST = 7 'for lvalue expr1 expr2 expr3 block => FOR lvalue = expr1 TO expr2 STEP expr3 const AST_FOR = 8 'select expr [AST_SELECT_LIST]* AST_SELECT_ELSE? => SELECT CASE expr CASE AST_SELECT_LIST... AST_SELECT_ELSE const AST_SELECT = 9 'Children are AST_SELECT_IS or AST_SELECT_RANGE. Last child is block. const AST_SELECT_LIST = 10 'ref is comparison function, ref2 is type sig. First child is AST_SELECT_VALUE, second 'child is expr to compare against (second argument to function). Note that this is 'the same format as AST_CALL. const AST_SELECT_IS = 11 'ref is comparison function, ref2 is type sig. Left & right bounding expr are first and 'second children respectively. const AST_SELECT_RANGE = 12 'First child is block const AST_SELECT_ELSE = 13 'When evaluated, returns the base expression value of the inner-most SELECT CASE. ref is 'the type of the expression. const AST_SELECT_VALUE = 14 'call param* => A function call to ref with type signature ref2 and parameters as children const AST_CALL = 15 'ref is a reference to an entry in the constants table const AST_CONSTANT = 16 'Casts are first-class AST elements instead of just CALLs to a cast function. ref is a 'type, child is a CALL, CONSTANT or VAR. const AST_CAST = 17 'Used to pass extra data to some functions that have behaviour set by syntax (e.g. INPUT, LINE). 'ref is one of AST_FLAG_* defined below. ref2 is the corresponding value. const AST_FLAGS = 18 'If the goto is resolved, ref is the node to jump to. If unresolved, the label symtab. A 'fully-parsed program will have no unresolved labels. const AST_GOTO = 19 'Used for empty optional arguments to functions const AST_NONE = 20 'The EXIT statement. ref is the loop statement or function we're exiting. const AST_EXIT = 21 'These nodes may appear where-ever an lvalue is required 'ref is reference to symtab const AST_VAR = 22 'Access to a UDT element. First child is the lvalue we're accessing an element of, ref is 'the UDT element symbol. const AST_UDT_ACCESS = 23 'Access to an array element. First child is the lvalue to be indexed. Second child is 'expression for the index in leftmost dimension, then so on for other dimensions. const AST_ARRAY_ACCESS = 24 'Emitted by DIM statements to initialise an array. First child is lvalue to be 'initialised, then each pair of children after are expr for the lower and upper 'bound of each dimension. The array is zeroed out. const AST_ARRAY_CREATE = 25 'Like above, but preserve the contents of the array if any. const AST_ARRAY_RESIZE = 26 'Free an array's heap allocation, effectively a destructor. First child is an lvalue. const AST_ARRAY_DELETE = 27 'Like _CREATE, with the exception that the array is not touched if memory is already 'allocated. Added to support STATIC arrays. const AST_ARRAY_ESTABLISH = 28 'Sets the return value of the current function. first child is expr to return, ref 'is the return type. const AST_SET_RETURN = 29 'Flag is a value defined in cmdflags.bi. const AST_FLAG_MANUAL = 1 'Flag is a contextual argument and value is the index into the list of alternates. const AST_FLAG_CONTEXTUAL = 2 'Flag is a token. const AST_FLAG_TOKEN = 3 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'parser.bi - Declarations for parser module 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'tokeng.bi - Delcarations for tokeniser engine CONST TS_SKIP = 1 CONST TS_ID = 2 CONST TS_NEWLINE = 3 CONST TS_LINENUM = 4 CONST TS_METACMD = 5 CONST TS_METAPARAM = 6 CONST TS_STRINGLIT = 7 CONST TS_SINGLE_SFX = 8 CONST TS_STRING_SFX = 9 CONST TS_POWER = 10 CONST TS_STAR = 11 CONST TS_OPAREN = 12 CONST TS_CPAREN = 13 CONST TS_OBRACKET = 14 CONST TS_CBRACKET = 15 CONST TS_OBRACE = 16 CONST TS_CBRACE = 17 CONST TS_DASH = 18 CONST TS_PLUS = 19 CONST TS_EQUALS = 20 CONST TS_BACKSLASH = 21 CONST TS_COLON = 22 CONST TS_SEMICOLON = 23 CONST TS_COMMA = 24 CONST TS_SLASH = 25 CONST TS_NUMINT = 26 CONST TS_NUMDEC = 27 CONST TS_NUMEXP = 28 CONST TS_INTEGER_SFX = 29 CONST TS_OFFSET_SFX = 30 CONST TS_DOUBLE_SFX = 31 CONST TS_QUAD_SFX = 32 CONST TS_LONG_SFX = 33 CONST TS_INTEGER64_SFX = 34 CONST TS_NUMBASE = 35 CONST TS_CMP_LT = 36 CONST TS_CMP_LTEQ = 37 CONST TS_CMP_NEQ = 38 CONST TS_CMP_GT = 39 CONST TS_CMP_GTEQ = 40 CONST TS_DOT = 41 CONST TS_MAX = 41 CONST TS_ST_Begin = 1 CONST TS_ST_Id = 2 CONST TS_ST_Linenum = 3 CONST TS_ST_Comment = 4 CONST TS_ST_Metacmd = 5 CONST TS_ST_General = 6 CONST TS_ST_Metagap = 7 CONST TS_ST_Metaparam = 8 CONST TS_ST_String = 9 CONST TS_ST_Number = 10 CONST TS_ST_HashPfx = 11 CONST TS_ST_PercentPfx = 12 CONST TS_ST_AmpersandPfx = 13 CONST TS_ST_LtPfx = 14 CONST TS_ST_GtPfx = 15 CONST TS_ST_Dot = 16 CONST TS_ST_NumDec = 17 CONST TS_ST_NumExpSgn = 18 CONST TS_ST_NumExp = 19 CONST TS_ST_NumBase = 20 DIM SHARED t_states~%(127, 20) DIM SHARED t_statenames$(20) CONST TOK_UNKNOWN = 1 CONST TOK_IEOF = 2 CONST TOK_EOI = 3 CONST TOK_NEWLINE = 4 CONST TOK_COMMA = 5 CONST TOK_SEMICOLON = 6 CONST TOK_DOT = 7 CONST TOK_REM = 8 CONST TOK_LINENUM = 9 CONST META_LIST = 10 CONST META_DEBUG = 11 CONST META_INCLUDE = 12 CONST META_OPTION = 13 CONST META_UNKNOWN = 14 CONST TOK_METAPARAM =-1 CONST TOK_INTEGER_SFX = 15 CONST TOK_LONG_SFX = 16 CONST TOK_INTEGER64_SFX = 17 CONST TOK_SINGLE_SFX = 18 CONST TOK_DOUBLE_SFX = 19 CONST TOK_QUAD_SFX = 20 CONST TOK_STRING_SFX = 21 CONST TYPE_NONE = 22 CONST TYPE_LIST = 23 CONST TYPE_FLAGS = 24 CONST TYPE_ANY = 25 CONST TYPE_ANY_ARRAY = 26 CONST TYPE_INTEGER = 27 CONST TYPE_LONG = 28 CONST TYPE_INTEGER64 = 29 CONST TYPE_SINGLE = 30 CONST TYPE_DOUBLE = 31 CONST TYPE_QUAD = 32 CONST TYPE_STRING = 33 CONST TYPE_CONTEXTUAL_ARGUMENT = 34 CONST TOK_OPAREN = 35 CONST TOK_CPAREN = 36 CONST TOK_OBRACKET = 37 CONST TOK_CBRACKET = 38 CONST TOK_OBRACE = 39 CONST TOK_CBRACE = 40 CONST TOK_NUMINT =-2 CONST TOK_NUMDEC =-3 CONST TOK_NUMEXP =-4 CONST TOK_NUMBASE =-5 CONST TOK_STRINGLIT =-6 CONST TOK_CONTEXTUAL_ARGUMENT =-7 CONST TOK_IMP = 41 CONST TOK_EQV = 42 CONST TOK_XOR = 43 CONST TOK_OR = 44 CONST TOK_AND = 45 CONST TOK_NOT= 46 CONST TOK_EQUALS = 47 CONST TOK_CMP_NEQ = 48 CONST TOK_CMP_LT = 49 CONST TOK_CMP_GT = 50 CONST TOK_CMP_LTEQ = 51 CONST TOK_CMP_GTEQ = 52 CONST TOK_PLUS = 53 CONST TOK_DASH = 54 CONST TOK_MOD = 55 CONST TOK_BACKSLASH = 56 CONST TOK_STAR = 57 CONST TOK_SLASH = 58 CONST TOK_NEGATIVE= 59 CONST TOK_POWER = 60 CONST TOK_AS = 61 CONST TOK_CONST = 62 CONST TOK_GOTO = 63 CONST TOK_EXIT = 64 CONST TOK_IF = 65 CONST TOK_THEN = 66 CONST TOK_ELSE = 67 CONST TOK_ELSEIF = 68 CONST TOK_DO = 69 CONST TOK_LOOP = 70 CONST TOK_UNTIL = 71 CONST TOK_WHILE = 72 CONST TOK_WEND = 73 CONST TOK_FOR = 74 CONST TOK_TO = 75 CONST TOK_STEP = 76 CONST TOK_NEXT = 77 CONST TOK_SELECT = 78 CONST TOK_CASE = 79 CONST TOK_IS = 80 CONST TOK_TYPE = 81 CONST TOK_SUB = 82 CONST TOK_FUNCTION = 83 CONST TOK_DECLARE = 84 CONST TOK_REDIM = 85 CONST TOK_SHARED = 86 CONST TOK__PRESERVE = 87 CONST TOK_STATIC = 88 CONST TOK__EXPLICIT = 89 CONST TOK__EXPLICITARRAY = 90 CONST TOK_BYREF = 91 CONST TOK_BYVAL = 92 CONST TOK_CALL = 93 CONST TOK_ABS = 94 CONST TOK_ASC = 95 CONST TOK__ATAN2 = 96 CONST TOK_ATN = 97 CONST TOK__AUTODISPLAY = 98 CONST TOK_BEEP = 99 CONST TOK__BLUE32 = 100 CONST TOK_CDBL = 101 CONST TOK_CHDIR = 102 CONST TOK_CHR = 103 CONST TOK_CINT = 104 CONST TOK_CIRCLE = 105 CONST TOK_CLNG = 106 CONST TOK_CLOSE = 107 CONST TOK_CLS = 108 CONST TOK_COLOR = 109 CONST TOK_COMMAND = 110 CONST TOK__COMMANDCOUNT = 111 CONST TOK_COS = 112 CONST TOK_CSNG = 113 CONST TOK_CSRLIN = 114 CONST TOK_CVD = 115 CONST TOK_CVDMBF = 116 CONST TOK_CVI = 117 CONST TOK_CVL = 118 CONST TOK_CVS = 119 CONST TOK_CVSMBF = 120 CONST TOK_DATE = 121 CONST TOK__DEFINE = 122 CONST TOK_DEFINT = 123 CONST TOK_DEFLNG = 124 CONST TOK_DEFSNG = 125 CONST TOK_DEFDBL = 126 CONST TOK_DEFSTR = 127 CONST TOK__DEFLATE = 128 CONST TOK__DELAY = 129 CONST TOK__DEST = 130 CONST TOK_DIM = 131 CONST TOK__DISPLAY = 132 CONST TOK_DRAW = 133 CONST TOK_END = 134 CONST TOK_ENVIRON = 135 CONST TOK_EOF = 136 CONST TOK_ERASE = 137 CONST TOK_EXP = 138 CONST TOK_FILES = 139 CONST TOK_FIX = 140 CONST TOK__FONTHEIGHT = 141 CONST TOK__FONTWIDTH = 142 CONST TOK_FREEFILE = 143 CONST TOK_GET = 144 CONST TOK__GREEN32 = 145 CONST TOK__HEIGHT = 146 CONST TOK_HEX = 147 CONST TOK__INFLATE = 148 CONST TOK_INKEY = 149 CONST TOK_INPUT = 150 CONST TOK_INSTR = 151 CONST TOK_INT = 152 CONST TOK__KEYCLEAR = 153 CONST TOK__KEYDOWN = 154 CONST TOK__KEYHIT = 155 CONST TOK_KILL = 156 CONST TOK_LBOUND = 157 CONST TOK_LCASE = 158 CONST TOK_LEFT = 159 CONST TOK_LEN = 160 CONST TOK__LIMIT = 161 CONST TOK_LINE = 162 CONST TOK_LINEINPUT = 163 CONST TOK__LOADIMAGE = 164 CONST TOK_LOCATE = 165 CONST TOK_LOF = 166 CONST TOK_LOG = 167 CONST TOK_LTRIM = 168 CONST TOK_MID = 169 CONST TOK__MOUSEBUTTON = 170 CONST TOK__MOUSEINPUT = 171 CONST TOK__MOUSEMOVEMENTX = 172 CONST TOK__MOUSEMOVEMENTY = 173 CONST TOK__MOUSEWHEEL = 174 CONST TOK__MOUSEX = 175 CONST TOK__MOUSEY = 176 CONST TOK__NEWIMAGE = 177 CONST TOK_OPEN = 178 CONST TOK_OPTION = 179 CONST TOK_PAINT = 180 CONST TOK__PI = 181 CONST TOK_PLAY = 182 CONST TOK_POINT = 183 CONST TOK_PRINT = 184 CONST TOK__PRINTSTRING = 185 CONST TOK__PRINTWIDTH = 186 CONST TOK_PSET = 187 CONST TOK_PUT = 188 CONST TOK__PUTIMAGE = 189 CONST TOK_RANDOMIZE = 190 CONST TOK__RED32 = 191 CONST TOK__RGB = 192 CONST TOK__RGB32 = 193 CONST TOK_RIGHT = 194 CONST TOK_RMDIR = 195 CONST TOK_RND = 196 CONST TOK_RTRIM = 197 CONST TOK_SCREEN = 198 CONST TOK_SGN = 199 CONST TOK_SIN = 200 CONST TOK_SLEEP = 201 CONST TOK__SMOOTH = 202 CONST TOK_SOUND = 203 CONST TOK__SOURCE = 204 CONST TOK_SPACE = 205 CONST TOK_SQR = 206 CONST TOK_STR = 207 CONST TOK__STRCMP = 208 CONST TOK__STRICMP = 209 CONST TOK_SWAP = 210 CONST TOK_SYSTEM = 211 CONST TOK_TAN = 212 CONST TOK_TIME = 213 CONST TOK_TIMER = 214 CONST TOK__TITLE = 215 CONST TOK__TRIM = 216 CONST TOK_UBOUND = 217 CONST TOK_UCASE = 218 CONST TOK_USING = 219 CONST TOK_VAL = 220 CONST TOK__WIDTH = 221 type tokeniser_state_t index as long curstate as long has_data as long linestart as long recovery_mode as long raw_line_in as string end type dim shared tokeng_state as tokeniser_state_t dim shared tok_content$ dim shared tok_token as long dim shared tok_next_content$ dim shared tok_next_token as long 'Used to map TS_ to TOK_ dim shared tok_direct(1 to TS_MAX) 'How big does the stack frame for the current scope need to be? 'This applies to the current scope - the parser for subs/functions will save and 'restore this value so it is preserved for the main program. dim shared ps_scope_frame_size as long 'When in a sub/function, we make the main program's frame size available too so that 'STATIC variables can be made part of the main program's stack allocation. This 'value is only valid when in a sub/function. dim shared ps_main_frame_size as long 'actual as opposed to any explicit old-timey line numbers/labels in the program dim shared ps_actual_linenum as long dim shared ps_default_type as long 'Set TRUE if processing a preload file, meaning internal functions 'can be overridden with user-supplied ones. dim shared ps_is_preload as long 'mkl$ list of symtab labels that are not attached to an AST node. 'This occurs if you have labels on empty or non-executable lines. dim shared ps_unattached_labels$ 'mkl$ list of nodes that ref a label location but were unresolved 'because the label hadn't been positioned yet. dim shared ps_unresolved_jumps$ 'mkl$ list of nodes that are DO, WHILE, FOR, SUB/FUNCTION for the purposes of 'parsing EXIT statements. dim shared ps_nested_structures$ 'Name of the containing function, used as part of a prefix for local objects. dim shared ps_scope_identifier$ 'Sometimes we need to run cleanup code just before exiting a scope. This is 'a list of nodes to be added to the end of a scope's block. dim shared ps_queued_nodes$ 'Set to FALSE if OPTION _EXPLICIT is in effect dim shared ps_allow_implicit_vars type imm_value_t n as _float s as string end type 'Stack holds objects with fixed memory size. Note a single element can 'hold a variable length string, and all UDTs are of fixed size (because 'any variable-size components like arrays are in fact pointers). 'Begins at 1 so we can catch null pointer errors, and so all pointers have 'SGN = 1. dim shared imm_stack(1) as imm_value_t dim shared imm_stack_last 'Used as an offset for stack value access, allowing support for 'stack frames. dim shared imm_stack_base 'Heap holds dynamically allocated objects i.e. arrays. See heap.bm 'for the allocation strategy. Note that pointers to heap locations are 'always stored as negative values, to distinguish them from stack addresses '(but are made positive just before heap access, so the array below grows 'in the positive direction). We'd like to grow the array negatively too, but 'that would force a copy on each reallocation which isn't desired. dim shared imm_heap(1) as imm_value_t dim shared imm_heap_next_free const IMM_HEAP_HEADER_SIZE = 2 'some extra values worth tracking dim shared imm_heap_current_blocks dim shared imm_heap_max_blocks dim shared imm_heap_current_bytes dim shared imm_heap_max_bytes 'Instead of executing the next statement, execution should begin at 'this node if it is > 0 (used to support GOTO) dim shared imm_jump_path$ 'If > 0, an EXIT command is in effect and imm_exit_node is the node to exit dim shared imm_exit_node 'Allow for input code to use file handles without clashing with internally 'opened files dim shared imm_filehandle_offset 'When evaluating a SELECT CASE, this holds the base value which is returned 'when AST_SELECT_VALUE is evaluated dim shared imm_select_value as imm_value_t 'Maintain a eval stack that can be printed for debugger purposes. Each element 'is an ast node dim shared imm_eval_stack(0) dim shared imm_eval_stack_last 'If FALSE, overflows generate an error. Otherwise, they are siliently ignored. dim shared imm_allow_overflow parse_cmd_line_args if not options.terminal_mode then _screenshow _dest 0 end if 'Send out debugging info to the screen logging_file_handle = freefile open_file "SCRN:", logging_file_handle, TRUE 'Setup AST, constants and parser settings ast_init ps_init $if DEBUG_TIMINGS then debuginfo "Boot time:" + str$(timer(0.001) - debug_timing_mark#) $end if 'Preload files can override built-in commands; handle that now if options.preload <> "" then preload_file 'Dispatch based on desired mode of operation Error_context = 1 if options.interactive_mode then 'User will type in commands interactive_mode FALSE elseif options.command_mode then 'Run some code given on the command line command_mode elseif options.compile_mode then 'Produce a binary output. Currently this just dumps the AST and symbol table. compile_mode else run_mode end if if options.terminal_mode then system else end interactive_recovery: interactive_mode TRUE error_handler: Error_occurred = TRUE old_dest = _dest if not options.terminal_mode then _dest 0 else _dest _console end if select case Error_context case 1 'Parsing code print "Parser: "; if err <> 101 then goto internal_error if options.interactive_mode and options.preload = "" then print Error_message$ Error_message$ = "" _dest old_dest resume interactive_recovery else if options.preload <> "" then print "In preload file: "; print "Line" + str$(ps_actual_linenum) + ": " + Error_message$ end if case 2, 5 'Immediate mode 'We have no good way of distinguishing between user program errors and internal errors 'Of course, the internal code is perfect so it *must* be a user program error print "Runtime error: "; if err = 101 then print Error_message$; else print _errormessage$(err); print " ("; _trim$(str$(err)); "/"; _inclerrorfile$; ":"; _trim$(str$(_inclerrorline)); ")" imm_show_eval_stack if Error_context = 2 then resume interactive_recovery case 3 'Dump mode print "Dump: "; if err <> 101 then goto internal_error print Error_message$ case 4 'File access check _dest old_dest resume next case else internal_error: if _inclerrorline then print "Internal error" + str$(err) + " on line" + str$(_inclerrorline) + " of " + _inclerrorfile$ + " (called from line" + str$(_errorline) + ")" else print "Internal error" + str$(err) + " on line" + str$(_errorline) end if print Error_message$ end select if options.terminal_mode then system 1 else end 1 'This one's solely for basic user error like input file not found, bad command line etc. sub fatalerror(msg$) print "Error: " + msg$ if options.terminal_mode then system 1 else end 1 end sub sub debuginfo(msg$) if options.debug then old_dest = _dest if not options.terminal_mode then _dest 0 else _dest _console end if print msg$ _dest old_dest end if end sub 'This function and the next are called from tokeng. 'They provide a uniform way of loading the next line. function general_next_line$ if options.preload <> "" then line input #input_files(input_files_last).handle, s$ elseif options.interactive_mode then old_dest = _dest if not options.terminal_mode then _dest 0 else _dest _console end if print "> "; line input s$ _dest old_dest elseif options.command_mode then s$ = options.mainarg options.mainarg = "" else line input #input_files(input_files_last).handle, s$ end if general_next_line$ = s$ end function function general_eof if options.preload <> "" then result = eof(input_files(input_files_last).handle) elseif options.interactive_mode then 'Hopefully one day we'll be able to handle ^D/^Z here result = FALSE elseif options.command_mode then result = options.mainarg = "" else result = eof(input_files(input_files_last).handle) 'An EOF in an include file just means close that and return to the 'outer file if result and input_files_last > 0 then close #input_files(input_files_last).handle input_files_last = input_files_last - 1 'Call recursively in case the outer file has also ended result = general_eof end if end if general_eof = result end function sub preload_file input_files(input_files_last).handle = freefile open_file options.preload, input_files(input_files_last).handle, FALSE tok_init Error_context = 1 ps_preload_file close #input_files(input_files_last).handle options.preload = "" end sub 'Open a file and trigger a fatal error if we couldn't sub open_file(filename$, handle, is_output) old_ctx = Error_context Error_context = 4 Error_occurred = FALSE if is_output then open filename$ for output as #handle else open filename$ for input as #handle end if if Error_occurred then fatalerror "Could not open file " + filename$ Error_context = old_ctx end sub sub interactive_mode(recovery) if recovery then ps_nested_structures$ = "" ps_scope_identifier$ = "" tok_recover TOK_NEWLINE symtab_commit ast_rollback ast_clear_entrypoint else imm_init AST_ENTRYPOINT = ast_add_node(AST_BLOCK) ast_commit tok_init ps_init end if do Error_context = 1 node = ps_stmt select case node case -2 'A SUB or FUNCTION was defined, we want to keep that. symtab_commit ast_commit case -1 '-1 is an end block, this should never happen ps_error "Block end at top-level" case 0 'No ast nodes were generated (DIM etc.), but save any 'symbols created. symtab_commit case else Error_context = 0 ast_attach AST_ENTRYPOINT, node $if DEBUG_PARSE_RESULT then if options.debug then Error_context = 3 ast_dump_pretty AST_ENTRYPOINT, 0 Error_context = 0 print #1, end if $end if 'TODO remove this next line by adding the logic to imm_run or similar imm_reinit ps_scope_frame_size Error_context = 2 imm_run AST_ENTRYPOINT 'Keep any symbols that were defined symtab_commit 'But don't keep any nodes generated ast_rollback 'And clear the main program ast_clear_entrypoint end select Error_context = 1 ps_consume TOK_NEWLINE loop end sub sub command_mode tok_init root = ps_block Error_context = 0 $if DEBUG_PARSE_RESULT then if options.debug then Error_context = 3 ast_dump_pretty root, 0 Error_context = 0 print #1, end if $end if imm_init Error_context = 2 imm_run root Error_context = 0 end sub sub compile_mode if options.mainarg = "" then fatalerror "No input file" 'Output file defaults to input file with .bas changed to .exe (or nothing on Unix) if options.outputfile = "" then options.outputfile = remove_ext$(options.mainarg) + target_platform_settings.executable_extension input_files(input_files_last).filename = options.mainarg options.mainarg = locate_path$(options.mainarg, _startdir$) input_files(input_files_last).dirname = dirname$(options.mainarg) input_files(input_files_last).handle = freefile open_file options.mainarg, input_files(input_files_last).handle, FALSE tok_init ps_prepass seek input_files(input_files_last).handle, 1 tok_reinit ps_init ast_rollback AST_ENTRYPOINT = ps_block ps_finish_labels AST_ENTRYPOINT Error_context = 0 close #input_files(input_files_last).handle close #logging_file_handle logging_file_handle = freefile open_file options.outputfile, logging_file_handle, TRUE Error_context = 3 dump_program Error_context = 0 close #1 end sub sub run_mode if options.mainarg = "" then fatalerror "No input file" input_files(input_files_last).filename = options.mainarg options.mainarg = locate_path$(options.mainarg, _startdir$) input_files(input_files_last).dirname = dirname$(options.mainarg) input_files(input_files_last).handle = freefile open_file options.mainarg, input_files(input_files_last).handle, FALSE tok_init $if DEBUG_TIMINGS then debug_timing_mark# = timer(0.001) $end if ps_prepass seek input_files(input_files_last).handle, 1 tok_reinit ps_init ast_rollback AST_ENTRYPOINT = ps_block ps_finish_labels AST_ENTRYPOINT $if DEBUG_TIMINGS then debuginfo "Parse time:" + str$(timer(0.001) - debug_timing_mark#) $end if Error_context = 0 close #input_files(input_files_last).handle imm_init Error_context = 5 $if DEBUG_TIMINGS then debug_timing_mark# = timer(0.001) $end if imm_run AST_ENTRYPOINT $if DEBUG_TIMINGS then debuginfo "Run time:" + str$(timer(0.001) - debug_timing_mark#) $end if Error_context = 0 $if DEBUG_HEAP then if options.debug then imm_heap_stats $end if end sub 'Strip the .bas extension if present function remove_ext$(fullname$) dot = _instrrev(fullname$, ".") if mid$(fullname$, dot + 1) = "bas" then remove_ext$ = left$(fullname$, dot - 1) else remove_ext$ = fullname$ end if end function 'Get the path to a file relative to the prefix$ path. If prefix$ is 'absolute, then the returned path is absolute too. function locate_path$(file$, prefix$) if runtime_platform_settings.posix_paths then if left$(file$, 1) = "/" then 'path is already absolute locate_path$ = file$ else locate_path$ = prefix$ + "/" + file$ end if else 'This doesn't support UNC paths or DOS device paths if mid$(file$, 2, 1) = ":" or left$(file$, 1) = "\" then 'already absolute, or relative with explicit drive letter 'that we can't meaningfully modify locate_path$ = file$ else if right$(prefix$, 1) = "\" then sep$ = "" else sep$ = "\" '"fix syntax hilight locate_path$ = prefix$ + sep$ + file$ end if end if end function 'Get the directory component of a path function dirname$(path$) if runtime_platform_settings.posix_paths then slash$ = "/" else slash$ = "\" '" end if s = _instrrev(path$, slash$) if s = 0 then dirname$ = "." else dirname$ = left$(path$, s - 1) end if end function 'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences 'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$(). ' 'result$() must have been REDIMmed previously. sub split(in$, delimiter$, result$()) redim result$(-1) start = 1 do while mid$(in$, start, len(delimiter$)) = delimiter$ start = start + len(delimiter$) if start > len(in$) then exit sub wend finish = instr(start, in$, delimiter$) if finish = 0 then finish = len(in$) + 1 redim _preserve result$(0 to ubound(result$) + 1) result$(ubound(result$)) = mid$(in$, start, finish - start) start = finish + len(delimiter$) loop while start <= len(in$) end sub sub show_version print "The L-BASIC compiler version " + VERSION$ end sub sub show_help print "The L-BASIC compiler" print "Usage: " + command$(0) + " [OPTIONS] [FILE]" print "Execute FILE if given, otherwise launch an interactive session." print ' '80 columns print "Options:" print " -t, --terminal Run in terminal mode (no graphical window)" print " -c, --compile Compile FILE instead of executing" print " -o OUTPUT, --output OUTPUT Place compilation output into OUTPUT" print " -e CMD, --execute CMD Execute the statement CMD then exit" print " --preload FILE Load FILE before parsing main program" print " -d, --debug For internal debugging (if available)" print " -h, --help Print this help message" print " --version Print version information" end sub 'The error handling here fakes terminal_mode on the assumption that if you're 'using command line arguments you don't want a graphical window popping up. sub parse_cmd_line_args() for i = 1 TO _commandcount arg$ = command$(i) select case arg$ case "--version" show_version system case "-h", "--help" show_help system case "-o", "--output" if i = _commandcount then options.terminal_mode = TRUE fatalerror arg$ + " requires argument" end if options.outputfile = locate_path$(command$(i + 1), _startdir$) i = i + 1 case "-d", "--debug" options.debug = TRUE case "-c", "--compile" options.compile_mode = TRUE case "-t", "--terminal" options.terminal_mode = TRUE case "-e", "--execute" options.command_mode = TRUE case "--preload" if i = _commandcount then options.terminal_mode = TRUE fatalerror arg$ + " requires argument" end if options.preload = locate_path$(command$(i + 1), _startdir$) i = i + 1 case else if left$(arg$, 1) = "-" then options.terminal_mode = TRUE fatalerror "Unknown option " + arg$ end if if options.mainarg = "" then options.mainarg = arg$ input_file_command_offset = i exit for end if end select next i if options.mainarg = "" then options.interactive_mode = TRUE if not options.interactive_mode and not options.compile_mode and _ not options.command_mode then options.run_mode = TRUE end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'type.bm - Routines for type management 'The fixed size of a type is the amount of memory/elements needed to store 'a variable of that type, but only counting the fixed-sized info (pointer and size) 'for arrays. function type_fixed_size(typ) type_fixed_size = symtab(typ).v1 end function function type_is_number(typ) select case typ case TYPE_INTEGER, TYPE_LONG, TYPE_INTEGER64, TYPE_SINGLE, TYPE_DOUBLE, TYPE_QUAD type_is_number = TRUE end select end function function type_is_array(typ) type_is_array = symtab(typ).v2 = SYM_TYPE_ARRAY end function function type_of_expr(root) select case ast_nodes(root).typ case AST_CONSTANT type_of_expr = type_of_constant(root) case AST_CALL type_of_expr = type_of_call(root) case AST_VAR, AST_UDT_ACCESS, AST_ARRAY_ACCESS type_of_expr = type_of_lvalue(root) case AST_CAST type_of_expr = type_of_cast(root) case AST_FLAGS type_of_expr = TYPE_FLAGS case AST_SELECT_VALUE type_of_expr = type_of_select_value(root) case else type_of_expr = TYPE_NONE end select end function function type_of_lvalue(node) select case ast_nodes(node).typ case AST_VAR type_of_lvalue = type_of_var(node) case AST_UDT_ACCESS type_of_lvalue = type_of_udt_access(node) case AST_ARRAY_ACCESS type_of_lvalue = type_of_array_access(node) end select end function function type_of_constant(node) type_of_constant = ast_constant_types(ast_nodes(node).ref) end function function type_of_call(node) type_of_call = type_sig_return(ast_nodes(node).ref2) end function function type_of_var(node) type_of_var = symtab(ast_nodes(node).ref).v1 end function function type_of_cast(node) type_of_cast = ast_nodes(node).ref end function function type_of_udt_access(node) type_of_udt_access = symtab(ast_nodes(node).ref).v1 end function function type_of_array_access(node) array = ast_get_child(node, 1) array_type = type_of_lvalue(array) type_of_array_access = symtab(array_type).v3 end function function type_is_lvalue(node) t = ast_nodes(node).typ type_is_lvalue = t = AST_VAR or t = AST_UDT_ACCESS or t = AST_ARRAY_ACCESS end function function type_of_select_value(node) type_of_select_value = ast_nodes(node).ref end function 'Can a be cast to b, even with loss? function type_can_cast(a, b) type_can_cast = type_can_safely_cast(a, b) or (type_is_number(a) and type_is_number(b)) end function 'Can a be cast to b without loss of data? function type_can_safely_cast(a, b) if a = b then 'Identity cast type_can_safely_cast = TRUE elseif b = TYPE_ANY then 'Generic type type_can_safely_cast = TRUE elseif type_is_array(a) or type_is_array(b) then 'Both arrays, same number of dimensions (or cast to indeterminate number), 'and element type is identical (or cast to ANY) type_can_safely_cast = type_is_array(a) and type_is_array(b) and _ (symtab(a).v4 = symtab(b).v4 or symtab(b).v4 = 0) and _ (symtab(a).v3 = symtab(b).v3 or symtab(b).v3 = TYPE_ANY) elseif not (type_is_number(a) and type_is_number(b)) then type_can_safely_cast = FALSE else select case a case TYPE_INTEGER type_can_safely_cast = TRUE case TYPE_LONG type_can_safely_cast = (b = TYPE_INTEGER64) or (b = TYPE_DOUBLE) or (b = TYPE_QUAD) case TYPE_INTEGER64 type_can_safely_cast = b = TYPE_QUAD case TYPE_SINGLE type_can_safely_cast = (b = TYPE_DOUBLE) or (b = TYPE_QUAD) case TYPE_DOUBLE type_can_safely_cast = b = TYPE_QUAD case TYPE_FLOAT type_can_safely_cast = FALSE end select end if end function function type_make_array(basetype, dimensions) dim sym as symtab_entry_t array_type_name$ = symtab(basetype).identifier + "[" + _trim$(str$(dimensions)) + "]" array_type_sym = symtab_get_id(array_type_name$) if array_type_sym then 'Already exists type_make_array = array_type_sym else sym.identifier = array_type_name$ sym.typ = SYM_TYPE 'Array descriptor: ' - pointer to data ' - number of dimensions ' - lbound of leftmost dimension ' - ubound of leftmost dimension ' - etc. ' - lbound of rightmost dimension ' - ubound of rightmost dimension if dimensions = 0 then '0 means any number of dimensions. Since we can't know how big the descriptor 'will be, it is treated as a simple pointer to descriptor and thus has size 1. sym.v1 = 1 else sym.v1 = 2 + dimensions * 2 end if sym.v2 = SYM_TYPE_ARRAY sym.v3 = basetype sym.v4 = dimensions symtab_add_entry sym type_make_array = symtab_last_entry end if end function 'The following functions are helpers to extract data from type signatures. type_sig_* 'variants take a numeric indentifier, type_sigt_* variants take a string holding the 'signature itself. arg_index is one-indexed, so 1 is the first argument in the signature. 'The type signature format (mkl$ encoded type, flags pairs) is used more generally for 'lists of types; in those cases the first component (return type) may be meaningless. 'What is the return type of the given signature? function type_sig_return(sig_index) type_sig_return = type_sigt_return(type_signatures(sig_index).sig) end function function type_sigt_return(sig$) type_sigt_return = cvl(left$(sig$, 4)) end function 'How many arguments (passed parameters) does a signature have, including all optionals? function type_sig_numargs(sig_index) type_sig_numargs = type_sigt_numargs(type_signatures(sig_index).sig) end function 'How many arguments excluding components that do not have an ast representation function type_sig_numargs_concrete(sig_index) for i = 1 to type_sig_numargs(sig_index) if type_sig_concrete_arg(sig_index, i) then result = result + 1 else end if next i type_sig_numargs_concrete = result end function function type_sigt_numargs(sig$) type_sigt_numargs = (len(sig$) - 4) / 8 end function 'What is the type of a particular argument in a signature? function type_sig_argtype(sig_index, arg_index) type_sig_argtype = type_sigt_argtype(type_signatures(sig_index).sig, arg_index) end function function type_sigt_argtype(sig$, arg_index) type_sigt_argtype = cvl(mid$(sig$, arg_index * 8 - 3, 4)) end function 'What are the flags of a particular argument in a signature? function type_sig_argflags(sig_index, arg_index) type_sig_argflags = type_sigt_argflags(type_signatures(sig_index).sig, arg_index) end function function type_sigt_argflags(sig$, arg_index) type_sigt_argflags = cvl(mid$(sig$, arg_index * 8 + 1, 4)) end function function type_sigt_flagval(flags) type_sigt_flagval = _shr(flags, 16) end function function type_sigt_merge$(a$, b$) type_sigt_merge$ = a$ + mid$(b$, 5) end function sub type_sig_merge(sig_index, b$) type_signatures(sig_index).sig = type_signatures(sig_index).sig + mid$(b$, 5) end function function type_sig_concrete_arg(sig_index, arg_index) flags = type_sig_argflags(sig_index, arg_index) type_sig_concrete_arg = (flags AND TYPE_SYNTAX_ONLY) = 0 end function 'Append an argument of the given type and flags to a signature sub type_sig_add_arg(sig_index, typ, flags) type_signatures(sig_index).sig = type_sigt_add_arg$(type_signatures(sig_index).sig, typ, flags) end sub function type_sigt_add_arg$(old$, new_argtype, new_argflags) type_sigt_add_arg$ = old$ + mkl$(new_argtype) + mkl$(new_argflags) end function 'Begin a new signature (no type_sig variant because it's unneeded) function type_sigt_create$(return_type) type_sigt_create$ = mkl$(return_type) end function 'Append a sig to the linked list ending in previous if previous > 0, otherwise start a 'new list function type_add_sig(previous, sig$) type_last_signature = type_last_signature + 1 if ubound(type_signatures) = type_last_signature then redim _preserve type_signatures(type_last_signature * 2) as type_signature_t end if type_signatures(type_last_signature).sig = sig$ type_signatures(type_last_signature).succ = 0 'Avoids QB64 compiler bug if previous then type_signatures(previous).succ = type_last_signature type_add_sig = type_last_signature end function 'Given an incomplete candidate, what types could we possibly expect to see next? 'Return format is list of 4 bytes padding + mkl$(type) + mkl$(flags). Padding 'allows using type_sigt_* functions to access. mkl$(0) + mkl$(0) means '"expect end of args". function type_sig_prefix_nexts$(func, candidate$, depth) result$ = type_sigt_create$(0) 'return type is meaningless compatibles$ = type_sig_prefix_compatibles$(func, candidate$) clen = type_sigt_numargs(candidate$) 'compatibles$ is list of possible sigs, but we can use type_sigt_* on it anyway for i = 1 to type_sigt_numargs(compatibles$) 'For each sig, determine what token we would be added to the candiate next 'if it were the true signature being read sig_index = type_sigt_argtype(compatibles$, i) if type_sig_numargs(sig_index) = clen then 'there are no more tokens expected for this sig, candidate matches exactly result$ = type_sigt_add_arg(result$, 0, 0) elseif type_sig_numargs(sig_index) > clen then 'candidate currently only has a prefix-set of the arguments. arg_type = type_sig_argtype(sig_index, clen + 1) arg_flags = type_sig_argflags(sig_index, clen + 1) OR _shl(depth, 16) result$ = type_sigt_add_arg(result$, arg_type, arg_flags) 'If that was an optional TYPE_TOKEN, also include the args after it to 'allow for epsilon transition. if (arg_flags AND TYPE_TOKEN) > 0 and (arg_flags AND TYPE_OPTIONAL) > 0 then lookahead$ = type_sig_prefix_nexts$(func, type_sigt_add_arg(candidate$, arg_type, arg_flags), depth + 1) result$ = type_sigt_merge$(result$, lookahead$) end if else 'Should never occur ps_error "Impossible sig length" end if next i type_sig_prefix_nexts$ = result$ $if DEBUG_CALL_RESOLUTION then for i = 1 to type_sigt_numargs(result$) if type_sigt_argflags(result$, i) and TYPE_CONTEXTUAL then debugmsg$ = debugmsg$ + " " + ast_constants(type_sigt_argtype(result$, i)) + "/" + str$(type_sigt_flagval(type_sigt_argflags(result$, i))) else debugmsg$ = debugmsg$ + " " + type_human_readable$(type_sigt_argtype(result$, i)) + "/" + str$(type_sigt_flagval(type_sigt_argflags(result$, i))) end if next i debuginfo "Nexts list:" + debugmsg$ $end if end function 'Given a (possibly incomplete) candidate, find sigs for func that are compatible 'Return format is list of mkl$(sig_index) function type_sig_prefix_compatibles$(func, candidate$) compatibles$ = type_sigt_create$(0) sig_index = symtab(func).v1 while sig_index <> 0 if type_sig_is_prefix_compatible(sig_index, candidate$, 0) then compatibles$ = type_sigt_add_arg(compatibles$, sig_index, 0) end if sig_index = type_signatures(sig_index).succ wend type_sig_prefix_compatibles$ = compatibles$ end function function type_sig_is_prefix_compatible(sig_index, candidate$, checkmode) $if DEBUG_CALL_RESOLUTION then debuginfo "Comparing to " + type_human_sig$(type_signatures(sig_index).sig) $end if 'candidate will generally have ANY or NONE return types for FUNCTION and SUB 'contexts respectively. In the future though this may become more specific, 'so ensure the actual return type can be cast to what is needed. if not type_can_cast(type_sig_return(sig_index), type_sigt_return(candidate$)) then $if DEBUG_CALL_RESOLUTION then debuginfo "No, return types not compatible" $end if exit function end if for argi = 1 to type_sigt_numargs(candidate$) if argi > type_sig_numargs(sig_index) then 'Cannot possibly match, candidate has more args than sig can accept $if DEBUG_CALL_RESOLUTION then debuginfo "No, candidate has too many arguments" $end if exit function end if sig_arg = type_sig_argtype(sig_index, argi) sig_flags = type_sig_argflags(sig_index, argi) c_arg = type_sigt_argtype(candidate$, argi) c_flags = type_sigt_argflags(candidate$, argi) if not type_sig_compatible_arg(sig_arg, sig_flags, c_arg, c_flags, checkmode) then $if DEBUG_CALL_RESOLUTION then debuginfo "No, mismatch on arg" + str$(argi) + " (candidate has " + type_human_readable$(c_arg) + ")" $end if exit function end if next argi $if DEBUG_CALL_RESOLUTION then debuginfo "(Prefix) " + str$(type_sigt_numargs(candidate$)) + " arguments match" $end if type_sig_is_prefix_compatible = TRUE end function 'Function call resolution! 'Each function name has one or more signatures. A signature gives the return type and the 'type of each of its arguments. When a call is parsed, a candidate is built which is like 'a signature in that it is a list of the type of each supplied argument and return type '(a candidate's return type is always NONE or ANY because we can't reliably detect that). ' 'With the candidate we then have to find a signature that matches. The procedure: '1) ' a) Look for a compatible signature. A sig is compatible if all required arguments are ' supplied, there are not too many optional arguments and all passed arguments can be ' cast to the expected type. ' b) if there no matches, fail. ' c) If there is exactly 1 compatible sig, that is the result. ' d) If there are multiple strictly compatible sigs, continue to step 2. '2) ' a) Of all compatible signatures, select the first one where all the casts are lossless. ' b) If no sig matches with lossless casts, select the last sig from the list of compatibles. ' 'Rule 1c is the usual case for simple functions. 2a allows polymorphic functions to be listed 'in the tokens.list file in order of increasing type width and the narrowest version that 'doesn't lose data is picked. 2b is a fallback if a cast is inevitable. function type_find_sig_match(func, candidate$) $if DEBUG_CALL_RESOLUTION then debuginfo "Function resolution candidate is " + type_human_sig$(candidate$) $end if sig_index = symtab(func).v1 compatibles$ = type_sigt_create$(0) while sig_index <> 0 if type_sig_is_compatible(sig_index, candidate$, 0) then compatibles$ = type_sigt_add_arg$(compatibles$, sig_index, 0) end if sig_index = type_signatures(sig_index).succ wend if type_sigt_numargs(compatibles$) = 0 then exit function elseif type_sigt_numargs(compatibles$) = 1 then type_find_sig_match = type_sigt_argtype(compatibles$, 1) else type_find_sig_match = type_pick_best_compatible_sig(compatibles$, candidate$) end if end function function type_sig_is_compatible(sig_index, candidate$, checkmode) if not type_sig_is_prefix_compatible(sig_index, candidate$, checkmode) then exit function for i = type_sigt_numargs(candidate$) + 1 to type_sig_numargs(sig_index) 'sig has more args; they had better be optional if (type_sig_argflags(sig_index, i) AND TYPE_OPTIONAL) = 0 then $if DEBUG_CALL_RESOLUTION then debuginfo "No, required argument" + str$(i) + " not provided" $end if exit function end if next i type_sig_is_compatible = TRUE $if DEBUG_CALL_RESOLUTION then debuginfo "Compatible" $end if end function function type_pick_best_compatible_sig(compatibles$, candidate$) 'Picks the first sig that has lossless casts, otherwise the last sig if 'no lossless casts are available. $if DEBUG_CALL_RESOLUTION then debuginfo "Looking for a safe cast option" $end if for i = 1 to type_sigt_numargs(compatibles$) sig_index = type_sigt_argtype(compatibles$, i) if type_sig_is_compatible(sig_index, candidate$, 1) then type_pick_best_compatible_sig = sig_index $if DEBUG_CALL_RESOLUTION then debuginfo "Safe signature found." $end if exit function end if next i $if DEBUG_CALL_RESOLUTION then debuginfo "No safe signature found." $end if 'Default to last sig on list type_pick_best_compatible_sig = type_sigt_argtype(compatibles$, type_sigt_numargs(compatibles$)) end function function type_sig_compatible_arg(sig_arg, sig_flags, c_arg, c_flags, checkmode) 'checkmode = 0 for lossy casts, 1 for lossless casts only if c_arg = TYPE_NONE then result = (sig_flags and TYPE_OPTIONAL) > 0 elseif sig_flags and TYPE_BYREF then 'Hardcoded check for TYPE_ANY, TYPE_ANY_ARRAY to allow for functions that really take any variable, array result = (c_flags and TYPE_BYREF) > 0 and (sig_arg = c_arg or sig_arg = TYPE_ANY or (sig_arg = TYPE_ANY_ARRAY and type_is_array(c_arg))) elseif checkmode = 0 then result = type_can_cast(c_arg, sig_arg) elseif checkmode = 1 then result = type_can_safely_cast(c_arg, sig_arg) end if fh_ok = ((c_flags and TYPE_FILEHANDLE) <> 0) imp ((sig_flags and TYPE_FILEHANDLE) <> 0) result = result and (fh_ok <> 0) type_sig_compatible_arg = result end function function type_human_readable$(typ) id$ = symtab(typ).identifier 'Remove any name mangling if left$(id$, 1) = "|" then id$ = mid$(id$, 2) type_human_readable$ = id$ end function function type_human_sig$(sig$) o$ = type_human_readable$(type_sigt_return(sig$)) + "(" for p = 1 to type_sigt_numargs(sig$) flags = type_sigt_argflags(sig$, p) if flags and TYPE_BYVAL then o$ = o$ + "BYVAL " if flags and TYPE_BYREF then o$ = o$ + "BYREF " if flags and TYPE_OPTIONAL then o$ = o$ + "OPTION " if flags and TYPE_FILEHANDLE then o$ = o$ + "#" if flags and TYPE_TOKEN then o$ = o$ + tok_human_readable$(type_sigt_argtype(sig$, p)) elseif flags and TYPE_CONTEXTUAL then o$ = o$ + ast_constants(type_sigt_argtype(sig$, p)) else o$ = o$ + type_human_readable$(type_sigt_argtype(sig$, p)) end if o$ = o$ + ", " next p if right$(o$, 2) = ", " then o$ = left$(o$, len(o$) - 2) 'Trim trailing comma type_human_sig$ = o$ + ")" end function function type_detect_numint_type(content$) '2^15-1 = 32767 '2^31-1 = 2147483647 '2^63-1 = 18446744073709551615 select case len(content$) case is < 5 type_detect_numint_type = TYPE_INTEGER case 5 if _strcmp("32767", content$) = -1 then type_detect_numint_type = TYPE_LONG else type_detect_numint_type = TYPE_INTEGER end if case is < 10 type_detect_numint_type = TYPE_LONG case 10 if _strcmp("2147483647", content$) = -1 then type_detect_numint_type = TYPE_INTEGER64 else type_detect_numint_type = TYPE_LONG end if case is < 20 type_detect_numint_type = TYPE_INTEGER64 case 20 if _strcmp("18446744073709551615", content$) = -1 then 'Should we be checking for overflow here? type_detect_numint_type = TYPE_QUAD else type_detect_numint_type = TYPE_INTEGER64 end if case > 20 'Again, should maybe check for overflow here type_detect_numint_type = TYPE_QUAD end select end function function type_detect_numdec_type(content$) '<= 7 digits -> single, <= 16 digits -> double select case len(content$) - 1 '-1 because there's a decimal point case is <= 7 type_detect_numdec_type = TYPE_SINGLE case is <= 16 type_detect_numdec_type = TYPE_DOUBLE case else type_detect_numdec_type = TYPE_QUAD end select end function function type_detect_numexp_type(content$) 'e -> single, d -> double, (q -> quad ?) for i = 1 to len(content$) if asc(content$, i) = 68 or asc(content$, i) = 100 then 'd or D type_detect_numexp_type = TYPE_DOUBLE exit function end if next i type_detect_numexp_type = TYPE_SINGLE end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'ast.bm - Routines for Abstract Syntax Tree deflng a-z ' Initialise a clean AST sub ast_init redim ast_nodes(10) as ast_node_t redim ast_children(10) as string ast_last_node = 0 redim ast_constants(10) as string redim ast_constant_types(10) as long ast_constants(AST_FALSE) = "0" ast_constant_types(AST_FALSE) = TYPE_INTEGER ast_constants(AST_TRUE) = "-1" ast_constant_types(AST_TRUE) = TYPE_INTEGER ast_constants(AST_ONE) = "1" ast_constant_types(AST_ONE) = TYPE_INTEGER ast_last_constant = 3 ast_commit end sub sub ast_commit ast_last_commit_id = ast_last_node ast_last_constant_commit_id = ast_last_constant end sub sub ast_rollback for i = ast_last_commit_id + 1 to ast_last_node ast_children(i) = "" next i ast_last_node = ast_last_commit_id ast_last_constant = ast_last_constant_commit_id end sub sub ast_clear_entrypoint 'Sets the main block to have 0 nodes. 'This doesn't actually delete the nodes, use ast_rollback for that. ast_children(AST_ENTRYPOINT) = "" end sub function ast_add_constant(token, content$, force_type) if ast_last_constant = ubound(ast_constants) then ast_expand_constants_array ast_last_constant = ast_last_constant + 1 select case token case TOK_NUMINT ast_constants(ast_last_constant) = content$ detected_type = type_detect_numint_type(content$) case TOK_NUMDEC ast_constants(ast_last_constant) = content$ detected_type = type_detect_numdec_type(ast_constants(ast_last_constant)) case TOK_NUMBASE ast_constants(ast_last_constant) = ltrim$(str$(val(content$))) detected_type = type_detect_numint_type(ast_constants(ast_last_constant)) case TOK_NUMEXP ast_constants(ast_last_constant) = content$ detected_type = type_detect_numexp_type(ast_constants(ast_last_constant)) case TOK_STRINGLIT 'Strip quotes ast_constants(ast_last_constant) = mid$(content$, 2, len(content$) - 2) detected_type = TYPE_STRING case TOK_CONTEXTUAL_ARGUMENT ast_constants(ast_last_constant) = "|" + content$ + "|" detected_type = TYPE_CONTEXTUAL_ARGUMENT end select if force_type > 0 then 'If you've used D or E, don't try and use # or ! as well! if token = TOK_NUMEXP or not type_can_safely_cast(detected_type, force_type) then ps_error "Cannot retype constant" ast_constant_types(ast_last_constant) = force_type else ast_constant_types(ast_last_constant) = detected_type end if ast_add_constant = ast_last_constant end function function ast_add_node(typ) if ast_last_node = ubound(ast_nodes) then ast_expand_nodes_arrays ast_last_node = ast_last_node + 1 ast_nodes(ast_last_node).typ = typ ast_nodes(ast_last_node).linenum = ps_actual_linenum ast_add_node = ast_last_node end function function ast_add_cast(expr, vartyp) if vartyp = type_of_expr(expr) or vartyp = TYPE_ANY or type_is_array(vartyp) then 'Don't cast to TYPE_ANY because that's just a shorthand for a function that 'can handle any type. Don't cast when arrays are involved because they already 'have the element type matching exactly. ast_add_cast = expr exit function end if cast_node = ast_add_node(AST_CAST) ast_nodes(cast_node).ref = vartyp ast_attach cast_node, expr ast_add_cast = cast_node end function sub ast_attach(parent, child) if child = 0 or child = -1 then $if DEBUG_PARSE_TRACE then debuginfo "Not adding child node because it is " + ltrim$(str$(child)) $end if exit sub end if ast_nodes(child).parent = parent ast_children(parent) = ast_children(parent) + mkl$(child) end sub sub ast_pre_attach(parent, child) if child = 0 or child = -1 then $if DEBUG_PARSE_TRACE then debuginfo "Not adding child node because it is " + ltrim$(str$(child)) $end if exit sub end if ast_nodes(child).parent = parent ast_children(parent) = mkl$(child) + ast_children(parent) end sub function ast_num_children(node) ast_num_children = len(ast_children(node)) / len(dummy&) end function function ast_is_none(node) ast_is_none = ast_nodes(node).typ = AST_NONE end function function ast_is_lvalue(node) select case ast_nodes(node).typ case AST_VAR, AST_ARRAY_ACCESS, AST_UDT_ACCESS ast_is_lvalue = TRUE end select end function function ast_get_child(node, index) ast_get_child = cvl(mid$(ast_children(node), len(dummy&) * (index - 1) + 1, len(dummy&))) end function sub ast_replace_child(node, index, new_child) mid$(ast_children(node), len(dummy&) * (index - 1) + 1, len(dummy&)) = mkl$(new_child) end sub 'Inverse of ast_get_child. node == ast_get_child(parent, ast_find_child(parent, node)) function ast_find_child(parent, node) for i = 1 to ast_num_children(parent) if ast_get_child(parent, i) = node then ast_find_child = i exit function end if next i end function sub ast_expand_nodes_arrays() new_size = ubound(ast_nodes) * 2 redim _preserve ast_nodes(new_size) as ast_node_t redim _preserve ast_children(new_size) as string end sub sub ast_expand_constants_array() new_size = ubound(ast_constants) * 2 redim _preserve ast_constants(new_size) as string redim _preserve ast_constant_types(new_size) as long end sub 'List of nodes beginning at common ancestor of src & dest, ending at dest function ast_path_from_ancestor$(src, dest) src_path$ = ast_abs_path$(src) dest_path$ = ast_abs_path$(dest) for i = 1 to len(dest_path$) step 4 if mid$(src_path$, i, 4) <> mid$(dest_path$, i, 4) then exit for next i ast_path_from_ancestor$ = mid$(dest_path$, i - 4) end function function ast_abs_path$(node) n = node do r$ = mkl$(n) + r$ n = ast_nodes(n).parent loop while n ast_abs_path$ = r$ end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'symtab.bm - Symbol Table sub symtab_add_entry(entry as symtab_entry_t) symtab_expand_if_needed symtab_last_entry = symtab_last_entry + 1 symtab(symtab_last_entry) = entry symtab_map_insert entry.identifier, symtab_last_entry end sub function symtab_get_id(identifier$) h~& = symtab_hash~&(identifier$, ubound(symtab_map)) do id = symtab_map(h~&) if id = 0 then exit function end if if symtab(id).identifier = identifier$ then symtab_get_id = id exit function endif h~& = (h~& + 1) mod (ubound(symtab_map) + 1) loop end function sub symtab_commit symtab_last_commit_id = symtab_last_entry end sub sub symtab_rollback 'Would it be more efficient to do this in reverse order? 'Does anyone care about how fast it is? for i = symtab_last_commit_id + 1 to symtab_last_entry identifier$ = symtab(i).identifier h~& = symtab_hash~&(identifier$, ubound(symtab_map)) do id = symtab_map(h~&) if symtab(id).identifier = identifier$ then exit do h~& = (h~& + 1) mod (ubound(symtab_map) + 1) loop symtab_map(h~&) = 0 next i symtab_last_entry = symtab_last_commit_id end sub 'Strictly internal functions below sub symtab_expand_if_needed const SYMTAB_MAX_LOADING = 0.75 const SYMTAB_GROWTH_FACTOR = 2 if symtab_last_entry = ubound(symtab) then redim _preserve symtab(ubound(symtab) * SYMTAB_GROWTH_FACTOR) as symtab_entry_t end if if symtab_last_entry / ubound(symtab_map) <= SYMTAB_MAX_LOADING then exit function redim symtab_map(ubound(symtab_map) * SYMTAB_GROWTH_FACTOR) for i = 1 to symtab_last_entry symtab_map_insert symtab(i).identifier, i next i end sub sub symtab_map_insert (k$, v) h~& = symtab_hash~&(k$, ubound(symtab_map)) do if symtab_map(h~&) = 0 then exit do h~& = (h~& + 1) mod (ubound(symtab_map) + 1) loop symtab_map(h~&) = v end sub 'http://www.cse.yorku.ca/~oz/hash.html 'Attributed to D. J. Bernstein function symtab_hash~&(k$, max) hash~& = 5381 for i = 1 to len(k$) hash~& = ((hash~& * 33) xor asc(k$, i)) mod max next i '0<=hash<=max-1, so 1<=hash+1<=max symtab_hash~& = hash~& + 1 end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'parser.bm - Recursive Descent Parser sub ps_init ps_scope_frame_size = 0 ps_main_frame_size = 0 ps_actual_linenum = 1 ps_default_type = TYPE_SINGLE ps_allow_implicit_vars = TRUE end sub function ps_is_linejoin ps_is_linejoin = tok_token = TOK_NEWLINE and tok_content$ = ":" end function sub ps_consume(expected) ps_assert expected tok_advance end sub function ps_consumed(expected) if tok_token = expected then if tok_token = TOK_NEWLINE and not ps_is_linejoin then ps_actual_linenum = ps_actual_linenum + 1 tok_advance ps_consumed = TRUE end if end function sub ps_assert(expected) if tok_token <> expected then if ucase$(tok_human_readable(tok_token)) = ucase$(tok_content$) then ps_error "Syntax error: expected " + tok_human_readable(expected) + " got " + tok_human_readable(tok_token) else ps_error "Syntax error: expected " + tok_human_readable(expected) + " got " + tok_human_readable(tok_token) + " " + chr$(34) + tok_content$ + chr$(34) end if else $if DEBUG_PARSE_TRACE then debuginfo "Assert " + tok_human_readable(expected) $end if end if if tok_token = TOK_NEWLINE and not ps_is_linejoin then ps_actual_linenum = ps_actual_linenum + 1 end sub 'Execute this when at the beginning of a line. As well as consuming whitespace, 'it handles the EOI from interactive mode. sub ps_line_prelude do while tok_token = TOK_NEWLINE ps_consume TOK_NEWLINE loop if tok_token = TOK_EOI then ps_consume TOK_EOI end if end sub function ps_is_terminator(t) select case t case TOK_ELSE, TOK_NEWLINE ps_is_terminator = TRUE end select end function function ps_last_nested(ast_type) for i = len(ps_nested_structures$) - 3 to 1 step -4 if ast_nodes(cvl(mid$(ps_nested_structures$, i, 4))).typ = ast_type then ps_last_nested = cvl(mid$(ps_nested_structures$, i, 4)) exit function end if next i end function function ps_final_nested if len(ps_nested_structures$) = 0 then exit function ps_final_nested = cvl(right$(ps_nested_structures$, 4)) end function sub ps_add_nested_structure(node) ps_nested_structures$ = ps_nested_structures$ + mkl$(node) end sub sub ps_remove_nested_structure ps_nested_structures$ = left$(ps_nested_structures$, len(ps_nested_structures$) - 4) end sub function ps_scope$ 'Note: global symbols (functions, SHARED vars) have no @ at all ps_scope$ = "@" + ps_scope_identifier$ + "@" end function function ps_get_scope$(token) varname$ = symtab(token).identifier if left$(varname$, 1) <> "@" then ps_get_scope$ = "" else ps_get_scope$ = mid$(varname$, 2, instr(2, varname$, "@") - 2) end if end function sub ps_queue_cleanup(node) ps_queued_nodes$ = ps_queued_nodes$ + mkl$(node) end sub sub ps_error(msg$) Error_message$ = msg$ error 101 end sub 'Expects: first token in block 'Results: block end marker or IEOF function ps_block $if DEBUG_PARSE_TRACE then debuginfo "Start block" $end if root = ast_add_node(AST_BLOCK) do do while tok_token = TOK_NEWLINE ps_consume TOK_NEWLINE loop stmt = ps_stmt ' -2 -> SUB or FUNCTION definition, continue processing input if stmt = -1 then exit do 'use -1 to signal the end of a block if stmt > 0 then ast_attach root, stmt '0 means that statement did not generate any ast nodes loop ps_block = root $if DEBUG_PARSE_TRACE then debuginfo "End block" $end if end function 'Because some program elements can be referenced before they are defined, we need to 'do a first pass through the program to identify these declarations. We contrast this '"prepass" with a main pass, usually an invocation of ps_block or similar. 'The prepass will detect and instantiate the following objects: ' - SUB/FUNCTION definitions ' - DIM SHARED variables ' - TYPE definitions 'everything else is ignored. Importantly, the ast will be reset after this so no nodes 'or constants can be created. sub ps_prepass $if DEBUG_PARSE_TRACE then debuginfo "Start prepass" $end if do select case tok_token case TOK_SUB, TOK_FUNCTION dummy = ps_declare_p case TOK_EXIT, TOK_END 'These could be followed by SUB or FUNCTION which would cause confusion tok_advance tok_advance case TOK_DIM tok_advance if tok_token = TOK__PRESERVE then tok_advance if tok_token <> TOK_SHARED then exit select 'TODO handle shared variable case TOK_TYPE dummy = ps_udt case TOK__DEFINE ps_define_type case TOK_DEFINT, TOK_DEFLNG, TOK_DEFSNG, TOK_DEFDBL, TOK_DEFSTR ps_deftype case TOK_NEWLINE ps_line_prelude case else tok_advance end select loop until ps_consumed(TOK_IEOF) $if DEBUG_PARSE_TRACE then debuginfo "Completed prepass" $end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'array.bm - Parse rules for array declaration and usage 'Expects: ( or other token 'Results: token after ) or sigil, if present 'This sub produces AST_ARRAY_DELETE and AST_ARRAY_RESIZE operations 'and adds them to the supplied block. It also generates the symtab entries 'for the array itself and its type. This somewhat duplicates the logic in 'parser/userfuncs.bm. sub ps_dim_array(token, var_name$, sigil, block, is_shared, preserve, is_static) $if DEBUG_PARSE_TRACE then debuginfo "Start dim array" $end if if token <> TOK_UNKNOWN then existing_array = token 'This variable is updated as we go; see towards the bottom for a summary. destruct = ps_last_nested(AST_PROCEDURE) > 0 'Note the parentheses may be omitted or empty if the number of dimensions 'is given in the type. if ps_consumed(TOK_OPAREN) then if tok_token <> TOK_CPAREN then 'dims$ will be a series of pairs of AST_EXPR, which are the lower and upper 'bounds for each dimension. do dims$ = dims$ + mkl$(ps_expr) if ps_consumed(TOK_TO) then dims$ = dims$ + mkl$(ps_expr) else 'Whoops, there was in implicit lower bound. Add it in. implicit_zero = ast_add_node(AST_CONSTANT) ast_nodes(implicit_zero).ref = AST_FALSE dims$ = left$(dims$, len(dims$) - 4) + mkl$(implicit_zero) + right$(dims$, 4) end if dimensions = dimensions + 1 loop while ps_consumed(TOK_COMMA) end if ps_consume TOK_CPAREN end if 'Empty or omitted parentheses mean this array is not concrete; we cannot actually 'instantiate it. if dimensions > 0 then concrete_array = TRUE 'So far sigil is any type provided before the (), sigil2 is any type given after 'the (). sigil2 = ps_opt_sigil if sigil2 > 0 and sigil > 0 then ps_error "Cannot give type twice" if sigil2 then sigil = sigil2 if sigil = 0 then sigil = ps_default_type 'If the type has a number of dimensions, ensure it matches the bounds if given. if type_is_array(sigil) and _ concrete_array and _ symtab(sigil).v2 <> 0 and _ dimensions <> symtab(sigil).v2 then ps_error "Number of bounded dimensions does not match number of dimensions in type" end if 'We need to create the array type based on number of bounds if it's not in the type if not type_is_array(sigil) then sigil = type_make_array(sigil, dimensions) 'sigil is now guaranteed to be an array type. Ensure we're not changing the type 'of an existing array. The exception is that if the existing array has no definite number 'of dimensions, we can specify any number of dimensions. This is somewhat dangerous, so 'a safe runtime will want to check this operation. if existing_array > 0 then existing_typ = symtab(existing_array).v1 if existing_typ <> sigil and symtab(existing_typ).v4 <> 0 then ps_error "Cannot change array type from " + type_human_readable$(existing_typ) + " to " + type_human_readable$(sigil) end if end if 'Now we can create the actual array variable dim sym as symtab_entry_t if existing_array = 0 then if is_shared then sym.identifier = ucase$(var_name$) else sym.identifier = ps_scope$ + ucase$(var_name$) end if sym.typ = SYM_VARIABLE sym.v1 = sigil sym.v2 = ps_scope_frame_size ps_scope_frame_size = ps_scope_frame_size + type_fixed_size(sym.v1) if is_static or is_shared then sym.v3 = SYM_VARIABLE_MAINFRAME destruct = FALSE else sym.v3 = 0 end if 'Because we don't know the size of a descriptor for any-dimensional arrays, 'they are always a pointer to the descriptor. if dimensions = 0 then sym.v3 = sym.v3 OR SYM_VARIABLE_DEREF symtab_add_entry sym var = symtab_last_entry else var = existing_array destruct = FALSE end if 'Used for constructor and destructor var_node = ast_add_node(AST_VAR) ast_nodes(var_node).ref = var 'Only generate a constructor if we actually know the array size if concrete_array then if is_static then node = ast_add_node(AST_ARRAY_ESTABLISH) elseif preserve then node = ast_add_node(AST_ARRAY_RESIZE) else node = ast_add_node(AST_ARRAY_CREATE) end if ast_attach node, var_node ast_attach block, node ast_children(node) = mkl$(var_node) + dims$ end if 'Generate an array destructor if: ' - we are in a procedure (no need to destruct at program exit), and ' - the array is not shared or static, and ' - the variable is not an existing array (would imply it is owned by another scope). ' Note that we _do_ generate a destructor for non-concrete arrays, because those ' variables may be assigned (and thus take ownership) of a concrete array. if destruct then 'Have a check to see if there's already a destructor. 'This could occur if there are multiple DIMs in the same function. for i = 1 to len(ps_queued_nodes$) - 3 step 4 other = cvl(mid$(ps_queued_nodes$, i, 4)) if ast_nodes(other).typ = AST_ARRAY_DELETE and _ ast_nodes(ast_get_child(other, 1)).ref = var then goto array_dstr_dup next i node = ast_add_node(AST_ARRAY_DELETE) ast_attach node, var_node ps_queue_cleanup node end if array_dstr_dup: $if DEBUG_PARSE_TRACE then debuginfo "Completed dim array" $end if end sub 'Expects: First index of array access 'Results: token after ) 'Takes array variable as argument function ps_array_element_access(lvalue) $if DEBUG_PARSE_TRACE then debuginfo "Start array element access" $end if array_type = type_of_lvalue(lvalue) if symtab(array_type).v2 <> SYM_TYPE_ARRAY then ps_error "Value is not an array" dimensions = symtab(array_type).v4 node = ast_add_node(AST_ARRAY_ACCESS) ast_attach node, lvalue do ast_attach node, ps_expr loop while ps_consumed(TOK_COMMA) ps_consume TOK_CPAREN if ast_num_children(node) - 1 <> dimensions and dimensions <> 0 then ps_error "Incorrect number of dimensions" end if ps_array_element_access = node $if DEBUG_PARSE_TRACE then debuginfo "Completed array element access" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'assignment.bm - Parse rules for variable assignment 'Expects: lvalue token 'Results: token after rvalue function ps_assignment $if DEBUG_PARSE_TRACE then debuginfo "Start assignment" $end if root = ast_add_node(AST_ASSIGN) lval = ps_lvalue_mutable ast_attach root, lval ps_consume TOK_EQUALS expr = ps_expr lvalue_type = type_of_lvalue(lval) rvalue_type = type_of_expr(expr) if not type_can_cast(rvalue_type, lvalue_type) then ps_error "Type of variable in assignment does not match value being assigned" expr = ast_add_cast(expr, lvalue_type) ast_attach root, expr ps_assignment = root $if DEBUG_PARSE_TRACE then debuginfo "Completed assignment" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'const.bm - Parse rules for CONST 'Expects: TOK_CONST 'Results: token after rvalue function ps_const $if DEBUG_PARSE_TRACE then debuginfo "Start const" $end if ps_consume TOK_CONST 'We use a block so we can deal with multiple consts root = ast_add_node(AST_BLOCK) do if tok_token <> TOK_UNKNOWN then ps_error "CONST already defined" const_name$ = tok_content$ tok_advance sigil = ps_opt_sigil var = ps_new_var_pp(const_name$, sigil, TRUE, FALSE) lval = ast_add_node(AST_VAR) ast_nodes(lval).ref = var symtab(var).v3 = symtab(var).v3 or SYM_VARIABLE_CONST 'Mark constant assignment = ast_add_node(AST_ASSIGN) ast_attach root, assignment ast_attach assignment, lval ps_consume TOK_EQUALS expr = ps_expr if sigil = 0 then symtab(var).v1 = type_of_expr(expr) ast_attach assignment, expr elseif type_can_cast(type_of_expr(expr), sigil) then cast = ast_add_node(AST_CAST) ast_nodes(cast).ref = sigil ast_attach cast, expr ast_attach assignment, cast else ps_error "Type mismatch" end if loop while ps_consumed(TOK_COMMA) ps_const = root $if DEBUG_PARSE_TRACE then debuginfo "Completed const" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'default_type.bm - Parse rules for DEF* A-Z and _DEFINE A-Z commands 'Expects: TOK_DEF{INT,LNG,SNG,DBL,STR} 'Results: NEWLINE sub ps_deftype $if DEBUG_PARSE_TRACE then debuginfo "Start deftype" $end if token = tok_token 'Do error checking for making any changes tok_advance if ucase$(tok_content$) <> "A" then ps_error "Range must be A-Z" tok_advance ps_consume TOK_DASH if ucase$(tok_content$) <> "Z" then ps_error "Range must be A-Z" tok_advance select case token case TOK_DEFINT ps_default_type = TYPE_INTEGER case TOK_DEFLNG ps_default_type = TYPE_LONG case TOK_DEFSNG ps_default_type = TYPE_SINGLE case TOK_DEFDBL ps_default_type = TYPE_DOUBLE case TOK_DEFSTR ps_default_type = TYPE_STRING end select $if DEBUG_PARSE_TRACE then debuginfo "Completed deftype" $end if end sub 'Expects: TOK__DEFINE 'Results: NEWLINE sub ps_define_type $if DEBUG_PARSE_TRACE then debuginfo "Start define type" $end if ps_consume TOK__DEFINE if ucase$(tok_content$) <> "A" then ps_error "Range must be A-Z" tok_advance ps_consume TOK_DASH if ucase$(tok_content$) <> "Z" then ps_error "Range must be A-Z" tok_advance typ = ps_opt_sigil if typ = 0 then ps_error "Expected type specifier" ps_default_type = typ $if DEBUG_PARSE_TRACE then debuginfo "Completed define type" $end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'drawing.bm - Parse rules for vector drawing commands 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'exit.bm - Parse rules for EXIT statements function ps_exit $if DEBUG_PARSE_TRACE then debuginfo "Start exit" $end if root = ast_add_node(AST_EXIT) ps_consume TOK_EXIT select case tok_token case TOK_DO target = ps_last_nested(AST_DO_PRE) if target = 0 then target = ps_last_nested(AST_DO_POST) case TOK_WHILE target = ps_last_nested(AST_WHILE) case TOK_FOR target = ps_last_nested(AST_FOR) case TOK_FUNCTION, TOK_SUB target = ps_last_nested(AST_PROCEDURE) case else ps_error "Expected DO, WHILE or FOR" end select if target = 0 then ps_error "Not inside a " + tok_human_readable$(tok_token) + " block" tok_advance ast_nodes(root).ref = target ps_exit = root $if DEBUG_PARSE_TRACE then debuginfo "Completed exit" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'for.bm - Parse rules for FOR loop 'Expects: FOR 'Results: NEWLINE after NEXT or iterator variable function ps_for $if DEBUG_PARSE_TRACE then debuginfo "Start FOR loop" $end if root = ast_add_node(AST_FOR) ps_add_nested_structure root ps_consume TOK_FOR var = ps_lvalue_mutable var_type = type_of_lvalue(var) if not type_is_number(var_type) then ps_error "FOR iterator variable must be numeric" ast_attach root, var ps_consume TOK_EQUALS start_val = ps_expr if not type_is_number(type_of_expr(start_val)) then ps_error "FOR start value must be numeric" if type_of_expr(start_val) <> var_type then cast = ast_add_node(AST_CAST) ast_nodes(cast).ref = var_type ast_attach cast, start_val start_val = cast end if ps_consume TOK_TO end_val = ps_expr if not type_is_number(type_of_expr(end_val)) then ps_error "FOR end value must be numeric" if type_of_expr(end_val) <> var_type then cast = ast_add_node(AST_CAST) ast_nodes(cast).ref = var_type ast_attach cast, end_val end_val = cast end if if tok_token = TOK_STEP then ps_consume TOK_STEP step_val = ps_expr if not type_is_number(type_of_expr(step_val)) then ps_error "FOR STEP value must be numeric" else step_val = ast_add_node(AST_CONSTANT) ast_nodes(step_val).ref = AST_ONE end if if type_of_expr(step_val) <> var_type then cast = ast_add_node(AST_CAST) ast_nodes(cast).ref = var_type ast_attach cast, step_val step_val = cast end if ps_consume TOK_NEWLINE ast_attach root, start_val ast_attach root, end_val ast_attach root, step_val ast_attach root, ps_block ps_consume TOK_NEXT 'TODO: Check this lvalue matches the one at the top of the loop if tok_token <> TOK_NEWLINE then dummy = ps_lvalue_mutable ps_remove_nested_structure ps_for = root $if DEBUG_PARSE_TRACE then debuginfo "Completed FOR loop" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'function.bm - Parse rules for function calls 'Expects: TOK_CALL 'Results: NEWLINE function ps_call $if DEBUG_PARSE_TRACE then debuginfo "Start call" $end if ps_consume TOK_CALL token = tok_token tok_advance ps_call = ps_funccall_p(token) $if DEBUG_PARSE_TRACE then debuginfo "Completed call" $end if end function 'Expects: function token 'Results: token after last argument function ps_funccall token = tok_token tok_advance ps_funccall = ps_funccall_p(token) end function 'Expects: token after function, function token as arg 'Results: token after last argument function ps_funccall_p(func) $if DEBUG_PARSE_TRACE then debuginfo "Start function call" $end if root = ast_add_node(AST_CALL) ast_nodes(root).ref = func sigil = ps_opt_sigil if tok_token = TOK_OPAREN then ps_consume TOK_OPAREN ps_funcargs root, type_sigt_create$(TYPE_ANY), FALSE ps_consume TOK_CPAREN else 'function has no arguments matching_sig = type_find_sig_match(func, type_sigt_create$(TYPE_ANY)) if matching_sig = 0 then ps_error "Cannot find matching type signature" ast_nodes(root).ref2 = matching_sig 'Add any optional arguments at end for i = 1 to type_sig_numargs(matching_sig) ast_attach root, ast_add_node(AST_NONE) next i end if if sigil > 0 and sigil <> type_of_call(root) then ps_error "Function must have correct type suffix if present" ps_funccall_p = root $if DEBUG_PARSE_TRACE then debuginfo "Completed function call" $end if end function 'Expects: first token after function name 'Results: token after argument list sub ps_funcargs(root, candidate$, is_statement) $if DEBUG_PARSE_TRACE then debuginfo "Start funcargs" $end if 'Handle empty argument at start if tok_token = TOK_COMMA then ps_funcarg root, candidate$, suppress_comma 'Loop over arguments and build candidate$ as a list of argument types do 'is_statement allows ) to appear in statements, whereas it terminates a function if ps_is_terminator(tok_token) or (not is_statement and tok_token = TOK_CPAREN) then exit do select case tok_token case TOK_COMMA ps_consume TOK_COMMA ps_funcarg root, candidate$, suppress_comma case else ps_funcarg root, candidate$, suppress_comma end select $if DEBUG_PARSE_TRACE then debuginfo "Candidate is now " + type_human_sig$(candidate$) $end if loop 'candidate$ may match multiple sigs; decide which fits "best". See type.bm for 'details on what "best" means. This may still fail because the candidate has only 'been checked as a prefix, never for an exect match on the number of arguments. best_sig = type_find_sig_match(ast_nodes(root).ref, candidate$) if best_sig = 0 then ps_error "Cannot find matching type signature" ast_nodes(root).ref2 = best_sig 'Modify argument nodes to add in casts where needed for i = 1 to ast_num_children(root) expr = ast_get_child(root, i) expr_type = type_of_expr(expr) 'The skip value allows us to skip over token that are in the sig but don't 'get a corresponding ast node. do while not type_sig_concrete_arg(best_sig, i + skip) skip = skip + 1 loop if i + skip > type_sig_numargs(best_sig) then exit for arg_type = type_sig_argtype(best_sig, i + skip) if not (expr_type = arg_type or _ expr_type = TYPE_NONE or _ expr_type = TYPE_FLAGS) then ast_replace_child root, i, ast_add_cast(expr, arg_type) end if next i 'Add any optional arguments at end for i = ast_num_children(root) + 1 to type_sig_numargs_concrete(best_sig) ast_attach root, ast_add_node(AST_NONE) next i $if DEBUG_PARSE_TRACE then debuginfo "Completed funcargs" $end if end sub sub ps_funcarg(root, candidate$, suppress_comma) $if DEBUG_PARSE_TRACE then debuginfo "Start funcarg" $end if func = ast_nodes(root).ref expects$ = type_sig_prefix_nexts$(func, candidate$, 0) suppress_comma = FALSE 'Step 1: Check if any tokens or contextual arguments are present for i = 1 to type_sigt_numargs(expects$) expected_type = type_sigt_argtype(expects$, i) expected_flags = type_sigt_argflags(expects$, i) if (expected_flags AND TYPE_TOKEN) > 0 and expected_type = tok_token then 'We have found a literal token we were told to expect typ = expected_type flags = expected_flags if expected_flags AND TYPE_SYNTAX_ONLY then 'Don't generate any ast nodes, but add this to the candidate expr = 0 else 'We need to generate an AST_FLAGS for this expr = ast_add_node(AST_FLAGS) ast_nodes(expr).ref = AST_FLAG_TOKEN ast_nodes(expr).ref2 = typ end if tok_advance suppress_comma = TRUE goto arg_done elseif expected_flags AND TYPE_CONTEXTUAL then l = instr(ast_constants(expected_type), "|" + ucase$(tok_content$) + "|") ast_nodes(expr).ref2 = 0 if l then 'We have found a matching contextual argument typ = expected_type flags = expected_flags expr = ast_add_node(AST_FLAGS) ast_nodes(expr).ref = AST_FLAG_CONTEXTUAL do while l > 1 ast_nodes(expr).ref2 = ast_nodes(expr).ref2 + 1 l = _instrrev(l - 1, ast_constants(expected_type), "|") loop ast_nodes(expr).ref2 = ast_nodes(expr).ref2 + 1 tok_advance suppress_comma = TRUE goto arg_done end if end if next i 'Step 2: The file handle prefix (#) if ps_consumed(TOK_DOUBLE_SFX) then flags = TYPE_FILEHANDLE 'Step 3a: Try parse an expression if tok_token = TOK_COMMA then 'empty argument expr = ast_add_node(AST_NONE) flags = flags or TYPE_BYREF else expr = ps_expr if type_is_lvalue(expr) then flags = flags or TYPE_BYREF end if 'Step 3b: See if that expression fits type-wise typ = type_of_expr(expr) for i = 1 to type_sigt_numargs(expects$) expected_type = type_sigt_argtype(expects$, i) expected_flags = type_sigt_argflags(expects$, i) 'it's unclear if "or (expected_type = 0 and expected_flags = 0)" is needed in 'the below condition. if type_sig_compatible_arg(expected_type, expected_flags, typ, flags, 0) then ok = TRUE end if next i if not ok then ps_error "Bad argument type " + type_human_readable$(typ) arg_done: 'Step 4a: If the processed arg skipped some optional components, add those optional 'components as placeholders for i = 1 to type_sigt_flagval(flags) ast_attach root, ast_add_node(AST_NONE) next i 'Step 4b: Add ast node if any if expr then ast_attach root, expr 'Step 5: Like step 4 for for the candidate for i = 1 to type_sigt_flagval(flags) candidate$ = type_sigt_add_arg(candidate$, TYPE_NONE, 0) next i candidate$ = type_sigt_add_arg(candidate$, typ, flags) $if DEBUG_PARSE_TRACE then debuginfo "Completed funcarg" $end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'goto.bm - Parse rules for GOTO statement 'Expects: GOTO 'Results: token after line number function ps_goto ps_consume TOK_GOTO ps_goto = ps_goto_p end function 'Expects: line number 'Results: token after line number function ps_goto_p $if DEBUG_PARSE_TRACE then debuginfo "Start goto" $end if ps_assert TOK_NUMINT root = ast_add_node(AST_GOTO) id = symtab_get_id(tok_content$) if id > 0 and symtab(id).v2 = TRUE and symtab(id).v1 > 0 then 'Label exists, is resolved and is attached $if DEBUG_PARSE_TRACE then debuginfo "Goto resolves to" + str$(symtab(id).v1) $end if ast_nodes(root).ref = symtab(id).v1 elseif id > 0 then 'This case helps with things like "10 GOTO 10" (label resolved but not attached) $if DEBUG_PARSE_TRACE then debuginfo "Reference to pre-existing unresolved or unattached label" $end if ast_nodes(root).ref = id ps_unresolved_jumps$ = ps_unresolved_jumps$ + mkl$(root) else $if DEBUG_PARSE_TRACE then debuginfo "Unresolved goto" $end if dim symtab_label as symtab_entry_t symtab_label.identifier = tok_content$ symtab_label.typ = SYM_LABEL symtab_add_entry symtab_label 'Unresolved, so point directly to the label ast_nodes(root).ref = symtab_last_entry ps_unresolved_jumps$ = ps_unresolved_jumps$ + mkl$(root) end if ps_consume TOK_NUMINT ps_goto_p = root $if DEBUG_PARSE_TRACE then debuginfo "Completed goto" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'if.bm - Parse rules for IF statement 'Expects: IF 'Results: newline function ps_if $if DEBUG_PARSE_TRACE then debuginfo "Start conditional" $end if root = ast_add_node(AST_IF) ps_consume TOK_IF ps_add_nested_structure root condition = ps_expr if not type_is_number(type_of_expr(condition)) then ps_error "Condition must be a numeric expression" ast_attach root, condition ps_consume TOK_THEN 'A REM after THEN acts as a command; we remain in single-line if mode if ucase$(tok_content$) = "REM" then block = ast_add_node(AST_BLOCK) ast_attach root, block ps_remove_nested_structure ps_if = root $if DEBUG_PARSE_TRACE then debuginfo "Completed conditional (single-line REM)" $end if exit function end if if tok_token <> TOK_NEWLINE or ps_is_linejoin then $if DEBUG_PARSE_TRACE then debuginfo "Single-line IF" $end if ast_attach root, ps_if_stmts if tok_token = TOK_ELSE then ps_consume TOK_ELSE ast_attach root, ps_if_stmts end if else $if DEBUG_PARSE_TRACE then debuginfo "Multi-line IF" $end if ast_attach root, ps_block do while tok_token = TOK_ELSEIF ps_consume TOK_ELSEIF condition = ps_expr if not type_is_number(type_of_expr(condition)) then ps_error "Condition must be a numeric expression" ast_attach root, condition ps_consume TOK_THEN ast_attach root, ps_block loop if tok_token = TOK_ELSE then ps_consume TOK_ELSE ast_attach root, ps_block end if ps_consume TOK_END ps_consume TOK_IF end if ps_remove_nested_structure ps_if = root $if DEBUG_PARSE_TRACE then debuginfo "Completed conditional" $end if end function 'Expects: Start of a statement or : 'Results: ELSE or NEWLINE 'Note: This handles one or more statements joined by : and terminated by ELSE/NEWLINE, or an implicit GOTO function ps_if_stmts $if DEBUG_PARSE_TRACE then debuginfo "Start if stmts" $end if block = ast_add_node(AST_BLOCK) if tok_token = TOK_NUMINT then ast_attach block, ps_goto_p else do while ps_is_linejoin ps_consume TOK_NEWLINE wend stmt = ps_stmt ast_attach block, stmt while ps_is_linejoin ps_consume TOK_NEWLINE wend loop until ps_is_terminator(tok_token) end if ps_if_stmts = block $if DEBUG_PARSE_TRACE then debuginfo "Completed if stmts" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'input.bm - Parse rules for INPUT statement 'Expects: TOK_INPUT or TOK_LINEINPUT 'Results: token after input variables 'Format: INPUT[;]["prompt"{;|,}]variablelist 'or LINE INPUT[;]["prompt"{;|,}]variable$ function ps_stmt_input $if DEBUG_PARSE_TRACE then debuginfo "Start stmt input" $end if root = ast_add_node(AST_CALL) ast_nodes(root).ref = TOK_INPUT ast_nodes(root).ref2 = symtab(TOK_INPUT).v1 flags = ast_add_node(AST_FLAGS) ast_nodes(flags).ref = AST_FLAG_MANUAL ast_attach root, flags ast_nodes(flags).ref2 = 0 if ps_consumed(TOK_LINEINPUT) then ast_nodes(flags).ref2 = ast_nodes(flags).ref2 OR STMT_INPUT_LINEMODE linemode = TRUE end if ps_consume TOK_INPUT if ps_consumed(TOK_SEMICOLON) then ast_nodes(flags).ref2 = STMT_INPUT_NO_NEWLINE end if 'The prompt must be a literal string, no expressions. Crazy, right? if tok_token = TOK_STRINGLIT then prompt = ast_add_node(AST_CONSTANT) ast_nodes(prompt).ref = ast_add_constant(tok_token, tok_content$, TYPE_STRINGLIT) ast_nodes(flags).ref2 = ast_nodes(flags).ref2 OR STMT_INPUT_PROMPT ast_attach root, prompt ps_consume TOK_STRINGLIT if tok_token = TOK_COMMA then ast_nodes(flags).ref2 = ast_nodes(flags).ref2 OR STMT_INPUT_NO_QUESTION ps_consume TOK_COMMA else ps_consume TOK_SEMICOLON end if 'It turns out INPUT and LINE INPUT interpret the {;|,} with exactly opposite 'meaning if linemode then ast_nodes(flags).ref2 = ast_nodes(flags).ref2 XOR STMT_INPUT_NO_QUESTION end if end if if linemode then var = ps_lvalue_mutable if type_of_lvalue(var) <> TYPE_STRING then ps_error "Variable must be a string" ast_attach root, var else do var = ps_lvalue_mutable ast_attach root, var loop while ps_consumed(TOK_COMMA) end if ps_stmt_input = root $if DEBUG_PARSE_TRACE then debuginfo "Completed stmt input" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'labels.bm - Parse rule for labels and utility functions for handling them 'Expects: TOK_LINENUM 'Results: next token 'Note: this is for label definitions, not references sub ps_label $if DEBUG_PARSE_TRACE then debuginfo "Start label" $end if id = symtab_get_id(tok_content$) if id > 0 and symtab(id).typ <> SYM_LABEL then ps_error "Label name conflicts with existing identifier" elseif id > 0 and symtab(id).v2 = TRUE then ps_error "Label already defined" elseif id > 0 then 'This is a label that was only referenced until now; mark it found symtab(id).v2 = TRUE else dim symtab_label as symtab_entry_t symtab_label.identifier = tok_content$ symtab_label.typ = SYM_LABEL symtab_label.v2 = TRUE symtab_add_entry symtab_label id = symtab_last_entry end if ps_unattached_labels$ = ps_unattached_labels$ + mkl$(id) ps_consume TOK_LINENUM $if DEBUG_PARSE_TRACE then debuginfo "Completed label" $end if end sub 'There may have been 0 or more labels since the last statement that produced 'nodes (some non-executable statements may not produce nodes). This attaches 'those labels to a node. It also resolves any jumps to those labels to point 'to the node. sub ps_attach_labels(node) if node > 0 then for i = 1 to len(ps_unattached_labels$) step 4 label_id = cvl(mid$(ps_unattached_labels$, i, 4)) $if DEBUG_PARSE_TRACE then debuginfo "Attached label " + symtab(label_id).identifier $end if symtab(label_id).v1 = node 'Have we resolved an unresolved jump? for j = 1 to len(ps_unresolved_jumps$) step 4 unres_node = cvl(mid$(ps_unresolved_jumps$, j, 4)) if ast_nodes(unres_node).ref = label_id then ast_nodes(unres_node).ref = node else still_unres$ = still_unres$ + mkl$(unres_node) end if next j ps_unresolved_jumps$ = still_unres$ next i ps_unattached_labels$ = "" end if end sub 'Handles any labels not yet attached by the end of the program, because 'they're trailing empty lines or trailing non-executable statements. 'Also ensures all references point to an existent label. sub ps_finish_labels(block) if len(ps_unattached_labels$) > 0 then end_node = ast_add_node(AST_BLOCK) ast_attach block, end_node ps_attach_labels end_node end if if len(ps_unresolved_jumps$) then labels$ = symtab(ast_nodes(cvl(left$(ps_unresolved_jumps$, 4))).ref).identifier for i = 5 to len(ps_unresolved_jumps$) step 4 labels$ = ", " + symtab(ast_nodes(cvl(mid$(ps_unresolved_jumps$, i, 4))).ref).identifier next i ps_error "Undefined label(s): " + labels$ end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'loop.bm - Parse rules for DO LOOP and WHILE WEND 'Expects: WHILE 'Results: NEWLINE after WEND function ps_while $if DEBUG_PARSE_TRACE then debuginfo "Start WHILE loop" $end if root = ast_add_node(AST_WHILE) ps_add_nested_structure root ps_consume TOK_WHILE ast_attach root, ps_expr ps_consume TOK_NEWLINE ast_attach root, ps_block ps_consume TOK_WEND ps_remove_nested_structure ps_while = root $if DEBUG_PARSE_TRACE then debuginfo "Completed WHILE loop" $end if end function 'Expects: DO 'Results: NEWLINE after LOOP or condition function ps_do $if DEBUG_PARSE_TRACE then debuginfo "Start DO loop" $end if ps_consume TOK_DO if tok_token = TOK_WHILE or tok_token = TOK_UNTIL then ps_do = ps_do_pre else ps_do = ps_do_post $if DEBUG_PARSE_TRACE then debuginfo "Completed DO loop" $end if end function 'Expects: WHILE or UNTIL 'Results: NEWLINE after LOOP function ps_do_pre $if DEBUG_PARSE_TRACE then debuginfo "Start DO-pre loop" $end if root = ast_add_node(AST_DO_PRE) ps_add_nested_structure root if tok_token = TOK_UNTIL then ps_consume TOK_UNTIL 'Need to invert guard condition guard = ast_add_node(AST_CALL) ast_nodes(guard).ref = TOK_EQUALS sig$ = type_sigt_add_arg(type_sigt_add_arg(type_sigt_create$(TYPE_ANY), TYPE_INTEGER, 0), TYPE_INTEGER, 0) ast_nodes(guard).ref2 = type_find_sig_match(TOK_EQUALS, sig$) ast_attach guard, ps_expr f = ast_add_node(AST_CONSTANT) ast_nodes(f).ref = AST_FALSE ast_attach guard, f else ps_consume TOK_WHILE guard = ps_expr end if ast_attach root, guard ps_consume TOK_NEWLINE ast_attach root, ps_block ps_consume TOK_LOOP ps_remove_nested_structure ps_do_pre = root $if DEBUG_PARSE_TRACE then debuginfo "Completed DO-pre loop" $end if end function 'Expects: NEWLINE 'Results: NEWLINE after loop guard condition function ps_do_post $if DEBUG_PARSE_TRACE then debuginfo "Start DO-post loop" $end if ps_consume TOK_NEWLINE root = ast_add_node(AST_DO_POST) ps_add_nested_structure root block = ps_block ps_consume TOK_LOOP if tok_token = TOK_UNTIL then ps_consume TOK_UNTIL 'Need to invert guard condition guard = ast_add_node(AST_CALL) ast_nodes(guard).ref = TOK_EQUALS sig$ = type_sigt_add_arg(type_sigt_add_arg(type_sigt_create$(TYPE_ANY), TYPE_INTEGER, 0), TYPE_INTEGER, 0) ast_nodes(guard).ref2 = type_find_sig_match(TOK_EQUALS, sig$) ast_attach guard, ps_expr f = ast_add_node(AST_CONSTANT) ast_nodes(f).ref = AST_FALSE ast_attach guard, f elseif tok_token = TOK_WHILE then ps_consume TOK_WHILE guard = ps_expr else 'Infinite loop guard = ast_add_node(AST_CONSTANT) ast_nodes(guard).ref = AST_TRUE end if ast_attach root, guard ast_attach root, block ps_remove_nested_structure ps_do_post = root $if DEBUG_PARSE_TRACE then debuginfo "Completed DO-post loop" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'metacommands.bm - Process $metacommands in parser 'Expects: META_LIST 'Results: TOK_NEWLINE sub ps_meta_list ps_consume META_LIST category$ = "SYMTAB" if tok_token = TOK_METAPARAM then category$ = _trim$(ucase$(tok_content$)) ps_consume TOK_METAPARAM end if select case left$(category$, 1) case "S" 'SYMTAB symtab_dump case "F" 'FUNCTIONS type_dump_functions case "P" 'PROGRAM ast_dump_pretty AST_ENTRYPOINT, 0 dump_subprocedures case "C" 'CONSTANTS ast_dump_constants case else ps_error "$LIST [SFPC]" end select end sub 'Expects: META_DEBUG 'Results: TOK_NEWLINE sub ps_meta_debug ps_consume META_DEBUG action$ = "ON" if tok_token = TOK_METAPARAM then action$ = _trim$(ucase$(tok_content$)) ps_consume TOK_METAPARAM end if select case action$ case "ON" options.debug = TRUE case "OFF" options.debug = FALSE case else ps_error "$DEBUG [ON|OFF]" end select end sub 'Expects: META_INCLUDE 'Results: TOK_NEWLINE sub ps_meta_include $if DEBUG_PARSE_TRACE then debuginfo "Start $include" $end if if input_files(input_files_last).handle = 0 then 'No file is open, we must be in interactive mode or similar ps_error "Cannot include files in this mode" end if ps_consume META_INCLUDE if tok_token <> TOK_METAPARAM then ps_error "Filename required" filename$ = _trim$(tok_content$) tok_advance 'Consume file name if left$(filename$, 1) <> "'" or right$(filename$, 1) <> "'" then ps_error "Filename must be surrounded by single quotes" end if filename$ = mid$(filename$, 2, len(filename$) - 2) input_files_last = input_files_last + 1 if ubound(input_files) < input_files_last then redim _preserve input_files(input_files_last) as input_file_t end if input_files(input_files_last).handle = freefile input_files(input_files_last).filename = filename$ 'A relative path is relative to the location of the including file filename$ = locate_path$(filename$, input_files(input_files_last - 1).dirname) input_files(input_files_last).dirname = dirname$(filename$) open_file filename$, input_files(input_files_last).handle, FALSE $if DEBUG_PARSE_TRACE then debuginfo "Completed $include" $end if end sub 'Expects: META_OPTION 'Results: TOK_NEWLINE sub ps_meta_option $if DEBUG_PARSE_TRACE then debuginfo "Start $option" $end if ps_consume META_OPTION if tok_token <> TOK_METAPARAM then ps_error "Expected list of options" redim options(0) as string split ucase$(tok_content$), ",", options() for i = 0 to ubound(options) plus = TRUE if left$(options(i), 1) = "+" then plus = TRUE options(i) = mid$(options(i), 2) elseif left$(options(i), 1) = "-" then plus = FALSE options(i) = mid$(options(i), 2) end if select case _trim$(options(i)) case "_EXPLICIT", "EXPLICIT" ps_allow_implicit_vars = not plus case "_EXPLICITARRAY" 'Arrays are never allowed to be implicit so this is always in effect. 'Ignore silently for compatibility. case "OVERFLOW" imm_allow_overflow = plus case else ps_error "Unknown option " + options(i) end select next i tok_advance $if DEBUG_PARSE_TRACE then debuginfo "Completed $option" $end if end sub 'Expects: unknown metacommand 'Results: TOK_NEWLINE sub ps_meta_unknown $if DEBUG_PARSE_TRACE then debuginfo "Metacommand " + tok_content$ + " is unknown" $end if while tok_token <> TOK_NEWLINE tok_advance wend end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'option.bm - Parse rules for the OPTION statement 'Expects: TOK_OPTION 'Results: NEWLINE sub ps_stmt_option ps_consume TOK_OPTION if ps_consumed(TOK__EXPLICIT) then ps_allow_implicit_vars = FALSE elseif ps_consumed(TOK__EXPLICITARRAY) then 'Arrays are never allowed to be implicit so this is always in effect. 'Ignore silently for compatibility. else ps_error "Expected OPTION _EXPLICIT" end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'pratt.bm - Expression parser using the Pratt algorithm 'Expects: first token of expr 'Results: token after expression 'Note: the expression parser is greedy; it will only stop when it encounters ' a token that cannot possibly be part of an expression. function ps_expr $if DEBUG_PARSE_TRACE then debuginfo "Start expr" $end if ps_expr = pt_expr(0) $if DEBUG_PARSE_TRACE then debuginfo "Completed expr" $end if end function function pt_expr(rbp) t = tok_token content$ = tok_content$ tok_advance left_node = nud(t, content$) while rbp < lbp(tok_token, tok_content$) t = tok_token content$ = tok_content$ tok_advance left_node = led(t, content$, left_node) wend pt_expr = left_node end function 'tok_token is positioned one after whatever token is. 'ps_ functions called from here usually need to be specially written 'to take their first token as an argument instead of from tok_token. function nud(token, content$) select case token case TOK_NUMINT, TOK_NUMBASE, TOK_NUMDEC, TOK_NUMEXP, TOK_STRINGLIT node = ast_add_node(AST_CONSTANT) ast_nodes(node).ref = ast_add_constant(token, content$, ps_opt_sigil) case TOK_OPAREN node = pt_expr(0) ps_consume TOK_CPAREN case TOK_DASH 'Hardcoded hack to change TOK_DASH into TOK_NEGATIVE token = TOK_NEGATIVE goto negative_hack case TOK_UNKNOWN 'Implicit variable definitions node = ps_simple_variable_p(token, content$) case else negative_hack: select case symtab(token).typ case SYM_FUNCTION node = ps_funccall_p(token) case SYM_VARIABLE node = ps_lvalue_p(token, content$) case SYM_PREFIX node = ast_add_node(AST_CALL) ast_nodes(node).ref = token expr = pt_expr(symtab(token).v2) if type_is_lvalue(expr) then candidate_flags = TYPE_BYREF candidate$ = type_sigt_create$(TYPE_ANY) candidate$ = type_sigt_add_arg$(candidate$, type_of_expr(expr), flags) matching_sig = type_find_sig_match(token, candidate$) if matching_sig = 0 then ps_error "Cannot find matching type signature" ast_attach node, ast_add_cast(expr, type_sig_argtype(matching_sig, 1)) ast_nodes(node).ref2 = matching_sig case else ps_error "Unexpected " + tok_human_readable$(token) end select end select nud = node end function function lbp(token, content$) select case token case is < 0 ps_error "Unexpected literal " + content$ case TOK_CPAREN lbp = 0 case else select case symtab(token).typ case SYM_INFIX lbp = symtab(token).v2 case else 'We've hit something that isn't part if the expression, 'time to finish. lbp = 0 end select end select end function function led(token, content$, left_node) 'content$ is not used but might be useful one day. 'This next line stops the warning about unused variables. content$ = content$ node = ast_add_node(AST_CALL) ast_nodes(node).ref = token select case symtab(token).typ case SYM_INFIX if symtab(token).v3 = 0 then 'Left-associative right_node = pt_expr(symtab(token).v2) else 'right-associative right_node = pt_expr(symtab(token).v2 - 1) end if candidate$ = type_sigt_create$(TYPE_ANY) if type_is_lvalue(left_node) then candidate_flags = TYPE_BYREF candidate$ = type_sigt_add_arg$(candidate$, type_of_expr(left_node), flags) if type_is_lvalue(right_node) then candidate_flags = TYPE_BYREF candidate$ = type_sigt_add_arg$(candidate$, type_of_expr(right_node), flags) matching_sig = type_find_sig_match(token, candidate$) if matching_sig = 0 then ps_error "Cannot find matching type signature" ast_attach node, ast_add_cast(left_node, type_sig_argtype(matching_sig, 1)) ast_attach node, ast_add_cast(right_node, type_sig_argtype(matching_sig, 2)) ast_nodes(node).ref2 = matching_sig case else ps_error "Unexpected led " + tok_human_readable$(token) end select led = node end function sub ps_preload_file $if DEBUG_PARSE_TRACE then debuginfo "Start preload file" $end if ps_is_preload = TRUE do do while tok_token = TOK_NEWLINE ps_consume TOK_NEWLINE loop stmt = ps_stmt if stmt > 0 then ps_error "Preload cannot contain executable code in main program" if stmt = -1 then exit do loop ps_is_preload = FALSE $if DEBUG_PARSE_TRACE then debuginfo "Completed preload file" $end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'print.bm - Parse rules for PRINT statement 'Expects: TOK_PRINT 'Results: token after last expression, comma or semicolon 'Format: PRINT [expressionlist][{,|;}] function ps_print $if DEBUG_PARSE_TRACE then debuginfo "Start print" $end if root = ast_add_node(AST_CALL) ast_nodes(root).ref = TOK_PRINT ast_nodes(root).ref2 = symtab(TOK_PRINT).v1 ps_consume TOK_PRINT newline = TRUE do if ps_is_terminator(tok_token) then exit do select case tok_token case TOK_COMMA node = ast_add_node(AST_FLAGS) ast_nodes(node).ref = AST_FLAG_MANUAL ast_nodes(node).ref2 = PRINT_NEXT_FIELD ast_attach root, node ps_consume TOK_COMMA newline = FALSE case TOK_SEMICOLON 'No flags needed here ps_consume TOK_SEMICOLON newline = FALSE case else ast_attach root, ps_expr newline = TRUE end select loop if newline then node = ast_add_node(AST_FLAGS) ast_nodes(node).ref = AST_FLAG_MANUAL ast_nodes(node).ref2 = PRINT_NEWLINE ast_attach root, node end if ps_print = root $if DEBUG_PARSE_TRACE then debuginfo "Completed print" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'putimage.bm - Parse rules for _PUTIMAGE statement 'Expects: TOK__PUTIMAGE 'Results: NEWLINE 'Format: [[STEP] (single, single) [- [STEP] (single, single)]], [long], [long], [[STEP] (single, single) [- STEP (single, single)]] [, _SMOOTH] function ps__putimage $if DEBUG_PARSE_TRACE then debuginfo "Start _putimage" $end if root = ast_add_node(AST_CALL) ast_nodes(root).ref = TOK__PUTIMAGE ast_nodes(root).ref2 = symtab(TOK__PUTIMAGE).v1 ps_consume TOK__PUTIMAGE flag_node = ast_add_node(AST_FLAGS) ast_nodes(flag_node).ref = AST_FLAG_MANUAL ast_attach root, flag_node if ps_consumed(TOK_STEP) then flags = flags OR PUTIMAGE_STEP_SRC1 if ps_consumed(TOK_OPAREN) then ast_attach root, ps_expr ps_consume TOK_COMMA ast_attach root, ps_expr ps_consume TOK_CPAREN else ast_attach root, ast_add_node(AST_NONE) ast_attach root, ast_add_node(AST_NONE) end if if ps_consumed(TOK_DASH) then if ps_consumed(TOK_STEP) then flags = flags OR PUTIMAGE_STEP_SRC2 ps_consume TOK_OPAREN ast_attach root, ps_expr ps_consume TOK_COMMA ast_attach root, ps_expr ps_consume TOK_CPAREN else ast_attach root, ast_add_node(AST_NONE) ast_attach root, ast_add_node(AST_NONE) end if if not ps_consumed(TOK_COMMA) then goto putimage_parse_done if tok_token <> TOK_COMMA then ast_attach root, ps_expr else ast_attach root, ast_add_node(AST_NONE) if not ps_consumed(TOK_COMMA) then goto putimage_parse_done if tok_token <> TOK_COMMA then ast_attach root, ps_expr else ast_attach root, ast_add_node(AST_NONE) if not ps_consumed(TOK_COMMA) then goto putimage_parse_done if ps_consumed(TOK_STEP) then flags = flags OR PUTIMAGE_STEP_DEST1 if ps_consumed(TOK_OPAREN) then ast_attach root, ps_expr ps_consume TOK_COMMA ast_attach root, ps_expr ps_consume TOK_CPAREN else ast_attach root, ast_add_node(AST_NONE) ast_attach root, ast_add_node(AST_NONE) end if if ps_consumed(TOK_DASH) then if ps_consumed(TOK_STEP) then flags = flags OR PUTIMAGE_STEP_DEST2 ps_consume TOK_OPAREN ast_attach root, ps_expr ps_consume TOK_COMMA ast_attach root, ps_expr ps_consume TOK_CPAREN else ast_attach root, ast_add_node(AST_NONE) ast_attach root, ast_add_node(AST_NONE) end if if ps_consumed(TOK_COMMA) then ps_consume TOK__SMOOTH flags = flags OR PUTIMAGE_SMOOTH end if putimage_parse_done: ast_nodes(flag_node).ref2 = flags 'Fill in any missing arguments on the end for i = ast_num_children(root) + 1 to 11 ast_attach root, ast_add_node(AST_NONE) next i ps__putimage = root $if DEBUG_PARSE_TRACE then debuginfo "Completed _putimage" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'select.bm - Parse rules for SELECT CASE statement 'Expects: TOK_SELECT 'Results: NEWLINE function ps_select $if DEBUG_PARSE_TRACE then debuginfo "Start select" $end if root = ast_add_node(AST_SELECT) ps_consume TOK_SELECT ps_consume TOK_CASE expr = ps_expr ast_attach root, expr ps_add_nested_structure root ps_consume TOK_NEWLINE ps_line_prelude while not ps_consumed(TOK_END) ast_attach root, ps_select_case(type_of_expr(expr)) wend ps_consume TOK_SELECT ps_remove_nested_structure ps_select = root $if DEBUG_PARSE_TRACE then debuginfo "Completed select" $end if end function function ps_select_case(typ) $if DEBUG_PARSE_TRACE then debuginfo "Start select case" $end if ps_consume TOK_CASE if ps_consumed(TOK_ELSE) then node = ast_add_node(AST_SELECT_ELSE) else node = ast_add_node(AST_SELECT_LIST) do ast_attach node, ps_select_case_guard(typ) loop while ps_consumed(TOK_COMMA) end if ast_attach node, ps_block ps_select_case = node $if DEBUG_PARSE_TRACE then debuginfo "Completed select case" $end if end function function ps_select_case_guard(typ) $if DEBUG_PARSE_TRACE then debuginfo "Start select case guard" $end if if ps_consumed(TOK_IS) then node = ast_add_node(AST_SELECT_IS) ref = tok_token ref_typ = symtab(ref).typ if not (ref_typ = SYM_INFIX or ref_typ = SYM_PREFIX or ref_typ = SYM_FUNCTION) then ps_error "Not a function" end if tok_advance expr = ps_expr candidate$ = type_sigt_create$(TYPE_INTEGER) candidate$ = type_sigt_add_arg$(candidate$, typ, 0) candidate$ = type_sigt_add_arg$(candidate$, type_of_expr(expr), 0) sig = type_find_sig_match(ref, candidate$) if sig = 0 then ps_error "Bad function" ast_nodes(node).ref = ref ast_nodes(node).ref2 = sig value_node = ast_add_node(AST_SELECT_VALUE) ast_nodes(value_node).ref = typ ast_attach node, ast_add_cast(value_node, type_sig_argtype(sig, 1)) expr = ast_add_cast(expr, type_sig_argtype(sig, 2)) ast_attach node, expr else expr1 = ps_expr if ps_consumed(TOK_TO) then expr2 = ps_expr 'Lookup <= to confirm types are well-ordered. Note that we use <= for 'both bounds, which simplfied this code a little and allows future fancy 'stuff (custom orderings etc.) to only need to implement the one function. node = ast_add_node(AST_SELECT_RANGE) candidate$ = type_sigt_create$(TYPE_INTEGER) candidate$ = type_sigt_add_arg$(candidate$, type_of_expr(expr1), 0) candidate$ = type_sigt_add_arg$(candidate$, typ, 0) sig = type_find_sig_match(TOK_CMP_LTEQ, candidate$) if sig = 0 then ps_error "Bad function" if type_sig_argtype(sig, 1) <> type_sig_argtype(sig, 2) then 'The arguments need to have the same type so we can use it 'with reversed arguments too. ps_error "Function does not have exchangable argument types" end if ast_nodes(node).ref = TOK_CMP_LTEQ ast_nodes(node).ref2 = sig ast_attach node, expr1 ast_attach node, expr2 else 'Simple CASE x node = ast_add_node(AST_SELECT_IS) candidate$ = type_sigt_create$(TYPE_INTEGER) candidate$ = type_sigt_add_arg$(candidate$, typ, 0) candidate$ = type_sigt_add_arg$(candidate$, type_of_expr(expr1), 0) sig = type_find_sig_match(TOK_EQUALS, candidate$) if sig = 0 then ps_error "Cannot compare for equality" ast_nodes(node).ref = TOK_EQUALS ast_nodes(node).ref2 = sig value_node = ast_add_node(AST_SELECT_VALUE) ast_nodes(value_node).ref = typ ast_attach node, ast_add_cast(value_node, type_sig_argtype(sig, 1)) expr1 = ast_add_cast(expr1, type_sig_argtype(sig, 2)) ast_attach node, expr1 end if end if ps_select_case_guard = node $if DEBUG_PARSE_TRACE then debuginfo "Completed select case guard" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'statement.bm - Parse rules for statements 'Expects: first token of statement 'Results: NEWLINE or block end marker 'Returns: ' -2 -> a SUB or FUNCTION was defined (useful for interactive mode to know) ' -1 -> end of a block ' 0 -> statement did not generate any ast nodes ' > 0 -> ast node function ps_stmt ps_line_prelude if tok_token = TOK_LINENUM then ps_label $if DEBUG_PARSE_TRACE then debuginfo "Start statement" $end if 'Sigh if tok_token = TOK_LINE and ucase$(tok_next_content$) = "INPUT" then tok_token = TOK_LINEINPUT select case tok_token case is < 0 ps_error "Unexpected literal " + tok_content$ case META_LIST ps_meta_list case META_DEBUG ps_meta_debug case META_INCLUDE ps_meta_include case META_OPTION ps_meta_option case META_UNKNOWN ps_meta_unknown case TOK_CALL stmt = ps_call case TOK_CONST stmt = ps_const case TOK_DECLARE stmt = ps_declare case TOK__DEFINE ps_define_type case TOK_DEFINT, TOK_DEFLNG, TOK_DEFSNG, TOK_DEFDBL, TOK_DEFSTR ps_deftype case TOK_DIM, TOK_REDIM, TOK_STATIC 'REDIM is treated as an alias for DIM. 'STATIC is so similar we handle it here too. stmt = ps_dim case TOK_DO stmt = ps_do case TOK_EXIT stmt = ps_exit case TOK_FOR stmt = ps_for case TOK_FUNCTION stmt = ps_userfunc case TOK_GOTO stmt = ps_goto case TOK_IF stmt = ps_if case TOK_INPUT, TOK_LINEINPUT 'These two are so similar, we parse them as the same function stmt = ps_stmt_input case TOK_OPTION ps_stmt_option case TOK_PRINT stmt = ps_print case TOK__PUTIMAGE stmt = ps__putimage case TOK_SELECT stmt = ps_select case TOK_SUB stmt = ps_userfunc case TOK_TYPE 'For non-interactive modes a TYPE is processed in the prepass, so ignore 'it here if options.compile_mode or options.run_mode then ps_udt_ignore else stmt = ps_udt end if case TOK_WHILE stmt = ps_while case TOK_UNKNOWN stmt = ps_assignment case TOK_NEWLINE 'Blank line; ignore it stmt = 0 'These all end a block in some fashion. The block-specific code will assert the 'ending token, but we check it's syntactically valid here. case TOK_END 'We can't check tok_next_token because it does not always contain correct look-ahead information next_content$ = ucase$(tok_next_content$) nesting = ast_nodes(ps_final_nested).typ if next_content$ <> "IF" and _ next_content$ <> "SELECT" and _ next_content$ <> "SUB" and _ next_content$ <> "FUNCTION" then 'Handle regular END command stmt = ps_stmtreg elseif nesting <> AST_IF and nesting <> AST_SELECT and nesting <> AST_PROCEDURE then ps_error "Unexpected END" else stmt = -1 end if case TOK_ELSE, TOK_ELSEIF if ast_nodes(ps_final_nested).typ <> AST_IF then ps_error tok_human_readable$(tok_token) + " without IF" stmt = -1 case TOK_LOOP if ast_nodes(ps_final_nested).typ <> AST_DO_PRE and ast_nodes(ps_final_nested).typ <> AST_DO_POST then ps_error "LOOP without DO" stmt = -1 case TOK_WEND if ast_nodes(ps_final_nested).typ <> AST_WHILE then ps_error "WEND without WHILE" stmt = -1 case TOK_NEXT if ast_nodes(ps_final_nested).typ <> AST_FOR then ps_error "NEXT without FOR" stmt = -1 case TOK_CASE if ast_nodes(ps_final_nested).typ <> AST_SELECT then ps_error "CASE without SELECT" stmt = -1 case TOK_IEOF if ps_final_nested <> 0 then ps_error "Unexpected end of file" stmt = -1 case else select case symtab(tok_token).typ case SYM_VARIABLE stmt = ps_assignment case SYM_FUNCTION stmt = ps_stmtreg case else ps_error tok_human_readable$(tok_token) + " (" + tok_content$ + ") doesn't belong here" end select end select ps_attach_labels stmt ps_stmt = stmt $if DEBUG_PARSE_TRACE then debuginfo "Completed statement" $end if end function 'Expects: statement token 'Results: token after last argument function ps_stmtreg $if DEBUG_PARSE_TRACE then debuginfo "Start stmtreg" $end if 'Is this in fact assigning the return value of a function? root = ps_func_return if root = 0 then 'Nope, it's just a statement root = ast_add_node(AST_CALL) ast_nodes(root).ref = tok_token tok_advance 'TYPE_NONE to indicate we have no return value ps_funcargs root, type_sigt_create$(TYPE_NONE), TRUE end if ps_stmtreg = root $if DEBUG_PARSE_TRACE then debuginfo "Completed stmtreg" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'tokeng.bm - Tokeniser Engine deflng a-z sub tok_init $if DEBUG_TIMINGS then debug_timing_mark# = timer(0.001) $end if 'Read in the state machine for the lexer restore tokeng_data for s = 1 to ubound(t_states~%, 2) read t_statenames$(s) for b = 1 to 127 read cmd t_states~%(b, s) = cmd next b next s 'Populate token and type signature data 'TODO check if this impacts startup times dim sym as symtab_entry_t sym.typ = SYM_GENERIC sym.identifier = "|UNKNOWN" symtab_add_entry sym sym.identifier = "|IEOF" symtab_add_entry sym sym.identifier = "|EOI" symtab_add_entry sym sym.identifier = "|NEWLINE" symtab_add_entry sym tok_direct(TS_NEWLINE) = 4 sym.identifier = "|COMMA" symtab_add_entry sym tok_direct(TS_COMMA) = 5 sym.identifier = "|SEMICOLON" symtab_add_entry sym tok_direct(TS_SEMICOLON) = 6 sym.identifier = "." symtab_add_entry sym tok_direct(TS_DOT) = 7 sym.identifier = "REM" symtab_add_entry sym sym.identifier = "|LINENUM" symtab_add_entry sym sym.typ = SYM_META sym.identifier = "$LIST" symtab_add_entry sym sym.identifier = "$DEBUG" symtab_add_entry sym sym.identifier = "$INCLUDE" symtab_add_entry sym sym.identifier = "$OPTION" symtab_add_entry sym sym.identifier = "|$UNKNOWN" symtab_add_entry sym tok_direct(TS_METAPARAM) =-1 sym.typ = SYM_GENERIC sym.identifier = "|INTEGER_SFX" symtab_add_entry sym tok_direct(TS_INTEGER_SFX) = 15 sym.identifier = "|LONG_SFX" symtab_add_entry sym tok_direct(TS_LONG_SFX) = 16 sym.identifier = "|INTEGER64_SFX" symtab_add_entry sym tok_direct(TS_INTEGER64_SFX) = 17 sym.identifier = "|SINGLE_SFX" symtab_add_entry sym tok_direct(TS_SINGLE_SFX) = 18 sym.identifier = "|DOUBLE_SFX" symtab_add_entry sym tok_direct(TS_DOUBLE_SFX) = 19 sym.identifier = "|QUAD_SFX" symtab_add_entry sym tok_direct(TS_QUAD_SFX) = 20 sym.identifier = "|STRING_SFX" symtab_add_entry sym tok_direct(TS_STRING_SFX) = 21 sym.typ = SYM_TYPE sym.v1 = 1 sym.v2 = SYM_TYPE_INTERNAL sym.identifier = "|NONE" symtab_add_entry sym sym.identifier = "|LIST" symtab_add_entry sym sym.identifier = "|FLAGS" symtab_add_entry sym sym.identifier = "|ANY" symtab_add_entry sym sym.v1 = type_fixed_size(TYPE_ANY) * 0 sym.v2 = SYM_TYPE_ARRAY sym.v3 = TYPE_ANY sym.v4 = 0 sym.identifier = "|ANY_ARRAY" symtab_add_entry sym sym.typ = SYM_TYPE sym.v1 = 1 sym.v2 = SYM_TYPE_INTERNAL sym.identifier = "INTEGER" symtab_add_entry sym sym.identifier = "LONG" symtab_add_entry sym sym.identifier = "INTEGER64" symtab_add_entry sym sym.identifier = "SINGLE" symtab_add_entry sym sym.identifier = "DOUBLE" symtab_add_entry sym sym.identifier = "QUAD" symtab_add_entry sym sym.identifier = "STRING" symtab_add_entry sym sym.identifier = "CONTEXTUAL_ARGUMENT" symtab_add_entry sym sym.typ = SYM_GENERIC sym.identifier = "|OPAREN" symtab_add_entry sym tok_direct(TS_OPAREN) = 35 sym.identifier = "|CPAREN" symtab_add_entry sym tok_direct(TS_CPAREN) = 36 sym.identifier = "|OBRACKET" symtab_add_entry sym tok_direct(TS_OBRACKET) = 37 sym.identifier = "|CBRACKET" symtab_add_entry sym tok_direct(TS_CBRACKET) = 38 sym.identifier = "|OBRACE" symtab_add_entry sym tok_direct(TS_OBRACE) = 39 sym.identifier = "|CBRACE" symtab_add_entry sym tok_direct(TS_CBRACE) = 40 tok_direct(TS_NUMINT) =-2 tok_direct(TS_NUMDEC) =-3 tok_direct(TS_NUMEXP) =-4 tok_direct(TS_NUMBASE) =-5 tok_direct(TS_STRINGLIT) =-6 sym.typ = SYM_INFIX sym.v2 = 2 sym.v3 = 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "IMP" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v2 = 3 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "EQV" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v2 = 4 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "XOR" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v2 = 5 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "OR" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v2 = 6 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "AND" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.typ = SYM_PREFIX sym.v2 = 7 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "NOT" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.typ = SYM_INFIX sym.v2 = 8 sym.v3 = 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "=" symtab_add_entry sym tok_direct(TS_EQUALS) = 47 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 tok_direct(TS_EQUALS) = 47 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_EQUALS) = 47 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_EQUALS) = 47 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_EQUALS) = 47 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_EQUALS) = 47 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_EQUALS) = 47 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "<>" symtab_add_entry sym tok_direct(TS_CMP_NEQ) = 48 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 tok_direct(TS_CMP_NEQ) = 48 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_CMP_NEQ) = 48 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_CMP_NEQ) = 48 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_CMP_NEQ) = 48 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_CMP_NEQ) = 48 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_CMP_NEQ) = 48 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "<" symtab_add_entry sym tok_direct(TS_CMP_LT) = 49 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 tok_direct(TS_CMP_LT) = 49 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_CMP_LT) = 49 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_CMP_LT) = 49 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_CMP_LT) = 49 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_CMP_LT) = 49 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_CMP_LT) = 49 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = ">" symtab_add_entry sym tok_direct(TS_CMP_GT) = 50 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 tok_direct(TS_CMP_GT) = 50 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_CMP_GT) = 50 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_CMP_GT) = 50 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_CMP_GT) = 50 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_CMP_GT) = 50 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_CMP_GT) = 50 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "<=" symtab_add_entry sym tok_direct(TS_CMP_LTEQ) = 51 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 tok_direct(TS_CMP_LTEQ) = 51 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_CMP_LTEQ) = 51 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_CMP_LTEQ) = 51 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_CMP_LTEQ) = 51 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_CMP_LTEQ) = 51 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_CMP_LTEQ) = 51 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = ">=" symtab_add_entry sym tok_direct(TS_CMP_GTEQ) = 52 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 tok_direct(TS_CMP_GTEQ) = 52 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_CMP_GTEQ) = 52 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_CMP_GTEQ) = 52 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_CMP_GTEQ) = 52 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_CMP_GTEQ) = 52 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_CMP_GTEQ) = 52 sym.v2 = 9 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "+" symtab_add_entry sym tok_direct(TS_PLUS) = 53 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 tok_direct(TS_PLUS) = 53 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_PLUS) = 53 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_PLUS) = 53 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_PLUS) = 53 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_PLUS) = 53 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_PLUS) = 53 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "-" symtab_add_entry sym tok_direct(TS_DASH) = 54 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_DASH) = 54 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_DASH) = 54 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_DASH) = 54 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_DASH) = 54 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_DASH) = 54 sym.v2 = 10 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "MOD" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v2 = 11 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "\" symtab_add_entry sym tok_direct(TS_BACKSLASH) = 56 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_BACKSLASH) = 56 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_BACKSLASH) = 56 sym.v2 = 12 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "*" symtab_add_entry sym tok_direct(TS_STAR) = 57 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 tok_direct(TS_STAR) = 57 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 tok_direct(TS_STAR) = 57 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 tok_direct(TS_STAR) = 57 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_STAR) = 57 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_STAR) = 57 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "/" symtab_add_entry sym tok_direct(TS_SLASH) = 58 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_SLASH) = 58 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_SLASH) = 58 sym.typ = SYM_PREFIX sym.v2 = 13 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "|NEGATIVE" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.typ = SYM_INFIX sym.v2 = 14 sym.v3 = 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "^" symtab_add_entry sym tok_direct(TS_POWER) = 60 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 tok_direct(TS_POWER) = 60 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 tok_direct(TS_POWER) = 60 sym.typ = SYM_GENERIC sym.identifier = "AS" symtab_add_entry sym sym.identifier = "CONST" symtab_add_entry sym sym.identifier = "GOTO" symtab_add_entry sym sym.identifier = "EXIT" symtab_add_entry sym sym.identifier = "IF" symtab_add_entry sym sym.identifier = "THEN" symtab_add_entry sym sym.identifier = "ELSE" symtab_add_entry sym sym.identifier = "ELSEIF" symtab_add_entry sym sym.identifier = "DO" symtab_add_entry sym sym.identifier = "LOOP" symtab_add_entry sym sym.identifier = "UNTIL" symtab_add_entry sym sym.identifier = "WHILE" symtab_add_entry sym sym.identifier = "WEND" symtab_add_entry sym sym.identifier = "FOR" symtab_add_entry sym sym.identifier = "TO" symtab_add_entry sym sym.identifier = "STEP" symtab_add_entry sym sym.identifier = "NEXT" symtab_add_entry sym sym.identifier = "SELECT" symtab_add_entry sym sym.identifier = "CASE" symtab_add_entry sym sym.identifier = "IS" symtab_add_entry sym sym.identifier = "TYPE" symtab_add_entry sym sym.identifier = "SUB" symtab_add_entry sym sym.identifier = "FUNCTION" symtab_add_entry sym sym.identifier = "DECLARE" symtab_add_entry sym sym.identifier = "REDIM" symtab_add_entry sym sym.identifier = "SHARED" symtab_add_entry sym sym.identifier = "_PRESERVE" symtab_add_entry sym sym.identifier = "STATIC" symtab_add_entry sym sym.identifier = "_EXPLICIT" symtab_add_entry sym sym.identifier = "_EXPLICITARRAY" symtab_add_entry sym sym.identifier = "BYREF" symtab_add_entry sym sym.identifier = "BYVAL" symtab_add_entry sym sym.identifier = "CALL" symtab_add_entry sym sym.typ = SYM_FUNCTION sym.v2 = SYM_FUNCTION_INTRINSIC sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "ABS" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 sym.identifier = "ASC" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "_ATAN2" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "ATN" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) sym.identifier = "_AUTODISPLAY" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) sym.identifier = "BEEP" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "_BLUE32" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.identifier = "CDBL" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "CHDIR" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "CHR" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "CINT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TOK_STEP, 17 type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_LONG, 1 type_sig_add_arg sym.v1, TYPE_SINGLE, 1 type_sig_add_arg sym.v1, TYPE_SINGLE, 1 type_sig_add_arg sym.v1, TYPE_SINGLE, 1 sym.identifier = "CIRCLE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "CLNG" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 9 sym.identifier = "CLOSE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_INTEGER, 1 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "CLS" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 1 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "COLOR" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_INTEGER, 1 sym.identifier = "COMMAND" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) sym.identifier = "_COMMANDCOUNT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "COS" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "CSNG" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) sym.identifier = "CSRLIN" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "CVD" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "CVDMBF" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "CVI" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "CVL" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "CVS" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "CVSMBF" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) sym.identifier = "DATE" symtab_add_entry sym sym.typ = SYM_GENERIC sym.identifier = "_DEFINE" symtab_add_entry sym sym.identifier = "DEFINT" symtab_add_entry sym sym.identifier = "DEFLNG" symtab_add_entry sym sym.identifier = "DEFSNG" symtab_add_entry sym sym.identifier = "DEFDBL" symtab_add_entry sym sym.identifier = "DEFSTR" symtab_add_entry sym sym.typ = SYM_FUNCTION sym.v2 = SYM_FUNCTION_INTRINSIC sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "_DEFLATE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "_DELAY" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "_DEST" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_ANY_ARRAY, 0 sym.identifier = "DIM" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) sym.identifier = "_DISPLAY" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "DRAW" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_INTEGER, 1 sym.identifier = "END" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "ENVIRON" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "EOF" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_ANY_ARRAY, 2 sym.identifier = "ERASE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "EXP" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_STRING, 1 sym.identifier = "FILES" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "FIX" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_FONTHEIGHT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_FONTWIDTH" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) sym.identifier = "FREEFILE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_STRING, 3 sym.identifier = "GET" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 3 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_LONG, 3 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_INTEGER64, 3 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_SINGLE, 3 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_DOUBLE, 3 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_QUAD, 3 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TOK_STEP, 17 type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TOK_DASH, 48 type_sig_add_arg sym.v1, TOK_STEP, 17 type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TYPE_ANY_ARRAY, 2 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "_GREEN32" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_HEIGHT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.identifier = "HEX" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "_INFLATE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) sym.identifier = "INKEY" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LIST, 0 sym.identifier = "INPUT" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_LONG, 9 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "INSTR" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "INT" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) sym.identifier = "_KEYCLEAR" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "_KEYDOWN" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) sym.identifier = "_KEYHIT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "KILL" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_ANY_ARRAY, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 sym.identifier = "LBOUND" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "LCASE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.identifier = "LEFT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "LEN" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER, 2 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_LONG, 2 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 2 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_SINGLE, 2 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 2 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_QUAD, 2 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "_LIMIT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TOK_DASH, 48 type_sig_add_arg sym.v1, TOK_STEP, 17 type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1,ast_add_constant(TOK_CONTEXTUAL_ARGUMENT,"B|BF",0), 65 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "LINE" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TOK_STEP, 17 type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TOK_DASH, 48 type_sig_add_arg sym.v1, TOK_STEP, 17 type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1,ast_add_constant(TOK_CONTEXTUAL_ARGUMENT,"B|BF",0), 65 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.typ = SYM_GENERIC sym.identifier = "LINEINPUT" symtab_add_entry sym sym.typ = SYM_FUNCTION sym.v2 = SYM_FUNCTION_INTRINSIC sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_LOADIMAGE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_INTEGER, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 sym.identifier = "LOCATE" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_INTEGER, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_LONG, 8 sym.identifier = "LOF" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "LOG" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "LTRIM" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 sym.identifier = "MID" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "_MOUSEBUTTON" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) sym.identifier = "_MOUSEINPUT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) sym.identifier = "_MOUSEMOVEMENTX" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) sym.identifier = "_MOUSEMOVEMENTY" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) sym.identifier = "_MOUSEWHEEL" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) sym.identifier = "_MOUSEX" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) sym.identifier = "_MOUSEY" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_NEWIMAGE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TOK_FOR, 48 type_sig_add_arg sym.v1,ast_add_constant(TOK_CONTEXTUAL_ARGUMENT,"RANDOM|INPUT|OUTPUT|BINARY|APPEND",0), 64 type_sig_add_arg sym.v1, TOK_AS, 48 type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TOK_LEN, 49 type_sig_add_arg sym.v1, TOK_EQUALS, 49 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "OPEN" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_ANY, 2 sym.identifier = "OPTION" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TOK_STEP, 17 type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "PAINT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 1 sym.identifier = "_PI" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "PLAY" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "POINT" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LIST, 0 sym.identifier = "PRINT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_PRINTSTRING" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_PRINTWIDTH" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TOK_STEP, 17 type_sig_add_arg sym.v1, TOK_OPAREN, 48 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TOK_CPAREN, 48 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "PSET" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_STRING, 1 sym.identifier = "PUT" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_SINGLE, 1 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_DOUBLE, 1 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 8 type_sig_add_arg sym.v1, TYPE_INTEGER64, 1 type_sig_add_arg sym.v1, TYPE_QUAD, 1 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_FLAGS, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "_PUTIMAGE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 1 sym.identifier = "RANDOMIZE" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TOK_USING, 16 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "_RED32" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_RGB" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "_RGB32" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.identifier = "RIGHT" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "RMDIR" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 1 sym.identifier = "RND" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "RTRIM" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 sym.identifier = "SCREEN" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "SGN" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "SIN" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "SLEEP" symtab_add_entry sym sym.typ = SYM_GENERIC sym.identifier = "_SMOOTH" symtab_add_entry sym sym.typ = SYM_FUNCTION sym.v2 = SYM_FUNCTION_INTRINSIC sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.identifier = "SOUND" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "_SOURCE" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_LONG)) sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.identifier = "SPACE" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "SQR" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_INTEGER, 0 sym.identifier = "STR" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_LONG, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_INTEGER64, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "_STRCMP" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER)) type_sig_add_arg sym.v1, TYPE_STRING, 0 type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "_STRICMP" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_ANY, 2 type_sig_add_arg sym.v1, TYPE_ANY, 2 sym.identifier = "SWAP" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_INTEGER, 1 sym.identifier = "SYSTEM" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_SINGLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 0 sym.identifier = "TAN" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_DOUBLE, 0 sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_QUAD, 0 sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) sym.identifier = "TIME" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_DOUBLE)) type_sig_add_arg sym.v1, TYPE_SINGLE, 1 sym.identifier = "TIMER" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_NONE)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "_TITLE" symtab_add_entry sym sym.v1 = type_add_sig(sym.v1, type_sigt_create$(TYPE_STRING)) sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "_TRIM" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_INTEGER64)) type_sig_add_arg sym.v1, TYPE_ANY_ARRAY, 0 type_sig_add_arg sym.v1, TYPE_INTEGER, 1 sym.identifier = "UBOUND" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_STRING)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "UCASE" symtab_add_entry sym sym.typ = SYM_GENERIC sym.identifier = "USING" symtab_add_entry sym sym.typ = SYM_FUNCTION sym.v2 = SYM_FUNCTION_INTRINSIC sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_QUAD)) type_sig_add_arg sym.v1, TYPE_STRING, 0 sym.identifier = "VAL" symtab_add_entry sym sym.v1 = type_add_sig(0, type_sigt_create$(TYPE_LONG)) type_sig_add_arg sym.v1, TYPE_LONG, 1 sym.identifier = "_WIDTH" symtab_add_entry sym ast_commit tokeng_data: DATA "Begin",0,0,0,0,0,0,0,0,257,259,257,257,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,257,0,0,0,1280,0,0,1024,0,0,0,0,0,0,0,0,768,768,768,768,768,768,768,768,768,768,0,0,0,0,0,1538,0,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,0,0,0,0,512,0,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,0,0,0,0,0 DATA "Id",0,0,0,0,0,0,0,0,1666,386,1666,1666,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1666,1666,1666,1666,1666,1666,1666,1154,1666,1666,1666,1666,1666,1666,1666,1666,512,512,512,512,512,512,512,512,512,512,1666,1666,1666,1666,1666,1666,0,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,1666,1666,1666,1666,512,0,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,1666,0,1666,1666,0 DATA "Linenum",0,0,0,0,0,0,0,0,1668,388,1668,1668,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1668,0,0,0,0,0,0,1156,0,0,0,0,0,0,0,0,768,768,768,768,768,768,768,768,768,768,1540,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA "Comment",1024,1024,1024,1024,1024,1024,1024,1024,1024,259,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024 DATA "Metacmd",0,0,0,0,0,0,0,0,1925,389,1925,1925,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1925,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1925,0,0,0,0,0,0,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,0,0,0,0,1280,0,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,0,0,0,0,0 DATA "General",0,0,0,0,0,0,0,0,1537,259,1537,1537,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1537,1544,2304,2816,1545,3072,3328,259,1548,1549,1547,1555,1560,1554,4096,1561,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,1558,1559,3584,1556,3840,1538,0,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,1550,1557,1551,1546,512,0,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,1552,0,1553,0,0 DATA "Metagap",2048,2048,2048,2048,2048,2048,2048,2048,2049,2048,2049,2049,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2049,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2049,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048 DATA "Metaparam",2048,2048,2048,2048,2048,2048,2048,2048,2048,390,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048,2048 DATA "String",2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,1543,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304 DATA "Number",1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,4352,1690,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,4608,4608,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,4608,4608,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690,1690 DATA "HashPfx",1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1568,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695,1695 DATA "PercentPfx",1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1566,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693,1693 DATA "AmpersandPfx",1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1570,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,5120,1697,1697,1697,1697,1697,5120,1697,1697,1697,1697,1697,1697,5120,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,5120,1697,1697,1697,1697,1697,5120,1697,1697,1697,1697,1697,1697,5120,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697,1697 DATA "LtPfx",1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1573,1574,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700,1700 DATA "GtPfx",1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1576,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703,1703 DATA "Dot",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4352,4352,4352,4352,4352,4352,4352,4352,4352,4352,0,0,0,0,0,0,0,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,0,0,0,0,1705,0,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,1705,0,0,0,0,0 DATA "NumDec",1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,4352,4352,4352,4352,4352,4352,4352,4352,4352,4352,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,4608,4608,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,4608,4608,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691,1691 DATA "NumExpSgn",1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,4864,1692,4864,1692,1692,4864,4864,4864,4864,4864,4864,4864,4864,4864,4864,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692 DATA "NumExp",1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,4864,4864,4864,4864,4864,4864,4864,4864,4864,4864,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692,1692 DATA "NumBase",1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,5120,5120,5120,5120,5120,5120,5120,5120,5120,5120,1699,1699,1699,1699,1699,1699,1699,5120,5120,5120,5120,5120,5120,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,5120,5120,5120,5120,5120,5120,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699,1699 tok_reinit $if DEBUG_TIMINGS then debuginfo "Parser init time:" + str$(timer(0.001) - debug_timing_mark#) $end if end sub sub tok_reinit tokeng_state.index = 1 tokeng_state.curstate = 1 tokeng_state.has_data = FALSE tokeng_state.linestart = TRUE tokeng_state.recovery_mode = FALSE 'Fill the 'next' buffer and propagate to tok_token tok_read_next_token tok_advance end sub sub tok_advance 'We defer symbol table lookups to now (instead of in tok_read_next_token) so 'we can correctly find any recently declared symbols. 'Also avoid ever doing lookups in recovery mode, because results are likely 'garbage. if tok_next_token = 0 and not tokeng_state.recovery_mode then 'First check local scope id = symtab_get_id(ucase$(ps_scope$ + tok_next_content$)) 'Then check global scope if id = 0 then id = symtab_get_id(ucase$(tok_next_content$)) 'Did we find anything? if id = 0 then tok_token = TOK_UNKNOWN else tok_token = id end if else tok_token = tok_next_token end if tok_content$ = tok_next_content$ if not options.interactive_mode then tok_read_next_token else if tok_token = TOK_NEWLINE and tok_content$ <> ":" then 'All lines end with TOK_EOI tok_next_token = TOK_EOI elseif tok_token = TOK_EOI then 'No line starts with TOK_NEWLINE do tok_read_next_token loop while tok_next_token = TOK_NEWLINE and tok_content$ <> ":" else tok_read_next_token end if end if $if DEBUG_TOKEN_STREAM then debuginfo ">>> " + tok_content$ $end if end sub 'Advance token stream until reaching end_marker, but do no processing of 'incoming data. Used to recover from errors. Results in tok_token = end_marker. sub tok_recover(end_marker) tokeng_state.recovery_mode = TRUE do until tok_token = end_marker tok_advance loop tokeng_state.recovery_mode = FALSE end sub sub tok_read_next_token if not tokeng_state.has_data then if general_eof then tok_next_token = TOK_IEOF exit function end if tokeng_state.index = 1 tokeng_state.raw_line_in = general_next_line$ tokeng_state.has_data = TRUE end if tok_next_content$ = tok_next_ts$(tokeng_state.raw_line_in + chr$(10), ts_type) select case ts_type case 0 'Out of data (an error) ps_error "Unexpected end of line" case TS_ID 'Special cases! if tok_next_content$ = "?" then tok_next_content$ = "PRINT" elseif ucase$(tok_next_content$) = "REM" then goto rem_hack end if tokeng_state.linestart = FALSE 'tok_next_token is not properly set here; see comments in tok_advance tok_next_token = 0 case TS_METACMD tok_next_token = symtab_get_id(ucase$(tok_next_content$)) if tok_next_token = 0 then tok_next_token = META_UNKNOWN case TS_LINENUM if not tokeng_state.linestart then ps_error "Line number must be at start of line" tok_next_token = TOK_LINENUM tokeng_state.linestart = FALSE case TS_COLON tok_next_token = TOK_NEWLINE tokeng_state.linestart = FALSE case TS_NEWLINE rem_hack: tokeng_state.has_data = FALSE tokeng_state.linestart = TRUE tok_next_token = TOK_NEWLINE case else if tok_direct(ts_type) then tok_next_token = tok_direct(ts_type) else ps_error "Unhandled TS" + str$(ts_type) end if tokeng_state.linestart = FALSE end select end function function tok_next_ts$(text$, ts_type) if tokeng_state.index > len(text$) then 'Out of data ts_type = 0 exit function end if for i = tokeng_state.index to len(text$) c = asc(text$, i) 'No utf-8 support for now if c > 127 then ps_error "Character outside character set (" + ltrim$(str$(c)) + ")" command = t_states~%(c, tokeng_state.curstate) 'Rules of the form "A: B ~ Error" encode to 0 if command = 0 then 'As an affordance to interactive mode, skip over the bad character so we don't get caught in an 'infinite loop when we restart after error tokeng_state.index = i + 1 ps_error chr$(34) + chr$(c) + chr$(34) + " from " + t_statenames$(tokeng_state.curstate) + " illegal" end if 'High byte is next state, low byte is token, high bit of low byte is pushback flag ts_type_internal = command and 127 pushback = command and 128 'print t_statenames$(tokeng_state.curstate); ":"; c; "~ "; tokeng_state.curstate = command \ 2^8 'print t_statenames$(tokeng_state.curstate) if ts_type_internal > 0 then ts_type = ts_type_internal if pushback then 'This doesn't include the current character, and uses it next time... if ts_type <> 1 then tok_next_ts$ = mid$(text$, tokeng_state.index, i - tokeng_state.index) tokeng_state.index = i else '...but this does include it, and starts from the next character next time. if ts_type <> 1 then tok_next_ts$ = mid$(text$, tokeng_state.index, i - tokeng_state.index + 1) tokeng_state.index = i + 1 end if if ts_type <> TS_SKIP then exit function end if next i ts_type = 0 end function function tok_human_readable$(token) if token > 0 then tok_human_readable$ = symtab(token).identifier else tok_human_readable$ = "LITERAL_" + mid$(str$(token), 2) end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'udt.bm - Parser for user-defined types 'Expects: TOK_TYPE 'Results: token after END TYPE sub ps_udt_ignore $if DEBUG_PARSE_TRACE then debuginfo "Start ignored UDT" $end if ps_consume TOK_TYPE tok_advance 'type name if ps_consumed(TOK_NEWLINE) then ps_line_prelude do dummy = ps_opt_sigil do tok_advance 'field name dummy = ps_opt_sigil loop while ps_consumed(TOK_COMMA) if ps_consumed(TOK_NEWLINE) then ps_line_prelude loop until ps_consumed(TOK_END) ps_consume TOK_TYPE $if DEBUG_PARSE_TRACE then debuginfo "Completed ignored UDT" $end if end sub 'Expects: TOK_TYPE 'Results: token after END TYPE function ps_udt $if DEBUG_PARSE_TRACE then debuginfo "Start UDT definition" $end if dim udt_sym as symtab_entry_t udt_sym.typ = SYM_TYPE udt_sym.v1 = 0 udt_sym.v2 = SYM_TYPE_UDT ps_consume TOK_TYPE if tok_token <> TOK_UNKNOWN then ps_error "UDT name already in use" udt_sym.identifier = ucase$(tok_content$) tok_advance if ps_consumed(TOK_NEWLINE) then ps_line_prelude do 'Handle As Long X style definitions typ = ps_opt_sigil do elem = ps_udt_element(udt_sym, typ) udt_sym.v1 = udt_sym.v1 + type_fixed_size(symtab(elem).v1) loop while ps_consumed(TOK_COMMA) 'If we ever need to keep a list of all the elements in a UDT, 'this is where we'd build it. if ps_consumed(TOK_NEWLINE) then ps_line_prelude loop until ps_consumed(TOK_END) ps_consume TOK_TYPE symtab_add_entry udt_sym ps_udt = 0 'Never generate any ast nodes $if DEBUG_PARSE_TRACE then debuginfo "End UDT definition" $end if end function 'Expects: Element identifier 'Results: token after variable (comma or newline) function ps_udt_element(udt_sym as symtab_entry_t, pre_typ) $if DEBUG_PARSE_TRACE then debuginfo "Start UDT element" $end if dim elem_sym as symtab_entry_t elem_sym.typ = SYM_UDT_ELEMENT 'Because UDT element names appear in such a restricted environment, 'they can live in their own namespace without conflicting with 'existing symbols. We just require that the name be an alphanumeric 'identifier. elem_name$ = ucase$(tok_content$) select case left$(elem_name$, 1) case "A" to "Z", "_" case else print tok_content$ ps_error "Invalid UDT element name" end select for i = 2 to len(elem_name$) select case mid$(elem_name$, i, 1) case "A" to "Z", "0" to "9", "_" case else ps_error "Invalid UDT element name" end select next i elem_sym.identifier = udt_sym.identifier + "." + elem_name$ tok_advance 'Set type from sigil, AS clause or default type sigil = ps_opt_sigil if pre_typ > 0 and sigil > 0 and pre_typ <> sigil then ps_error "Declared type does not match" end if if sigil = 0 then sigil = pre_typ if sigil = 0 then elem_sym.v1 = ps_default_type else elem_sym.v1 = sigil 'Get offset of element in UDT elem_sym.v2 = udt_sym.v1 symtab_add_entry elem_sym ps_udt_element = symtab_last_entry $if DEBUG_PARSE_TRACE then debuginfo "Completed UDT element" $end if end function 'Expects: Element 'Results: token after element 'Takes udt variable as argument function ps_udt_element_access(lvalue) $if DEBUG_PARSE_TRACE then debuginfo "Start udt element access" $end if head_typ_name$ = symtab(type_of_lvalue(lvalue)).identifier elem = symtab_get_id(head_typ_name$ + "." + ucase$(tok_content$)) if elem = 0 or symtab(elem).typ <> SYM_UDT_ELEMENT then ps_error "Bad UDT element access" tok_advance node = ast_add_node(AST_UDT_ACCESS) ast_attach node, lvalue ast_nodes(node).ref = elem ps_udt_element_access = node $if DEBUG_PARSE_TRACE then debuginfo "Completed udt element access" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'userfuncs.bm - Parse rules for SUB and FUNCTION definitions 'Expects: TOK_DECLARE 'Results: NEWLINE function ps_declare ps_consume TOK_DECLARE ps_declare = ps_declare_p end function function ps_declare_p $if DEBUG_PARSE_TRACE then debuginfo "Start declare_p" $end if if ps_consumed(TOK_SUB) then is_sub = TRUE else ps_consume(TOK_FUNCTION) if tok_token <> TOK_UNKNOWN then ps_error "Name already in use" end if dim sym as symtab_entry_t sym.identifier = ucase$(tok_content$) sym.typ = SYM_FUNCTION tok_advance if is_sub then return_type = TYPE_NONE else return_type = ps_opt_sigil if return_type = 0 then return_type = ps_default_type sym.v1 = type_add_sig(0, type_sigt_create$(return_type)) if ps_consumed(TOK_OPAREN) then if not ps_consumed(TOK_CPAREN) then sig$ = ps_formal_args$(0) type_sig_merge sym.v1, sig$ ps_consume TOK_CPAREN end if end if sym.v2 = SYM_FUNCTION_USER sym.v3 = 0 'We have no implementation for this function yet symtab_add_entry sym proc_id = symtab_last_entry ps_declare_p = 0 $if DEBUG_PARSE_TRACE then debuginfo "Completed declare_p" $end if end function 'Expects: TOK_FUNCTION or TOK_SUB 'Results: NEWLINE 'Return -2, which is handled particularly by ps_block, ps_stmt and interactive_mode function ps_userfunc $if DEBUG_PARSE_TRACE then debuginfo "Start userfunc" $end if if ps_final_nested then ps_error "SUB and FUNCTION must appear at top level" end if if ps_consumed(TOK_SUB) then is_sub = TRUE else ps_consume(TOK_FUNCTION) if tok_token <> TOK_UNKNOWN then if symtab(tok_token).typ <> SYM_FUNCTION then ps_error "Existing name is not a function" 'if not preload mode and (intrinsic function or implemented user function) if not ps_is_preload and (symtab(tok_token).v2 <> SYM_FUNCTION_USER or symtab(tok_token).v3 <> 0) then ps_error "Function already exists" override_sym = tok_token end if dim sym as symtab_entry_t sym.identifier = ucase$(tok_content$) sym.typ = SYM_FUNCTION tok_advance root = ast_add_node(AST_PROCEDURE) ps_add_nested_structure root ps_scope_identifier$ = sym.identifier 'Save this value so we can restore it later (and so STATIC can access it) ps_main_frame_size = ps_scope_frame_size ps_scope_frame_size = 0 if is_sub then return_type = TYPE_NONE else return_type = ps_opt_sigil if return_type = 0 then return_type = ps_default_type new_sig = type_add_sig(0, type_sigt_create$(return_type)) if ps_consumed(TOK_OPAREN) then if not ps_consumed(TOK_CPAREN) then sig$ = ps_formal_args$(root) type_sig_merge new_sig, sig$ ps_consume TOK_CPAREN end if end if if override_sym then 'Overriding existing function, or implementing a declaration 'TODO: Be more smart about the type signature for intrinsics if symtab(override_sym).v2 = SYM_FUNCTION_USER and _ type_signatures(symtab(override_sym).v1).sig <> type_signatures(new_sig).sig then print type_human_sig$(type_signatures(symtab(override_sym).v1).sig) print type_human_sig$(type_signatures(new_sig).sig) ps_error "Type signature does not match existing" end if symtab(override_sym).v2 = SYM_FUNCTION_USER symtab(override_sym).v3 = root proc_id = override_sym else sym.v1 = new_sig sym.v2 = SYM_FUNCTION_USER sym.v3 = root symtab_add_entry sym proc_id = symtab_last_entry end if ast_nodes(root).ref = proc_id 'TODO: STATIC and other modifiers ps_consume TOK_NEWLINE block = ps_block for i = 1 to len(ps_queued_nodes$) - 3 step 4 other = cvl(mid$(ps_queued_nodes$, i, 4)) ast_attach block, other next i ps_queued_nodes$ = "" ast_pre_attach root, block ps_consume TOK_END if is_sub then ps_consume TOK_SUB else ps_consume TOK_FUNCTION symtab(proc_id).v4 = ps_scope_frame_size ps_scope_frame_size = ps_main_frame_size ps_scope_identifier$ = "" ps_remove_nested_structure ps_userfunc = -2 $if DEBUG_PARSE_TRACE then debuginfo "Completed userfunc" $end if end function 'Expects: token after OPAREN 'Result: CPAREN 'Return list of formal args. If root is <> 0, attach AST_VAR nodes. function ps_formal_args$(root) $if DEBUG_PARSE_TRACE then debuginfo "Start formal args" $end if result$ = type_sigt_create$(0) do flags = 0 do select case tok_token case TOK_BYREF if flags and TYPE_BYREF then ps_error "Duplicate modifier" flags = flags OR TYPE_BYREF tok_advance case TOK_BYVAL if flags and TYPE_BYVAL then ps_error "Duplicate modifier" flags = flags OR TYPE_BYVAL tok_advance case TOK_OPTION if flags and TYPE_OPTIONAL then ps_error "Duplicate modifier" flags = flags OR TYPE_OPTIONAL tok_advance case else exit do end select loop 'Our calling convention can't handle optional byval arguments if ((flags AND TYPE_BYVAL) <> 0) and ((flags AND TYPE_OPTIONAL) <> 0) then ps_error "Optional arguments cannot be BYVAL" end if if tok_token <> TOK_UNKNOWN then ps_error "Expected new variable name" end if 'We need to do a bit of jumping around to check for arrays, and sigils in 'multiple places. This somewhat duplicates the logic in parser/array.bm. var_name$ = tok_content$ tok_advance sigil = ps_opt_sigil if ps_consumed(TOK_OPAREN) then is_array = TRUE ps_consume TOK_CPAREN end if sigil2 = ps_opt_sigil if sigil2 > 0 and sigil > 0 then ps_error "Cannot give type twice" if sigil2 then sigil = sigil2 if sigil = 0 then sigil = ps_default_type 'The array is always non-concrete, so if the sigil doesn't have dimension 'information we let it accept any dimension of array. if is_array and not type_is_array(sigil) then sigil = type_make_array(sigil, 0) is_array = type_is_array(sigil) if is_array and ((flags AND TYPE_BYVAL) <> 0) then ps_error "Array must be passed by reference" end if if root then var = ast_add_node(AST_VAR) 'Argument is pass-by-reference, unless explicitly requesting BYVAL is_ref = (flags AND TYPE_BYVAL) = 0 ast_nodes(var).ref = ps_new_var_pp(var_name$, sigil, FALSE, is_ref) ast_attach root, var end if result$ = type_sigt_add_arg(result$, sigil, flags) loop while ps_consumed(TOK_COMMA) ps_formal_args$ = result$ $if DEBUG_PARSE_TRACE then debuginfo "Completed formal args" $end if end function 'Expects: function name token 'Result: NEWLINE if valid return assignment, unchanged otherwise 'Returns node if this is a function return value assignment, 0 otherwise function ps_func_return $if DEBUG_PARSE_TRACE then debuginfo "Start func return" $end if 'Are we in a procedure with a matching name? u$ = ucase$(tok_content$) if u$ <> ps_scope_identifier$ then $if DEBUG_PARSE_TRACE then debuginfo "Completed func return" $end if exit function end if proc_id = symtab_get_id(u$) 'Is this actually a function, not a sub? return_type = type_sig_return(symtab(proc_id).v1) if return_type = TYPE_NONE then $if DEBUG_PARSE_TRACE then debuginfo "Completed func return" $end if exit function end if tok_advance 'Ensure any type sigils match sigil = ps_opt_sigil if sigil <> 0 and return_type <> sigil then ps_error "Function return type not consistent" 'Ok, definitely setting the return value ps_consume TOK_EQUALS root = ast_add_node(AST_SET_RETURN) expr = ps_expr expr_type = type_of_expr(expr) if not type_can_cast(expr_type, return_type) then ps_error "Function return type does not match that of expression" expr = ast_add_cast(expr, return_type) ast_attach root, expr ast_nodes(root).ref = return_type ps_func_return = root $if DEBUG_PARSE_TRACE then debuginfo "Completed func return" $end if end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'var.bm - Parse rules for DIM and variables 'Expects: TOK_DIM, TOK_REDIM or TOK_STATIC 'Results: token after last declaration 'Format: DIM [STATIC] [_PRESERVE] [SHARED] variablelist function ps_dim $if DEBUG_PARSE_TRACE then debuginfo "Start dim" $end if if tok_token = TOK_DIM or tok_token = TOK_REDIM then tok_advance if ps_consumed(TOK_STATIC) then is_static = TRUE if ps_consumed(TOK__PRESERVE) then preserve = TRUE if ps_consumed(TOK_SHARED) then is_shared = TRUE if is_static then if is_shared or preserve then ps_error "Cannot be SHARED or _PRESERVE when STATIC" if ps_last_nested(AST_PROCEDURE) = 0 then ps_error "Not in function" 'Switch back to the main program's frame so that statics are allocated 'in there instead of locally. inner_frame_size = ps_scope_frame_size ps_scope_frame_size = ps_main_frame_size end if 'Check for Dim As Long style syntax typ = ps_opt_sigil do name_token = tok_token 'This is a little messy because we have to look-ahead some to see if 'it's a scalar or array. variable_name$ = tok_content$ tok_advance sigil = ps_opt_sigil if typ > 0 and sigil > 0 and typ <> sigil then ps_error "Variable type does not match DIM type" if typ then sigil = typ if tok_token = TOK_OPAREN or type_is_array(sigil) then 'Array declaration. 'The block holds all resizes declared in this DIM statement if block = 0 then block = ast_add_node(AST_BLOCK) ps_dim_array name_token, variable_name$, sigil, block, is_shared, preserve, is_static else 'Just a regular variable if name_token <> TOK_UNKNOWN then ps_error "Expected new variable name" sym = ps_new_var_pp(variable_name$, sigil, is_shared, FALSE) if is_static then symtab(sym).v3 = symtab(sym).v3 OR SYM_VARIABLE_MAINFRAME end if loop while ps_consumed(TOK_COMMA) ps_dim = block if is_static then ps_main_frame_size = ps_scope_frame_size ps_scope_frame_size = inner_frame_size end if $if DEBUG_PARSE_TRACE then debuginfo "Completed dim" $end if end function function ps_lvalue token = tok_token content$ = tok_content$ tok_advance ps_lvalue = ps_lvalue_p(token, content$) end function function ps_lvalue_mutable node = ps_lvalue if symtab(ast_nodes(node).ref).v3 AND SYM_VARIABLE_CONST then ps_error "Cannot reassign CONST" end if ps_lvalue_mutable = node end function function ps_lvalue_p(head, content$) $if DEBUG_PARSE_TRACE then debuginfo "Start lvalue" $end if node = ps_simple_variable_p(head, content$) do while tok_token = TOK_DOT or tok_token = TOK_OPAREN if ps_consumed(TOK_DOT) then 'UDT element access node = ps_udt_element_access(node) elseif ps_consumed(TOK_OPAREN) and not ps_consumed(TOK_CPAREN) then 'array access. Something like `a()` is a reference to the entire array, 'so no access operation needed. node = ps_array_element_access(node) end if loop ps_lvalue_p = node $if DEBUG_PARSE_TRACE then debuginfo "Completed lvalue" $end if end function function ps_simple_variable token = tok_token content$ = tok_content$ tok_advance ps_simple_variable = ps_simple_variable_p(token, content$) end function 'Expects: token after variable, variable token as arg 'Results: token after optional sigil 'Note: process simple variables, i.e. no udt or array stuff. Returns AST_VAR. function ps_simple_variable_p(head, content$) $if DEBUG_PARSE_TRACE then debuginfo "Start simple variable" $end if node = ast_add_node(AST_VAR) if head = TOK_UNKNOWN then 'Add new variable (implicit declaration) if not ps_allow_implicit_vars then ps_error "Implicit variable declaration" ast_nodes(node).ref = ps_new_var_p(content$) elseif symtab(head).typ <> SYM_VARIABLE then ps_error "Expected variable" else 'Existing variable sigil = ps_opt_sigil current_type = symtab(head).v1 if symtab(current_type).v2 = SYM_TYPE_ARRAY then current_type = symtab(current_type).v3 if sigil and sigil <> current_type then ps_error "Type suffix does not match existing variable type" ast_nodes(node).ref = head end if ps_simple_variable_p = node $if DEBUG_PARSE_TRACE then debuginfo "Completed simple variable" $end if end function 'Expects: sigil or otherwise 'Results: post token if sigil present, unchanged otherwise function ps_opt_sigil $if DEBUG_PARSE_TRACE then debuginfo "Start optional sigil" $end if if ps_consumed(TOK_AS) then typ = tok_token if typ = 0 or symtab(typ).typ <> SYM_TYPE then ps_error "Expected type name" else select case tok_token case TOK_INTEGER_SFX typ = TYPE_INTEGER case TOK_LONG_SFX typ = TYPE_LONG case TOK_INTEGER64_SFX typ = TYPE_INTEGER64 case TOK_SINGLE_SFX typ = TYPE_SINGLE case TOK_DOUBLE_SFX typ = TYPE_DOUBLE case TOK_QUAD_SFX typ = TYPE_QUAD case TOK_STRING_SFX typ = TYPE_STRING case else typ = 0 end select end if if typ then tok_advance if ps_consumed(TOK_OBRACKET) then 'Array type. If the element type hasn't been given, assume it to 'be the default type. if typ = 0 then typ = ps_default_type ps_assert TOK_NUMINT dimensions = val(tok_content$) tok_advance ps_consume TOK_CBRACKET typ = type_make_array(typ, dimensions) end if ps_opt_sigil = typ $if DEBUG_PARSE_TRACE then debuginfo "Completed optional sigil" $end if end function function ps_new_var_p(var_name$) sigil = ps_opt_sigil ps_new_var_p = ps_new_var_pp(var_name$, sigil, FALSE, FALSE) end function function ps_new_var_pp(var_name$, sigil, is_shared, is_ref) dim sym as symtab_entry_t if is_shared then sym.identifier = ucase$(var_name$) else sym.identifier = ps_scope$ + ucase$(var_name$) end if sym.typ = SYM_VARIABLE if sigil then sym.v1 = sigil else sym.v1 = ps_default_type sym.v2 = ps_scope_frame_size if is_ref then ps_scope_frame_size = ps_scope_frame_size + 1 else ps_scope_frame_size = ps_scope_frame_size + type_fixed_size(sym.v1) end if if is_shared then sym.v3 = SYM_VARIABLE_MAINFRAME else sym.v3 = 0 if is_ref then sym.v3 = sym.v3 OR SYM_VARIABLE_DEREF symtab_add_entry sym ps_new_var_pp = symtab_last_entry end function 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'dump.bm - Produce human readable representation of parsed program sub dump_program print #logging_file_handle, "Table of identifiers:" symtab_dump print #logging_file_handle, 'print #logging_file_handle, "Function type signatures:" 'type_dump_functions 'print #logging_file_handle, print #logging_file_handle, "Table of constants:" ast_dump_constants print #logging_file_handle, print #logging_file_handle, "Program:" ast_dump_pretty AST_ENTRYPOINT, 0 dump_subprocedures end sub sub type_dump_functions for i = 1 to symtab_last_entry typ = symtab(i).typ if typ = SYM_FUNCTION or typ = SYM_INFIX or typ = SYM_PREFIX then sig_index = symtab(i).v1 do print #logging_file_handle, sig_index; " "; symtab(i).identifier; " "; type_human_sig$(type_signatures(sig_index).sig) sig_index = type_signatures(sig_index).succ loop while sig_index <> 0 end if next i end sub sub symtab_dump print #logging_file_handle, " ID Name Typ v1 v2 v3 v4" for i = 1 to symtab_last_entry print #logging_file_handle, using "### \ \ ### ### ### ### ###"; i; symtab(i).identifier; _ symtab(i).typ,symtab(i).v1; symtab(i).v2; symtab(i).v3; symtab(i).v4 next i end sub sub dump_subprocedures for i = 1 to symtab_last_entry if symtab(i).typ = SYM_FUNCTION and symtab(i).v2 = SYM_FUNCTION_USER then return_type = type_sig_return(symtab(i).v1) if return_type = TYPE_NONE then is_sub = TRUE else is_sub = FALSE print #logging_file_handle, if is_sub then print #logging_file_handle, "SUB "; symtab(i).identifier; " ("; else print #logging_file_handle, "FUNCTION "; symtab(i).identifier; " AS "; type_human_readable$(return_type); " ("; end if root = symtab(i).v3 for j = 2 to ast_num_children(root) ast_dump_pretty ast_get_child(root, j), 0 if j < ast_num_children(root) then print #logging_file_handle, ", "; next j print #logging_file_handle, ")" ast_dump_pretty ast_get_child(root, 1), 1 if is_sub then print #logging_file_handle, "END SUB" else print #logging_file_handle, "END FUNCTION" end if next i end sub sub ast_dump_summary(root, newline) if ast_nodes(root).typ = 0 then Error_message$ = "Node" + str$(root) + " is invalid": error 101 end if select case ast_nodes(root).typ case AST_ASSIGN if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; ast_dump_summary ast_get_child(root, 1), FALSE print #logging_file_handle, " = "; ast_dump_summary ast_get_child(root, 2), FALSE case AST_CALL if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; print #logging_file_handle, "call("; print #logging_file_handle, symtab(ast_nodes(root).ref).identifier; if len(ast_children(root)) then print #logging_file_handle, ", "; for i = 1 to ast_num_children(root) ast_dump_summary ast_get_child(root, i), FALSE if i <> ast_num_children(root) then print #logging_file_handle, ", "; next i print #logging_file_handle, ")"; case AST_CONSTANT if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; if type_of_constant(root) = TYPE_STRING then print #logging_file_handle, chr$(34); ast_constants(ast_nodes(root).ref); chr$(34); else print #logging_file_handle, ast_constants(ast_nodes(root).ref); end if case AST_VAR print #logging_file_handle, "var("; var = ast_nodes(root).ref if symtab(var).v3 AND SYM_VARIABLE_CONST then print #logging_file_handle, "CONST "; print #logging_file_handle, symtab(var).identifier; ")"; case AST_UDT_ACCESS if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; print #logging_file_handle, "udt("; ast_dump_summary ast_get_child(root, 1), FALSE print #logging_file_handle, ", "; symtab(ast_nodes(root).ref).identifier; ")"; case AST_ARRAY_ACCESS if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; ast_dump_summary ast_get_child(root, 1), FALSE print #logging_file_handle, "("; for i = 2 to ast_num_children(root) ast_dump_summary ast_get_child(root, i), FALSE if i <> ast_num_children(root) then print #logging_file_handle, ", "; next i print #logging_file_handle, ")"; case AST_ARRAY_CREATE, AST_ARRAY_RESIZE if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; print #logging_file_handle, "REDIM "; if ast_nodes(root).typ = AST_ARRAY_RESIZE then print #logging_file_handle, "_PRESERVE "; ast_dump_summary ast_get_child(root, 1), FALSE print #logging_file_handle, "("; for i = 2 to ast_num_children(root) step 2 ast_dump_summary ast_get_child(root, i), FALSE print #logging_file_handle, " TO "; ast_dump_summary ast_get_child(root, i + 1), FALSE if i < ast_num_children(root) - 1 then print #logging_file_handle, ", "; next i print #logging_file_handle, ")"; case AST_CAST if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; print #logging_file_handle, "cast("; type_human_readable$(type_of_cast(root)); ", "; ast_dump_summary ast_get_child(root, 1), FALSE print #logging_file_handle, ")"; case AST_FLAGS if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; print #logging_file_handle, "flag("; select case ast_nodes(root).ref case AST_FLAG_MANUAL, AST_FLAG_CONTEXTUAL print #logging_file_handle, ltrim$(str$(ast_nodes(root).ref2)); case AST_FLAG_TOKEN print #logging_file_handle, symtab(ast_nodes(root).ref2).identifier; end select print #logging_file_handle, ")"; case AST_NONE if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; print #logging_file_handle, "[NONE]"; case AST_SET_RETURN if newline then print #logging_file_handle, "Line"; ast_nodes(root).linenum; ": "; print #logging_file_handle, "return "; ast_dump_summary ast_get_child(root, 1), FALSE case else exit sub end select if newline then print #logging_file_handle, end sub sub ast_dump_pretty(root, indent_level) indent$ = space$(indent_level * 4) if ast_nodes(root).typ = 0 then Error_message$ = "Node" + str$(root) + " is invalid": error 101 end if select case ast_nodes(root).typ case AST_PROCEDURE print #logging_file_handle, "Invalid nested procedure" case AST_ASSIGN ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, " = "; ast_dump_pretty ast_get_child(root, 2), 0 case AST_IF for clause = 1 to ast_num_children(root) \ 2 if clause = 1 then print #logging_file_handle, indent$; "IF "; else print #logging_file_handle, indent$; "ELSEIF "; ast_dump_pretty ast_get_child(root, clause * 2 - 1), 0 print #logging_file_handle, " THEN " ast_dump_pretty ast_get_child(root, clause * 2), indent_level + 1 next clause if ast_num_children(root) mod 2 then print #logging_file_handle, indent$; "ELSE" ast_dump_pretty ast_get_child(root, ast_num_children(root)), indent_level + 1 end if print #logging_file_handle, indent$; "END IF"; case AST_WHILE print #logging_file_handle, indent$; "WHILE "; ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, ast_dump_pretty ast_get_child(root, 2), indent_level + 1 print #logging_file_handle, indent$; "WEND"; case AST_DO_PRE print #logging_file_handle, indent$; "DO WHILE "; ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, ast_dump_pretty ast_get_child(root, 2), indent_level + 1 print #logging_file_handle, indent$; "LOOP"; case AST_DO_POST print #logging_file_handle, indent$; "DO" ast_dump_pretty ast_get_child(root, 2), indent_level + 1 print #logging_file_handle, indent$; "LOOP WHILE "; ast_dump_pretty ast_get_child(root, 1), 0 case AST_FOR print #logging_file_handle, indent$; "FOR "; ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, " = "; ast_dump_pretty ast_get_child(root, 2), 0 print #logging_file_handle, " TO "; ast_dump_pretty ast_get_child(root, 3), 0 print #logging_file_handle, " STEP "; ast_dump_pretty ast_get_child(root, 4), 0 print #logging_file_handle, ast_dump_pretty ast_get_child(root, 5), indent_level + 1 print #logging_file_handle, indent$; "NEXT "; ast_dump_pretty ast_get_child(root, 1), 0 case AST_SELECT print #logging_file_handle, indent$; "SELECT CASE "; ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, for i = 2 to ast_num_children(root) ast_dump_pretty ast_get_child(root, i), indent_level next i print #logging_file_handle, indent$; "END SELECT"; case AST_SELECT_LIST print #logging_file_handle, indent$; "CASE "; for i = 1 to ast_num_children(root) - 1 ast_dump_pretty ast_get_child(root, i), 0 if i < ast_num_children(root) - 1 then print #logging_file_handle, ", "; next i print #logging_file_handle, ast_dump_pretty ast_get_child(root, ast_num_children(root)), indent_level + 1 case AST_SELECT_ELSE print #logging_file_handle, indent$; "CASE ELSE" ast_dump_pretty ast_get_child(root, ast_num_children(root)), indent_level + 1 case AST_SELECT_IS print #logging_file_handle, indent$; "IS "; print #logging_file_handle, symtab(ast_nodes(root).ref).identifier; " "; ast_dump_pretty ast_get_child(root, 2), 0 case AST_SELECT_RANGE ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, indent$; " TO "; ast_dump_pretty ast_get_child(root, 2), 0 case AST_CALL print #logging_file_handle, "call("; print #logging_file_handle, symtab(ast_nodes(root).ref).identifier; print #logging_file_handle, " ["; type_human_sig$(type_signatures(ast_nodes(root).ref2).sig); "]"; if len(ast_children(root)) then print #logging_file_handle, ", "; for i = 1 to ast_num_children(root) ast_dump_pretty ast_get_child(root, i), 0 if i <> ast_num_children(root) then print #logging_file_handle, ", "; next i print #logging_file_handle, ")"; case AST_CONSTANT if type_of_constant(root) = TYPE_STRING then print #logging_file_handle, chr$(34); ast_constants(ast_nodes(root).ref); chr$(34); else print #logging_file_handle, ast_constants(ast_nodes(root).ref); end if case AST_BLOCK for i = 1 to ast_num_children(root) print #logging_file_handle, indent$; ast_dump_pretty ast_get_child(root, i), indent_level + 1 print #logging_file_handle, next i case AST_VAR print #logging_file_handle, "var("; var = ast_nodes(root).ref if symtab(var).v3 AND SYM_VARIABLE_CONST then print #logging_file_handle, "CONST "; print #logging_file_handle, symtab(var).identifier; ")"; case AST_UDT_ACCESS print #logging_file_handle, "udt("; ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, ", "; symtab(ast_nodes(root).ref).identifier; ")"; case AST_ARRAY_ACCESS print #logging_file_handle, "array("; ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, ", "; for i = 2 to ast_num_children(root) ast_dump_pretty ast_get_child(root, i), 0 if i <> ast_num_children(root) then print #logging_file_handle, ", "; next i print #logging_file_handle, ")"; case AST_ARRAY_CREATE, AST_ARRAY_RESIZE print #logging_file_handle, "REDIM "; if ast_nodes(root).typ = AST_ARRAY_RESIZE then print #logging_file_handle, "_PRESERVE "; ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, "("; for i = 2 to ast_num_children(root) step 2 ast_dump_pretty ast_get_child(root, i), 0 print #logging_file_handle, " TO "; ast_dump_pretty ast_get_child(root, i + 1), 0 if i < ast_num_children(root) - 1 then print #logging_file_handle, ", "; next i print #logging_file_handle, ")"; case AST_ARRAY_DELETE print #logging_file_handle, "delete "; ast_dump_pretty ast_get_child(root, 1), 0 case AST_CAST print #logging_file_handle, "cast("; type_human_readable$(type_of_cast(root)); ", "; ast_dump_pretty ast_get_child(root, 1), 0 print #logging_file_handle, ")"; case AST_FLAGS print #logging_file_handle, "flag("; select case ast_nodes(root).ref case AST_FLAG_MANUAL, AST_FLAG_CONTEXTUAL print #logging_file_handle, ltrim$(str$(ast_nodes(root).ref2)); case AST_FLAG_TOKEN print #logging_file_handle, symtab(ast_nodes(root).ref2).identifier; end select print #logging_file_handle, ")"; case AST_GOTO print #logging_file_handle, indent$; "goto("; ast_nodes(root).ref; ")"; case AST_EXIT print #logging_file_handle, "EXIT "; select case ast_nodes(ast_nodes(root).ref).typ case AST_WHILE print #logging_file_handle, "WHILE"; case AST_DO_POST, AST_DO_PRE print #logging_file_handle, "DO"; case AST_FOR print #logging_file_handle, "FOR"; end select case AST_NONE print #logging_file_handle, "[NONE]"; case AST_SET_RETURN print #logging_file_handle, "return "; ast_dump_pretty ast_get_child(root, 1), 0 case else print #logging_file_handle, "Unknown AST type"; ast_nodes(root).typ end select end sub sub ast_dump_constants print #logging_file_handle, " ID Type Value" for i = 1 to ast_last_constant print #logging_file_handle, using "### & &"; i; type_human_readable(ast_constant_types(i)); ast_constants(i) next i end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'immediate.bm - Execute a parsed program sub imm_init imm_stack_last = ps_scope_frame_size redim imm_stack(1 to imm_stack_last) as imm_value_t 'No, I'm not crazy - this explicit initialisation is to 'work around a QB64 bug where it doesn't set these values 'properly. Probably something to do with the dynamic-length 'string in a UDT. for i = 1 to imm_stack_last imm_stack(i).s = "" imm_stack(i).n = 0 next i 'Starting at 1 allows catching writes to address 0 imm_stack_base = 1 imm_filehandle_offset = freefile - 1 imm_heap_init end sub sub imm_reinit(stack_size) old_last = imm_stack_last imm_stack_last = stack_size if imm_stack_last > u then redim _preserve imm_stack(1 to imm_stack_last) as imm_value_t for i = old_last + 1 to imm_stack_last imm_stack(i).s = "" imm_stack(i).n = 0 next i end sub sub imm_run(node) dim dummy_result as imm_value_t imm_eval node, dummy_result end sub sub imm_error(msg$) Error_message$ = msg$ error 101 end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'array.bm - Array handling functions sub imm_do_array_establish(node) array = ast_get_child(node, 1) 'get address of descriptor info_base_addr = imm_get_addr(array) 'get data block address data_addr = imm_get_at_addr_n(info_base_addr) if data_addr <> 0 then exit sub imm_array_init node end sub sub imm_do_array_delete(node) array = ast_get_child(node, 1) 'get address of descriptor info_base_addr = imm_get_addr(array) 'don't free anything if descriptor does not exist if info_base_addr = 0 then exit sub 'get data block address data_addr = imm_get_at_addr_n(info_base_addr) imm_heap_free data_addr if info_base_addr < 0 then 'descriptor is on the heap, free that too imm_heap_free info_base_addr 'clear reference to descriptor imm_set_at_addr_n imm_get_addr_loc(array), 0 end if end sub sub imm_array_delete(info_base_addr) if info_base_addr = 0 then exit sub data_addr = imm_get_at_addr_n(info_base_addr) if data_addr then imm_heap_free data_addr if info_base_addr < 0 then imm_heap_free info_base_addr end sub sub imm_array_init(node) dim temp as imm_value_t 'New array 'Array descriptor: ' - pointer to data ' - number of dimensions ' - lbound of leftmost dimension ' - ubound of leftmost dimension ' - etc. ' - lbound of rightmost dimension ' - ubound of rightmost dimension array = ast_get_child(node, 1) info_base_addr = imm_get_addr(array) data_addr = imm_get_at_addr_n(info_base_addr) array_type = type_of_lvalue(array) element_type = symtab(array_type).v3 dimensions = (ast_num_children(node) - 1) / 2 cur_dimensions = imm_get_at_addr_n(imm_add_offset(info_base_addr, 1)) if cur_dimensions <> 0 and cur_dimensions <> dimensions then imm_error "Cannot change number of array dimensions" end if block_size = 1 imm_set_at_addr_n imm_add_offset(info_base_addr, 1), dimensions for i = 1 to dimensions 'evaluate upper and lower bounds for this dimension imm_eval ast_get_child(node, i * 2), temp lower_bound = temp.n imm_eval ast_get_child(node, i * 2 + 1), temp upper_bound = temp.n 'write values to descriptor imm_set_at_addr_n imm_add_offset(info_base_addr, i * 2), lower_bound imm_set_at_addr_n imm_add_offset(info_base_addr, i * 2 + 1), upper_bound 'accumulate total data block size as number of elements data_size = data_size + (upper_bound - lower_bound + 1) * block_size block_size = upper_bound - lower_bound + 1 next i 'convert to bytes data_size = data_size * type_fixed_size(element_type) 'allocate and store pointer data_addr = imm_heap_alloc(data_size) imm_set_at_addr_n info_base_addr, data_addr temp.n = 0 temp.s = "" imm_memset data_addr, data_size, temp end sub sub imm_do_array_resize(node, preserve) dim temp as imm_value_t array = ast_get_child(node, 1) dimensions = (ast_num_children(node) - 1) / 2 'get address of descriptor info_base_addr = imm_get_addr(array) if info_base_addr = 0 then 'need to allocate descriptor info_base_addr = imm_heap_alloc(2 + dimensions * 2) imm_set_at_addr_n imm_get_addr_loc(array), info_base_addr 'explicitly set number of dimensions to 0 so that imm_array_init 'does not complain imm_set_at_addr_n imm_add_offset(info_base_addr, 1), dimensions data_addr = 0 else 'get data block address data_addr = imm_get_at_addr_n(info_base_addr) end if if data_addr = 0 then imm_array_init node elseif not preserve then imm_heap_free data_addr imm_array_init node else 'only allow resizing the last dimension because otherwise we would need to 'rearrange all the data array_type = type_of_lvalue(array) element_type = symtab(array_type).v3 cur_dimensions = imm_get_at_addr_n(imm_add_offset(info_base_addr, 1)) if cur_dimensions <> 0 and cur_dimensions <> dimensions then imm_error "Cannot change number of array dimensions" end if old_block_size = 1 new_block_size = 1 for i = 1 to dimensions 'check lower bound imm_eval ast_get_child(node, i * 2), temp old_lower_bound = imm_get_at_addr_n(imm_add_offset(info_base_addr, i * 2)) new_lower_bound = temp.n if i < dimensions and old_lower_bound <> new_lower_bound then imm_error "Bad array resize" 'check upper bound imm_eval ast_get_child(node, i * 2 + 1), temp old_upper_bound = imm_get_at_addr_n(imm_add_offset(info_base_addr, i * 2 + 1)) new_upper_bound = temp.n if i < dimensions and old_upper_bound <> new_upper_bound then imm_error "Bad array resize" imm_set_at_addr_n imm_add_offset(info_base_addr, i * 2), new_lower_bound imm_set_at_addr_n imm_add_offset(info_base_addr, i * 2 + 1), new_upper_bound old_data_size = old_data_size + (old_upper_bound - old_lower_bound + 1) * old_block_size old_block_size = old_upper_bound - old_lower_bound + 1 new_data_size = new_data_size + (new_upper_bound - new_lower_bound + 1) * new_block_size new_block_size = new_upper_bound - new_lower_bound + 1 next i old_data_size = old_data_size * type_fixed_size(element_type) new_data_size = new_data_size * type_fixed_size(element_type) if new_data_size <= old_data_size then 'Array is shrinking or staying the same. Since we don't have the ability 'to shrink allocations, just leave it the same size. 'TODO implement heap shrinking else 'Array is expanding. Copy data to a new allocation. 'TODO implement heap expanding new_data_addr = imm_heap_alloc(new_data_size) for i = 0 to old_data_size - 1 imm_get_at_addr imm_add_offset(data_addr, i), temp imm_set_at_addr imm_add_offset(new_data_addr, i), temp next i imm_heap_free data_addr imm_set_at_addr_n info_base_addr, new_data_addr end if end if end sub 'If is_ref is true, dest_addr is the address of a pointer to the descriptor. 'It may be a null pointer, indicating the descriptor needs to be created. 'If is_ref is false, dest_addr is the descriptor address. sub imm_array_copy(src_addr, dest_addr_in, is_ref) dest_addr = dest_addr_in 'Don't try and copy an array onto itself if dest_addr = src_addr then exit sub src_data_addr = imm_get_at_addr_n(src_addr) if src_data_addr = 0 then imm_error "Cannot assign uninitialised array" end if src_dims = imm_get_at_addr_n(imm_add_offset(src_addr, 1)) if is_ref then dest_ref = dest_addr dest_addr = imm_get_at_addr_n(dest_ref) end if if is_ref and dest_addr = 0 then 'need to initialise dest array dest_addr = imm_heap_alloc(2 + src_dims * 2) imm_set_at_addr_n dest_ref, dest_addr imm_set_at_addr_n dest_addr, 0 'No data block yet imm_set_at_addr_n imm_add_offset(dest_addr, 1), src_dims dest_dims = src_dims else dest_dims = imm_get_at_addr_n(imm_add_offset(dest_addr, 1)) if src_dims <> dest_dims then imm_error "Array dimensions do not match" end if end if 'Copy data block, freeing old one if needed dest_data_addr = imm_get_at_addr_n(dest_addr) if dest_data_addr then imm_heap_free dest_data_addr dest_data_addr = imm_heap_copy_alloc(src_data_addr) imm_set_at_addr_n dest_addr, dest_data_addr 'Also copy upper and lower bound information for i = 2 to src_dims * 2 + 1 imm_set_at_addr_n imm_add_offset(dest_addr, i), imm_get_at_addr_n(imm_add_offset(src_addr, i)) next i end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'assignment.bm - Executor for variable assignment sub imm_do_assign(node) dim rvalue as imm_value_t lvalue = ast_get_child(node, 1) imm_eval ast_get_child(node, 2), rvalue dest_addr = imm_get_addr(lvalue) typ = type_of_lvalue(lvalue) if symtab(typ).v2 = SYM_TYPE_UDT then src_addr = rvalue.n for i = 1 to type_fixed_size(typ) 'TODO: Deep copy dim temp as imm_value_t imm_get_at_addr src_addr, temp imm_set_at_addr dest_addr, temp src_addr = imm_add_offset(src_addr, 1) dest_addr = imm_add_offset(dest_addr, 1) next i elseif symtab(typ).v2 = SYM_TYPE_ARRAY then imm_array_copy rvalue.n, imm_get_addr_loc(lvalue), imm_needs_deref(lvalue) else imm_set_at_addr dest_addr, rvalue end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'block.bm - Executor for a BLOCK sub imm_do_block(node, result as imm_value_t) start_at = 1 if imm_next_jump then imm_trim_jump start_at = ast_find_child(node, imm_next_jump) imm_trim_jump end if for i = start_at to ast_num_children(node) imm_eval ast_get_child(node, i), result if imm_next_jump then 'Are we GOTOing somewhere? if imm_next_jump = ast_get_child(node, i) then 'Handle the crazy case of things like "10 GOTO 10" imm_trim_jump i = i - 1 elseif imm_next_jump = node then imm_trim_jump 'This node is on the jump path 'Note: labels never attach directly to a block '-1 because the top of the loop does +1 i = ast_find_child(node, imm_next_jump) - 1 imm_trim_jump else 'Our target is in another block, unwind further exit function end if end if if imm_exit_node > 0 then exit sub next i end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'call.bm - Executor for CALLs sub imm_do_call(node, result as imm_value_t) if symtab(ast_nodes(node).ref).v2 = SYM_FUNCTION_USER then imm_do_call_userfunc node, result else imm_do_call_internal node, result end if end sub sub imm_do_call_internal(node, result as imm_value_t) dim v1 as imm_value_t dim v2 as imm_value_t dim v3 as imm_value_t dim v4 as imm_value_t dim v5 as imm_value_t dim v6 as imm_value_t dim v7 as imm_value_t dim v8 as imm_value_t dim v9 as imm_value_t dim v10 as imm_value_t return_type = type_of_call(node) select case ast_nodes(node).ref 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'input.bm - Executor for INPUT statement and function case TOK_INPUT if return_type <> TYPE_NONE then 'INPUT$ function imm_eval ast_get_child(node, 1), v1 c2 = ast_get_child(node, 2) if ast_is_none(c2) then result.s = input$(v1.n) else imm_eval c2, v2 result.s = input$(v1.n, v2.n + imm_filehandle_offset) end if else 'INPUT statement numvars = ast_num_children(node) - 1 first_var_offset = 1 flags = ast_nodes(ast_get_child(node, 1)).ref2 if flags AND STMT_INPUT_PROMPT then imm_eval ast_get_child(node, 2), v1 print v1.s; numvars = numvars - 1 first_var_offset = 2 end if if (flags AND STMT_INPUT_NO_QUESTION) = 0 then print "? "; if flags AND STMT_INPUT_NO_NEWLINE then line input ; readline$ else line input readline$ if flags AND STMT_INPUT_LINEMODE then var = ast_get_child(node, first_var_offset + 1) var_addr = imm_get_addr(var) imm_set_at_addr_s var_addr, readline$ else 'TODO: Better error handling for i = 1 to numvars comma = instr(readline$, ",") if comma = 0 then comma = len(readline$) + 1 var = ast_get_child(node, first_var_offset + i) var_addr = imm_get_addr(var) if nomoredata then v1.n = 0 v1.s = "" elseif type_of_var(var) = TYPE_STRING then v1.s = left$(readline$, comma - 1) else v1.n = val(left$(readline$, comma - 1)) end if imm_enforce_type v1, type_of_var(var) imm_set_at_addr var_addr, v1 readline$ = mid$(readline$, comma + 1) if readline$ = "" then nomoredata = TRUE next i end if end if 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'file.bm - Executors for file management commands case TOK_CHDIR imm_eval ast_get_child(node, 1), v1 chdir v1.s case TOK_CLOSE fh = ast_get_child(node, 1) if ast_is_none(fh) then for i = imm_filehandle_offset + 1 to 255 close i next i else imm_eval fh, v1 close #v1.n + imm_filehandle_offset end if case TOK_EOF imm_eval ast_get_child(node, 1), v1 result.n = eof(v1.n + imm_filehandle_offset) case TOK_FILES c1 = ast_get_child(node, 1) if ast_is_none(c1) then files else imm_eval c1, v1 files v1.s end if case TOK_FREEFILE result.n = freefile case TOK_KILL imm_eval ast_get_child(node, 1), v1 kill v1.s case TOK_LOF imm_eval ast_get_child(node, 1), v1 result.n = lof(v1.n + imm_filehandle_offset) case TOK_OPEN imm_eval ast_get_child(node, 1), v1 'filename mode = ast_nodes(ast_get_child(node, 2)).ref2 imm_eval ast_get_child(node, 3), v2 'file handle v2.n = v2.n + imm_filehandle_offset v3.n = 128 'len reclen = ast_get_child(node, 4) if not ast_is_none(reclen) then imm_eval reclen, v3 select case mode case 1 open v1.s for random as #v2.n len=v3.n case 2 open v1.s for input as #v2.n case 3 open v1.s for output as #v2.n case 4 open v1.s for binary as #v2.n case 5 open v1.s for append as #v2.n end select case TOK_PUT imm_eval ast_get_child(node, 1), v1 v1.n = v1.n + imm_filehandle_offset v2.n = seek(v1.n) position = ast_get_child(node, 2) if not ast_is_none(position) then imm_eval position, v2 src_var = ast_get_child(node, 3) if ast_is_none(src_var) then put #v1.n, v2.n else imm_eval src_var, v3 select case type_of_expr(src_var) case TYPE_INTEGER putvar_int% = v3.n put #v1.n, v2.n, putvar_int% case TYPE_LONG putvar_long& = v3.n put #v1.n, v2.n, putvar_long& case TYPE_INTEGER64 putvar_int64&& = v3.n put #v1.n, v2.n, putvar_int64&& case TYPE_SINGLE putvar_single! = v3.n put #v1.n, v2.n, putvar_single! case TYPE_DOUBLE putvar_double# = v3.n put #v1.n, v2.n, putvar_double# case TYPE_QUAD putvar_quad## = v3.n put #v1.n, v2.n, putvar_quad## case TYPE_STRING putvar_str$ = v3.s put #v1.n, v2.n, putvar_str$ end select end if case TOK_GET imm_eval ast_get_child(node, 1), v1 v1.n = v1.n + imm_filehandle_offset v2.n = seek(v1.n) position = ast_get_child(node, 2) if not ast_is_none(position) then imm_eval position, v2 dest_var = ast_get_child(node, 3) if ast_is_none(dest_var) then get #v1.n, v2.n else dest_addr = imm_get_addr(dest_var) select case type_of_var(dest_var) case TYPE_INTEGER get #v1.n, v2.n, getvar_int% imm_set_at_addr_n dest_addr, getvar_int% case TYPE_LONG get #v1.n, v2.n, getvar_long& imm_set_at_addr_n dest_addr, getvar_long& case TYPE_INTEGER64 get #v1.n, v2.n, getvar_int64&& imm_set_at_addr_n dest_addr, getvar_int64&& case TYPE_SINGLE get #v1.n, v2.n, getvar_single! imm_set_at_addr_n dest_addr, getvar_single! case TYPE_DOUBLE get #v1.n, v2.n, getvar_double# imm_set_at_addr_n dest_addr, getvar_double# case TYPE_QUAD get #v1.n, v2.n, getvar_quad## imm_set_at_addr_n dest_addr, getvar_quad## case TYPE_STRING getvar_string$ = space$(len(imm_get_at_addr_s(dest_addr))) get #v1.n, v2.n, getvar_string$ imm_set_at_addr_s dest_addr, getvar_string$ end select end if 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'font.bm - Executors for font handling functions case TOK__FONTHEIGHT c1 = ast_get_child(node, 1) if ast_is_none(c1) then result.n = _fontheight else imm_eval c1, v1 result.n = _fontheight(v1.n) end if case TOK__FONTWIDTH c1 = ast_get_child(node, 1) if ast_is_none(c1) then result.n = _fontwidth else imm_eval c1, v1 result.n = _fontwidth(v1.n) end if case TOK__PRINTWIDTH imm_eval ast_get_child(node, 1), v1 c2 = ast_get_child(node, 2) if ast_is_none(c2) then v2.n = _dest else imm_eval c2, v2 result.n = _printwidth(v1.s, v2.n) 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'graphics.bm - Executors for graphics functions case TOK__BLUE32 imm_eval ast_get_child(node, 1), v1 result.n = _red32(v1.n) case TOK_CIRCLE 'Node 1 is flag for STEP imm_eval ast_get_child(node, 2), v1 imm_eval ast_get_child(node, 3), v2 imm_eval ast_get_child(node, 4), v3 v4.n = _defaultcolor c4 = ast_get_child(node, 5) if not ast_is_none(c4) then imm_eval c4, v4 v5.n = 0 c5 = ast_get_child(node, 6) if not ast_is_none(c5) then imm_eval c5, v5 v6.n = _pi(2) c6 = ast_get_child(node, 7) if not ast_is_none(c6) then imm_eval c6, v6 v7.n = 1 c7 = ast_get_child(node, 8) if not ast_is_none(c7) then imm_eval c7, v7 if not ast_is_none(ast_get_child(node, 1)) then circle step (v1.n, v2.n), v3.n, v4.n, v5.n, v6.n, v7.n else circle (v1.n, v2.n), v3.n, v4.n, v5.n, v6.n, v7.n end if case TOK_DRAW imm_eval ast_get_child(node, 1), v1 draw v1.s case TOK__GREEN32 imm_eval ast_get_child(node, 1), v1 result.n = _green32(v1.n) case TOK_LINE if ast_num_children(node) = 6 then src_step = true v1.n = 0 v2.n = 0 if ast_is_none(ast_get_child(node, 1)) then dest_step = false else dest_step = true imm_eval ast_get_child(node, 2), v3 imm_eval ast_get_child(node, 3), v4 imm_eval ast_get_child(node, 4), v5 mode_child = ast_get_child(node, 5) style_child = ast_get_child(node, 6) else if ast_is_none(ast_get_child(node, 1)) then src_step = false else src_step = true imm_eval ast_get_child(node, 2), v1 imm_eval ast_get_child(node, 3), v2 if ast_is_none(ast_get_child(node, 4)) then dest_step = false else dest_step = true imm_eval ast_get_child(node, 5), v3 imm_eval ast_get_child(node, 6), v4 imm_eval ast_get_child(node, 7), v5 mode_child = ast_get_child(node, 8) style_child = ast_get_child(node, 9) end if old_source = _source _source _dest if src_step then v1.n = v1.n + point(2) v2.n = v2.n + point(3) end if _source old_source if dest_step then v3.n = v3.n + v1.n v4.n = v4.n + v2.n end if if ast_is_none(mode_child) then mode = 0 else mode = ast_nodes(mode_child).ref2 if ast_is_none(style_child) then v6.n = 65535 else imm_eval style_child, v6 select case mode case 0 line (v1.n, v2.n)-(v3.n, v4.n), v5.n, , v6.n case 1 line (v1.n, v2.n)-(v3.n, v4.n), v5.n, b, v6.n case 2 line (v1.n, v2.n)-(v3.n, v4.n), v5.n, bf, v6.n end select case TOK__LOADIMAGE imm_eval ast_get_child(node, 1), v1 c1 = ast_get_child(node, 2) if ast_is_none(c1) then result.n = _loadimage(v1.s) else imm_eval c1, v2 result.n = _loadimage(v1.s, v2.n) end if case TOK__NEWIMAGE imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 c3 = ast_get_child(node,3) if ast_is_none(c3) then result.n = _newimage(v1.n, v2.n) else imm_eval ast_get_child(node, 3), v3 result.n = _newimage(v1.n, v2.n, v3.n) end if case TOK_PAINT imm_eval ast_get_child(node, 2), v1 imm_eval ast_get_child(node, 3), v2 v3.n = _defaultcolor imm_eval ast_get_child(node, 4), v3 v4.n = v3.n imm_eval ast_get_child(node, 5), v4 if not ast_is_none(ast_get_child(node, 1)) then paint step (v1.n, v2.n), v3.n, v4.n else paint (v1.n, v2.n), v3.n, v4.n end if case TOK_PSET imm_eval ast_get_child(node, 2), v1 imm_eval ast_get_child(node, 3), v2 v3.n = _defaultcolor c3 = ast_get_child(node, 4) if not ast_is_none(c3) then imm_eval c3, v3 if not ast_is_none(ast_get_child(node, 1)) then pset step (v1.n, v2.n), v3.n else pset (v1.n, v2.n), v3.n end if case TOK__PUTIMAGE flags = ast_nodes(ast_get_child(node, 1)).ref2 v5.n = _source v6.n = _dest imm_eval ast_get_child(node, 6), v5 imm_eval ast_get_child(node, 7), v6 v1.n = 0 v2.n = 0 imm_eval ast_get_child(node, 2), v1 imm_eval ast_get_child(node, 3), v2 if flags AND PUTIMAGE_STEP_SRC1 then old_source = _source _source v6.n v1.n = v1.n + point(2) v2.n = v2.n + point(3) _source old_source end if v3.n = _width(v6.n) v4.n = _height(v6.n) imm_eval ast_get_child(node, 4), v3 imm_eval ast_get_child(node, 5), v4 if flags AND PUTIMAGE_STEP_SRC2 then v3.n = v3.n + v1.n v4.n = v4.n + v2.n end if v7.n = 0 v8.n = 0 imm_eval ast_get_child(node, 8), v7 imm_eval ast_get_child(node, 9), v8 if flags AND PUTIMAGE_STEP_DEST1 then old_source = _source _source v5.n v7.n = v7.n + point(2) v8.n = v8.n + point(3) _source old_source end if v9.n = _width(v5.n) v10.n = _height(v5.n) imm_eval ast_get_child(node, 10), v9 imm_eval ast_get_child(node, 11), v10 if flags AND PUTIMAGE_STEP_DEST2 then v9.n = v9.n + v7.n v10.n = v10.n + v8.n end if if flags AND PUTIMAGE_SMOOTH then _putimage (v1.n, v2.n)-(v3.n, v4.n), v5.n, v6.n, (v7.n, v8.n)-(v9.n, v10.n), _smooth else _putimage (v1.n, v2.n)-(v3.n, v4.n), v5.n, v6.n, (v7.n, v8.n)-(v9.n, v10.n) end if case TOK__RED32 imm_eval ast_get_child(node, 1), v1 result.n = _red32(v1.n) case TOK__RGB imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 imm_eval ast_get_child(node, 3), v3 v4.n = _dest imm_eval ast_get_child(node, 4), v4 r = _rgb(v1.n, v2.n, v3.n, v4.n) result.n = r case TOK__RGB32 select case ast_num_children(node) case 1 imm_eval ast_get_child(node, 1), v1 r = _rgb32(v1.n) case 2 imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 r = _rgb32(v1.n, v2.n) case 3 imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 imm_eval ast_get_child(node, 3), v3 r = _rgb32(v1.n, v2.n, v3.n) case 4 imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 imm_eval ast_get_child(node, 3), v3 imm_eval ast_get_child(node, 4), v4 r = _rgb32(v1.n, v2.n, v3.n, v4.n) end select result.n = r case TOK_SCREEN 'Ignores second argument imm_eval ast_get_child(node, 1), v1 v2.n = 0 c2 = ast_get_child(node, 3) if not ast_is_none(c2) then imm_eval c2, v2 v3.n = 0 c3 = ast_get_child(node, 4) if not ast_is_none(c3) then imm_eval c3, v3 screen v1.n, , v2.n, v3.n if options.terminal_mode then _screenshow 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'keyboard.bm - Executors for keyboard handling functions case TOK_INKEY result.s = inkey$ case TOK__KEYCLEAR _keyclear case TOK__KEYDOWN imm_eval ast_get_child(node, 1), v1 result.n = _keydown(v1.n) case TOK__KEYHIT result.n = _keyhit 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'logic.bm - Executors for logic operations case TOK_AND imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n and v2.n case TOK_CMP_GT imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n > v2.n case TOK_CMP_GTEQ imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n >= v2.n case TOK_CMP_LT imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n < v2.n case TOK_CMP_LTEQ imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n <= v2.n case TOK_CMP_NEQ imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 if type_of_expr(ast_get_child(node, 1)) = TYPE_STRING then result.n = v1.s <> v2.s else result.n = v1.n <> v2.n case TOK_EQUALS imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 if type_of_expr(ast_get_child(node, 1)) = TYPE_STRING then result.n = v1.s = v2.s else result.n = v1.n = v2.n case TOK_EQV imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n eqv v2.n case TOK_IMP imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n imp v2.n case TOK_NOT imm_eval ast_get_child(node, 1), v1 result.n = not v1.n case TOK_OR imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n or v2.n case TOK_XOR imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n xor v2.n 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'maths.bm - Executors for maths operations case TOK_ABS imm_eval ast_get_child(node, 1), v1 result.n = abs(v1.n) case TOK__ATAN2 imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = _atan2(v1.n, v2.n) case TOK_ATN imm_eval ast_get_child(node, 1), v1 result.n = atn(v1.n) case TOK_BACKSLASH imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n \ v2.n case TOK_COS imm_eval ast_get_child(node, 1), v1 result.n = cos(v1.n) case TOK_DASH imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n - v2.n case TOK_EXP imm_eval ast_get_child(node, 1), v1 result.n = exp(v1.n) case TOK__PI v1.n = 1 c1 = ast_get_child(node, 1) if not ast_is_none(c1) then imm_eval c1, v1 result.n = _pi(v1.n) case TOK_LOG imm_eval ast_get_child(node, 1), v1 result.n = log(v1.n) case TOK_MOD imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n mod v2.n case TOK_POWER imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n ^ v2.n case TOK_NEGATIVE imm_eval ast_get_child(node, 1), v1 result.n = -v1.n case TOK_PLUS imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 if type_of_call(node) = TYPE_STRING then result.s = v1.s + v2.s else result.n = v1.n + v2.n case TOK_SIN imm_eval ast_get_child(node, 1), v1 result.n = sin(v1.n) case TOK_SGN imm_eval ast_get_child(node, 1), v1 result.n = sgn(v1.n) case TOK_SQR imm_eval ast_get_child(node, 1), v1 result.n = sqr(v1.n) case TOK_SLASH imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n / v2.n case TOK_STAR imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = v1.n * v2.n case TOK_TAN imm_eval ast_get_child(node, 1), v1 result.n = tan(v1.n) 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'mouse.bm - Executors for mouse input functions case TOK__MOUSEBUTTON imm_eval ast_get_child(node, 1), v1 result.n = _mousebutton(v1.n) case TOK__MOUSEINPUT result.n = _mouseinput case TOK__MOUSEMOVEMENTX result.n = _mousemovementx case TOK__MOUSEMOVEMENTY result.n = _mousemovementy case TOK__MOUSEWHEEL result.n = _mousewheel case TOK__MOUSEX result.n = _mousex case TOK__MOUSEY result.n = _mousey 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'os.bm - Various OS and environment functions case TOK_COMMAND if ast_is_none(ast_get_child(node, 1)) then result.s = "" for i = input_file_command_offset + 1 to _commandcount result.s = result.s + command$(i) if i <> _commandcount then result.s = result.s + " " next else imm_eval ast_get_child(node, 1), v1 result.s = command$(input_file_command_offset + v1.n) end if case TOK__COMMANDCOUNT result.n = _commandcount - input_file_command_offset case TOK_END v1.n = 0 if not ast_is_none(ast_get_child(node, 1)) then imm_eval ast_get_child(node, 1), v1 'END is only useful when the display will disappear after execution is finished, 'which is not the case when running in terminal mode. $if DEBUG_HEAP then if options.debug then imm_heap_stats $end if if options.terminal_mode then system v1.n else end v1.n case TOK_ENVIRON c1 = ast_get_child(node, 1) imm_eval c1, v1 if type_of_expr(c1) = TYPE_STRING then result.s = environ$(v1.s) else result.s = environ$(v1.n) end if case TOK_RMDIR c1 = ast_get_child(node, 1) imm_eval c1, v1 rmdir v1.s case TOK_SYSTEM v1.n = 0 if not ast_is_none(ast_get_child(node, 1)) then imm_eval ast_get_child(node, 1), v1 $if DEBUG_HEAP then if options.debug then imm_heap_stats $end if system v1.n case TOK__TITLE if return_type = TYPE_STRING then result.s = _title$ else imm_eval ast_get_child(node, 1), v1 _title v1.s end if 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'print.bm - Executor for PRINT statement and friends case TOK_PRINT for i = 1 to ast_num_children(node) child = ast_get_child(node, i) if ast_nodes(child).typ = AST_FLAGS then if ast_nodes(child).ref2 AND PRINT_NEXT_FIELD then print , elseif ast_nodes(child).ref2 AND PRINT_NEWLINE then print end if else imm_eval child, v1 'Need to check type explicitly so we can explicitly give the correct C*() function select case type_of_expr(child) case TYPE_INTEGER print cint(v1.n); case TYPE_LONG print clng(v1.n); case TYPE_INTEGER64 print _round(v1.n); case TYPE_SINGLE if imm_allow_overflow then print v1.n else print csng(v1.n); case TYPE_DOUBLE if imm_allow_overflow then print v1.n else print cdbl(v1.n); case TYPE_QUAD print v1.n; case TYPE_STRING print v1.s; end select end if next i case TOK__PRINTSTRING imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 imm_eval ast_get_child(node, 3), v3 v4.n = _dest c4 = ast_get_child(node, 4) if not ast_is_none(c4) then imm_eval c4, v4 _printstring (v1.n, v2.n), v3.s, v4.n case TOK_RANDOMIZE if ast_num_children(node) = 1 then c1 = ast_get_child(node, 1) if ast_is_none(c1) then randomize else imm_eval c1, v1 randomize v1.n end if else c1 = ast_get_child(node, 2) imm_eval c1, v1 randomize using v1.n end if case TOK_RND c1 = ast_get_child(node, 1) if ast_is_none(c1) then result.n = rnd else imm_eval c1, v1 result.n = rnd(v1.n) end if 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'rounding.bm - Executors for numeric rounding functions case TOK_CDBL, TOK_CINT, TOK_CLNG, TOK_CSNG imm_eval ast_get_child(node, 1), v1 result.n = v1.n case TOK_FIX imm_eval ast_get_child(node, 1), v1 result.n = fix(v1.n) case TOK_INT imm_eval ast_get_child(node, 1), v1 result.n = int(v1.n) 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'screen.bm - Executors for screen management commands case TOK__AUTODISPLAY _autodisplay case TOK_CLS c1 = ast_get_child(node, 1) c2 = ast_get_child(node, 2) if ast_is_none(c1) and ast_is_none(c2) then cls elseif not ast_is_none(c1) then imm_eval c1, v1 cls v1.n elseif not ast_is_none(c2) then imm_eval c2, v2 cls , v2.n else imm_eval c1, v1 imm_eval c2, v2 cls v1.n, v2.n end if case TOK_COLOR v1.n = _defaultcolor v2.n = _backgroundcolor c1 = ast_get_child(node, 1) c2 = ast_get_child(node, 2) if not ast_is_none(c1) then imm_eval c1, v1 if not ast_is_none(c2) then imm_eval c2, v2 color v1.n, v2.n case TOK_CSRLIN result.n = csrlin case TOK__DEST if return_type = TYPE_NONE then imm_eval ast_get_child(node, 1), v1 _dest v1.n else result.n = _dest end if case TOK__DISPLAY _display case TOK__HEIGHT c1 = ast_get_child(node, 1) if ast_is_none(c1) then v1.n = _dest else imm_eval c1, v1 end if result.n = _height(v1.n) case TOK_LOCATE v1.n = csrlin v2.n = pos(0) imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 cursor = ast_get_child(node, 3) imm_eval cursor, v3 if ast_num_children(node) = 5 then imm_eval ast_get_child(node, 4), v4 imm_eval ast_get_child(node, 5), v5 if ast_is_none(cursor) then locate v1.n, v2.n, , v4.n, v5.n else locate v1.n, v2.n, v3.n, v4.n, v5.n end if else if ast_is_none(cursor) then locate v1.n, v2.n else locate v1.n, v2.n, v3.n end if end if case TOK_POINT if ast_num_children(node) = 1 then imm_eval ast_get_child(node, 1), v1 result.n = point(v1.n) else imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 r = point(v1.n, v2.n) result.n = r end if case TOK__SOURCE if return_type = TYPE_NONE then imm_eval ast_get_child(node, 1), v1 _source v1.n else result.n = _source end if case TOK__WIDTH c1 = ast_get_child(node, 1) if ast_is_none(c1) then v1.n = _dest else imm_eval c1, v1 end if result.n = _width(v1.n) 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'sound.bm - Executors for sound functions case TOK_BEEP beep case TOK_PLAY imm_eval ast_get_child(node, 1), v1 play v1.s case TOK_SOUND imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 sound v1.n, v2.n 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'string.bm - Executors for string manipulation functions case TOK_ASC imm_eval ast_get_child(node, 1), v1 if not ast_is_none(ast_get_child(node, 2)) then imm_eval ast_get_child(node, 2), v2 result.n = asc(v1.s, v2.n) else result.n = asc(v1.s) end if case TOK_CHR imm_eval ast_get_child(node, 1), v1 result.s = chr$(v1.n) case TOK_CVD imm_eval ast_get_child(node, 1), v1 result.n = cvd(v1.s) case TOK_CVDMBF imm_eval ast_get_child(node, 1), v1 result.n = cvdmbf(v1.s) case TOK_CVI imm_eval ast_get_child(node, 1), v1 result.n = cvi(v1.s) case TOK_CVL imm_eval ast_get_child(node, 1), v1 result.n = cvl(v1.s) case TOK_CVS imm_eval ast_get_child(node, 1), v1 result.n = cvs(v1.s) case TOK_CVSMBF imm_eval ast_get_child(node, 1), v1 result.n = cvsmbf(v1.s) case TOK__DEFLATE imm_eval ast_get_child(node, 1), v1 result.s = _deflate$(v1.s) case TOK_HEX imm_eval ast_get_child(node, 1), v1 result.s = hex$(v1.n) case TOK__INFLATE imm_eval ast_get_child(node, 1), v1 result.s = _inflate$(v1.s) case TOK_INSTR v1.n = 1 haystack = 1 'TODO: Make this use signature identifiers or something if ast_num_children(node) = 3 then haystack = 2 imm_eval ast_get_child(node, 1), v1 end if imm_eval ast_get_child(node, haystack), v2 imm_eval ast_get_child(node, haystack + 1), v3 result.n = instr(v1.n, v2.s, v3.s) case TOK_LEFT imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.s = left$(v1.s, v2.n) case TOK_LCASE imm_eval ast_get_child(node, 1), v1 result.s = lcase$(v1.s) case TOK_LTRIM imm_eval ast_get_child(node,1), v1 result.s = ltrim$(v1.s) case TOK_MID imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 if not ast_is_none(ast_get_child(node, 3)) then imm_eval ast_get_child(node, 3), v3 result.s = mid$(v1.s, v2.n, v3.n) else result.s = mid$(v1.s, v2.n) end if case TOK_RIGHT imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.s = right$(v1.s, v2.n) case TOK_RTRIM imm_eval ast_get_child(node, 1), v1 result.s = rtrim$(v1.s) case TOK_SPACE imm_eval ast_get_child(node, 1), v1 result.s = space$(v1.n) case TOK_STR imm_eval ast_get_child(node, 1), v1 result.s = str$(v1.n) case TOK__STRCMP imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = _strcmp(v1.s,v2.s) case TOK__STRICMP imm_eval ast_get_child(node, 1), v1 imm_eval ast_get_child(node, 2), v2 result.n = _stricmp(v1.s,v2.s) case TOK__TRIM imm_eval ast_get_child(node, 1), v1 result.s = _trim$(v1.s) case TOK_UCASE imm_eval ast_get_child(node, 1), v1 result.s = ucase$(v1.s) case TOK_VAL imm_eval ast_get_child(node, 1), v1 result.n = val(v1.s) 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'time.bm - Executors for time and date related functions case TOK_DATE result.s = date$ case TOK__DELAY imm_eval ast_get_child(node, 1), v1 _delay v1.n case TOK__LIMIT imm_eval ast_get_child(node, 1), v1 _limit v1.n case TOK_SLEEP period = ast_get_child(node, 1) if ast_is_none(period) then sleep else imm_eval period, v1 sleep v1.n end if case TOK_TIME result.s = time$ case TOK_TIMER c1 = ast_get_child(node, 1) if ast_is_none(c1) then result.n = timer else imm_eval c1, v1 result.n = timer(v1.n) end if 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'varinfo.bm - Various variable interrogation function case TOK_DIM 'This is the DIM function child = ast_get_child(node, 1) imm_eval child, v1 result.n = imm_get_at_addr_n(imm_add_offset(v1.n, 1)) case TOK_ERASE child = ast_get_child(node, 1) addr = imm_get_addr(child) data_addr = imm_get_at_addr_n(addr) if data_addr <> 0 then imm_heap_free data_addr imm_set_at_addr_n addr, 0 end if case TOK_OPTION 'The OPTION function to check if an OPTION variable was passed child = ast_get_child(node, 1) if ast_nodes(child).typ <> AST_VAR then 'TODO: Implement imm_error "OPTION check not supported on arrays & UDTs" end if sym = ast_nodes(child).ref if (symtab(sym).v3 AND SYM_VARIABLE_DEREF) = 0 then 'Not pass-by-reference, so could not have been optional result.n = TRUE else 'Don't use imm_get_addr because that'll attempt to dereference addr = imm_stack_base + symtab(sym).v2 if imm_get_at_addr_n(addr) then result.n = TRUE else result.n = FALSE end if end if case TOK_LEN child = ast_get_child(node, 1) imm_eval child, v1 select case type_of_expr(child) case TYPE_INTEGER result.n = len(dummy_integer%) case TYPE_LONG result.n = len(dummy_long&) case TYPE_INTEGER64 result.n = len(dummy_int64&&) case TYPE_SINGLE result.n = len(dummy_single!) case TYPE_DOUBLE result.n = len(dummy_double#) case TYPE_QUAD 'QB64 gives this as 32, but should be 16 result.n = len(dummy_quad##) case TYPE_STRING result.n = len(v1.s) end select case TOK_LBOUND imm_eval ast_get_child(node, 1), v1 dimension = ast_get_child(node, 2) if ast_is_none(dimension) then v2.n = 1 else imm_eval dimension, v2 if v2.n < 1 or v2.n > imm_get_at_addr_n(imm_add_offset(v1.n, 1)) then error 9 end if result.n = imm_get_at_addr_n(imm_add_offset(v1.n, v2.n * 2)) case TOK_SWAP l = ast_get_child(node, 1) r = ast_get_child(node, 2) l_addr = imm_get_addr(l) r_addr = imm_get_addr(r) l_type = type_of_lvalue(l) r_type = type_of_lvalue(r) 'TODO check this at compile time! if l_type <> r_type then imm_error "Bad SWAP" for i = 1 to type_fixed_size(l_type) imm_get_at_addr l_addr, v1 imm_get_at_addr r_addr, v2 imm_set_at_addr l_addr, v2 imm_set_at_addr r_addr, v1 next i case TOK_UBOUND imm_eval ast_get_child(node, 1), v1 dimension = ast_get_child(node, 2) if ast_is_none(dimension) then v2.n = 1 else imm_eval dimension, v2 if v2.n < 1 or v2.n > imm_get_at_addr_n(imm_add_offset(v1.n, 1)) then error 9 end if result.n = imm_get_at_addr_n(imm_add_offset(v1.n, v2.n * 2 + 1)) case else imm_error "Unhandled call to " + tok_human_readable$(ast_nodes(node).ref) end select imm_enforce_type result, type_of_call(node) end sub sub imm_do_call_userfunc(node, result as imm_value_t) proc_id = ast_nodes(node).ref proc_node = symtab(proc_id).v3 num_locals = symtab(proc_id).v4 if proc_node = 0 then imm_error "Call to unimplemented function" 'Create new stack frame $if DEBUG_MEM_TRACE then debuginfo "New stack frame at" + str$(imm_stack_last + 1) debuginfo "Allocate" + str$(num_locals) + " slots" $end if old_stack_last = imm_stack_last old_stack_base = imm_stack_base imm_reinit imm_stack_last + num_locals 'Evaluate and store arguments, left to right dim arg as imm_value_t for i = 1 to ast_num_children(node) arg_node = ast_get_child(node, i) if i > ast_num_children(proc_node) - 1 then 'This should only happen when the function definition doesn't declare 'all parameters, such as for overriding functions. 'We still need to evaluate the argument being passed though in case 'it has side effects. imm_eval arg_node, arg elseif ast_nodes(arg_node).typ = AST_NONE then 'Not supplied optional argument, pass a null pointer imm_set_at_addr_n old_stack_last + i, 0 elseif symtab(ast_nodes(ast_get_child(proc_node, i + 1)).ref).v3 AND SYM_VARIABLE_DEREF then 'Callee needs a reference. Can we just provide a pointer to a passed variable? if ast_is_lvalue(arg_node) then 'Yes, passed argument is an lvalue so we can get a reference to it imm_set_at_addr_n old_stack_last + i, imm_get_addr(arg_node) else 'No, we need to make a shadow copy and pass a reference to that. 'The shadow copy will also be on the stack. imm_reinit imm_stack_last + 1 imm_eval arg_node, arg imm_set_at_addr imm_stack_last, arg imm_set_at_addr_n old_stack_last + i, imm_stack_last end if else 'Force pass-by-value arg_node = ast_get_child(node, i) imm_eval arg_node, arg imm_set_at_addr old_stack_last + i, arg end if next i 'If we're expected to return a value, allocate an extra stack slot 'after the formal arguments and shadow copies to hold that value if type_sig_return(ast_nodes(node).ref2) <> TYPE_NONE then has_return_value = TRUE imm_reinit imm_stack_last + 1 'This must be zeroed out so that if the function returns a reference, 'we can free referenced objects in the case that successive return values 'are set. imm_set_at_addr_n imm_stack_last, 0 end if 'Set frame pointer appropriately (delayed to here so argument evaluation 'occurs in the caller's stack frame) imm_stack_base = old_stack_last + 1 'Do the call! imm_eval ast_get_child(symtab(proc_id).v3, 1), result 'Collect return value if relevant if has_return_value then imm_get_at_addr imm_stack_last, result 'Restore previous stack frame imm_stack_last = imm_stack_base imm_stack_base = old_stack_base 'If we exited early, clear the exit flag (no need to actually check it because 'we can't nest functions). imm_exit_node = 0 end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'eval.bm - Top level executor function sub imm_eval(node, result as imm_value_t) imm_eval_stack_last = imm_eval_stack_last + 1 if imm_eval_stack_last > ubound(imm_eval_stack) then redim _preserve imm_eval_stack(imm_eval_stack_last) end if imm_eval_stack(imm_eval_stack_last) = node select case ast_nodes(node).typ case AST_ASSIGN imm_do_assign node case AST_IF imm_do_conditional node case AST_WHILE imm_do_do_pre node case AST_DO_PRE imm_do_do_pre node case AST_DO_POST imm_do_do_post node case AST_FOR imm_do_for node case AST_SELECT imm_do_select node case AST_SELECT_VALUE result = imm_select_value case AST_CALL, AST_SELECT_IS imm_do_call node, result case AST_CONSTANT if type_of_constant(node) = TYPE_STRING then result.s = ast_constants(ast_nodes(node).ref) else result.n = val(ast_constants(ast_nodes(node).ref)) end if case AST_BLOCK imm_do_block node, result case AST_VAR, AST_UDT_ACCESS, AST_ARRAY_ACCESS addr = imm_get_addr(node) 'Take address for a full UDT or array if symtab(type_of_lvalue(node)).v2 then result.n = addr else imm_get_at_addr addr, result end if case AST_ARRAY_CREATE imm_do_array_resize node, FALSE case AST_ARRAY_RESIZE imm_do_array_resize node, TRUE case AST_ARRAY_DELETE imm_do_array_delete node case AST_ARRAY_ESTABLISH imm_do_array_establish node case AST_CAST imm_do_cast node, result case AST_GOTO imm_do_goto node case AST_EXIT imm_exit_node = ast_nodes(node).ref case AST_SET_RETURN dim temp as imm_value_t child = ast_get_child(node, 1) imm_eval child, temp if type_is_array(ast_nodes(node).ref) then 'Clear previously-set return value, if any imm_array_delete imm_get_at_addr_n(imm_stack_last) imm_set_at_addr_n imm_stack_last, 0 imm_array_copy temp.n, imm_stack_last, TRUE else imm_set_at_addr imm_stack_last, temp end if case AST_NONE 'do nothing case else imm_error "Cannot eval node " + str$(node) end select imm_eval_stack_last = imm_eval_stack_last - 1 end sub sub imm_do_cast(node, result as imm_value_t) imm_eval ast_get_child(node, 1), result imm_enforce_type result, ast_nodes(node).ref end sub sub imm_enforce_type(result as imm_value_t, typ) select case typ case TYPE_INTEGER if imm_allow_overflow then dummy% = result.n result.n = dummy% else result.n = cint(result.n) end if case TYPE_LONG if imm_allow_overflow then dummy& = result.n result.n = dummy& else result.n = clng(result.n) end if case TYPE_INTEGER64 if imm_allow_overflow then dummy&& = result.n result.n = dummy&& else result.n = _round(result.n) if result.n < -2147483648 or result.n > 2147483647 then error 6 end if case TYPE_SINGLE if imm_allow_overflow then dummy! = result.n result.n = dummy! else result.n = csng(result.n) end if case TYPE_DOUBLE if imm_allow_overflow then dummy# = result.n result.n = dummy# else result.n = cdbl(result.n) end if case TYPE_QUAD, TYPE_STRING 'Nothing to do here end select end sub sub imm_show_eval_stack print #logging_file_handle, "Eval stack (most recent eval last):" for i = 1 to imm_eval_stack_last ast_dump_summary imm_eval_stack(i), TRUE next i end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'for.bm - Executor for FOR loop sub imm_do_for(node) dim start_val as imm_value_t dim end_val as imm_value_t dim step_val as imm_value_t iterator_addr = imm_get_addr(ast_get_child(node, 1)) if imm_next_jump = 0 then 'If we're GOTOing the middle of the loop, the start value isn't even evaluated imm_eval ast_get_child(node, 2), start_val imm_set_at_addr iterator_addr, start_val end if imm_eval ast_get_child(node, 3), end_val imm_eval ast_get_child(node, 4), step_val block = ast_get_child(node, 5) direction = sgn(step_val.n) if direction = 0 then direction = 1 do while (direction = 1 and imm_get_at_addr_n(iterator_addr) <= end_val.n) or _ (direction = -1 and imm_get_at_addr_n(iterator_addr) >= end_val.n) or _ imm_next_jump > 0 imm_run block if imm_next_jump then exit sub if imm_exit_node > 0 and imm_exit_node = node then imm_exit_node = 0 exit sub elseif imm_exit_node > 0 then exit sub end if imm_set_at_addr_n iterator_addr, imm_get_at_addr_n(iterator_addr) + step_val.n loop end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'goto.bm - Executor for GOTO and utility functions for managing jumps sub imm_do_goto(node) n = ast_nodes(node).ref imm_jump_path$ = ast_path_from_ancestor$(node, n) '?"Jump path: "; 'for i = 1 to len(imm_jump_path$) step 4 ' print cvl(mid$(imm_jump_path$, i, 4)); 'next i '? end sub function imm_next_jump if len(imm_jump_path$) = 0 then exit function imm_next_jump = cvl(left$(imm_jump_path$, 4)) end function sub imm_trim_jump imm_jump_path$ = mid$(imm_jump_path$, 5) end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'heap.bm - Heap data management 'The heap is used for allocating dynamically sized objects, or objects 'that are not necessarily tied to a single function's scope. ' 'Block header: ' - size of region, including header ' - pointer to next free region 'Blocks are in a cyclic linked list. ' 'The list of free blocks is searched until a suitable sized block is found. 'If the block is bigger than needed, the tail end is returned. Blocks are 'always allocated in sizes a multiple of IMM_HEAP_HEADER_SIZE. Freed blocks 'will be coalesced with an adjacent free block if possible. ' 'This is based on the allocator presented in Chapter 8.7 of K&R C. 'Allocate 'req_elems' elements on the heap and return start address. function imm_heap_alloc(req_elems) 'Calculate needed size to the next multiple of IMM_HEAP_HEADER_SIZE, 'including +1 for the header itself. nelems = (_ceil(req_elems / IMM_HEAP_HEADER_SIZE) + 1) * IMM_HEAP_HEADER_SIZE prevp = imm_heap_next_free p = imm_heap(prevp + 1).n do if (imm_heap(p).n >= nelems) then 'big enough if (imm_heap(p).n = nelems) then 'exactly imm_heap(prevp + 1).n = imm_heap(p + 1).n else 'split block, allocate tail end imm_heap(p).n = imm_heap(p).n - nelems p = p + imm_heap(p).n imm_heap(p).n = nelems end if imm_heap_next_free = prevp imm_heap_alloc = -(p + IMM_HEAP_HEADER_SIZE) $if DEBUG_HEAP then imm_heap_current_blocks = imm_heap_current_blocks + 1 imm_heap_current_bytes = imm_heap_current_bytes + nelems if imm_heap_current_blocks > imm_heap_max_blocks then imm_heap_max_blocks = imm_heap_current_blocks if imm_heap_current_bytes > imm_heap_max_bytes then imm_heap_max_bytes = imm_heap_current_bytes debuginfo "Allocated" + str$(nelems) + " elements at " + str$(-p - IMM_HEAP_HEADER_SIZE) $end if exit function end if if p = imm_heap_next_free then 'wrapped around free list p = imm_heap_expand(nelems) end if prevp = p p = imm_heap(p + 1).n loop end function 'Make a copy of the block at address function imm_heap_copy_alloc(address) size = imm_heap(-address - IMM_HEAP_HEADER_SIZE).n - IMM_HEAP_HEADER_SIZE new_block = imm_heap_alloc(size) $if DEBUG_HEAP then debuginfo "Copying" + str$(size) + " elements from " + str$(address) + " to " + str$(new_block) $end if for i = 0 to size - 1 imm_heap(-new_block + i) = imm_heap(-address + i) next i imm_heap_copy_alloc = new_block end function 'Free allocation at 'address' sub imm_heap_free(address) data_addr = -address addr = data_addr - IMM_HEAP_HEADER_SIZE p = imm_heap_next_free 'Start at next free block 'Search for p s.t. addr is between p and next block address while not (addr > p and addr < imm_heap(p + 1).n) if p >= imm_heap(p + 1).n and (addr > p or addr < imm_heap(p + 1).n) then 'Freed block at start or end of memory region exit while end if p = imm_heap(p + 1).n wend if addr + imm_heap(addr).n = imm_heap(p + 1).n then 'Adjacent to upper block imm_heap(addr).n = imm_heap(addr).n + imm_heap(imm_heap(p + 1).n).n imm_heap(addr + 1).n = imm_heap(imm_heap(p + 1).n + 1).n else imm_heap(addr + 1).n = imm_heap(p + 1).n end if if p + imm_heap(p).n = addr then 'Adjacent to lower block imm_heap(p).n = imm_heap(p).n + imm_heap(addr).n imm_heap(p + 1).n = imm_heap(addr + 1).n else imm_heap(p + 1).n = addr end if imm_heap_next_free = p $if DEBUG_HEAP then imm_heap_current_blocks = imm_heap_current_blocks - 1 imm_heap_current_bytes = imm_heap_current_bytes - imm_heap(addr).n debuginfo "Freed" + str$(imm_heap(addr).n) + " elements at " + str$(address) $end if end sub 'Setup initial heap sub imm_heap_init redim imm_heap(1 to 2) as imm_value_t imm_heap(1).n = 0 imm_heap(2).n = 1 imm_heap_next_free = 1 end sub 'Increase the total heap size by adding new memory to list function imm_heap_expand(nu) const IMM_HEAP_MIN_ALLOC = 1024 'Value from K&R, rather arbitrary nelems = nu if nelems < IMM_HEAP_MIN_ALLOC then nelems = IMM_HEAP_MIN_ALLOC new_mem = ubound(imm_heap) + 1 redim _preserve imm_heap(1 to ubound(imm_heap) + nelems) as imm_value_t $if DEBUG_HEAP then debuginfo "Expand heap to" + str$(ubound(imm_heap)) + " elements" imm_heap_current_blocks = imm_heap_current_blocks + 1 imm_heap_current_bytes = imm_heap_current_bytes + nelems $end if imm_heap(new_mem).n = nelems imm_heap_free -(new_mem + IMM_HEAP_HEADER_SIZE) imm_heap_expand = imm_heap_next_free end sub sub imm_heap_stats print #logging_file_handle, "Total heap allocation:"; ubound(imm_heap); " elements" print #logging_file_handle, "Current heap:"; imm_heap_current_blocks; " blocks /"; imm_heap_current_bytes; " elements" print #logging_file_handle, "Max heap:"; imm_heap_max_blocks; " blocks /"; imm_heap_max_bytes; " elements" end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'if.bm - Executor for IF statement sub imm_do_conditional(node) if imm_next_jump then 'Don't start at top, we're GOTOing a point imm_run imm_next_jump exit sub end if dim condition as imm_value_t for clause = 1 to ast_num_children(node) \ 2 imm_eval ast_get_child(node, clause * 2 - 1), condition if condition.n then imm_run ast_get_child(node, clause * 2) exit sub end if next clause if ast_num_children(node) mod 2 then imm_run ast_get_child(node, ast_num_children(node)) end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'loop.bm - Executor for DO LOOP and WHILE WEND 'Also used for WHILE WEND loops sub imm_do_do_pre(node) dim temp as imm_value_t guard = ast_get_child(node, 1) block = ast_get_child(node, 2) if imm_next_jump = 0 then imm_eval guard, temp do while temp.n <> 0 or imm_next_jump <> 0 imm_run block if imm_next_jump then exit sub if imm_exit_node > 0 and imm_exit_node = node then imm_exit_node = 0 exit sub elseif imm_exit_node > 0 then exit sub end if imm_eval guard, temp loop end sub sub imm_do_do_post(node) dim temp as imm_value_t guard = ast_get_child(node, 1) block = ast_get_child(node, 2) do imm_run block if imm_next_jump then exit sub if imm_exit_node > 0 and imm_exit_node = node then imm_exit_node = 0 exit sub elseif imm_exit_node > 0 then exit sub end if imm_eval guard, temp loop while temp.n end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'memory.bm - Memory access and addressing routines function imm_add_offset(base_addr, offset) 'The base_addr might be negative if it is a heap address, so "pass through" 'the negative sign. e.g. base_addr = -10, offset = 2, result = -12 imm_add_offset = (abs(base_addr) + offset) * sgn(base_addr) end function 'Get the address of a variable. Handles simple scalars, elments of nested UDTs & arrays, 'and entire UDTs & arrays. If the returned value is < 0, it is a heap address. Otherwise, 'it is a stack address. function imm_get_addr(node) addr = imm_get_addr_loc(node) if imm_needs_deref(node) then if addr = 0 then imm_error "Access to uninitialised variable" addr = imm_get_at_addr_n(addr) end if imm_get_addr = addr end function function imm_needs_deref(node) 'TODO: Is a dereference check needed for UDT or array accesses? imm_needs_deref = ast_nodes(node).typ = AST_VAR and symtab(ast_nodes(node).ref).v3 AND SYM_VARIABLE_DEREF end function 'Like imm_get_addr, but does not do a final dereference even if the variable is a 'reference. This is useful for initialising or otherwise setting the actual address 'of a variable. function imm_get_addr_loc(node) select case ast_nodes(node).typ case AST_VAR if symtab(ast_nodes(node).ref).v3 AND SYM_VARIABLE_MAINFRAME then 'shared or static variable '+1 because the addresses are offsets, but memory starts at 1 imm_get_addr_loc = 1 + symtab(ast_nodes(node).ref).v2 else 'local variable imm_get_addr_loc = imm_stack_base + symtab(ast_nodes(node).ref).v2 end if case AST_UDT_ACCESS base_addr = imm_get_addr(ast_get_child(node, 1)) offset = symtab(ast_nodes(node).ref).v2 imm_get_addr_loc = imm_add_offset(base_addr, offset) case AST_ARRAY_ACCESS array = ast_get_child(node, 1) array_type = type_of_lvalue(array) info_base_addr = imm_get_addr(array) if info_base_addr = 0 then imm_error "Access to uninitialised array" element_type = symtab(array_type).v3 dimensions = imm_get_at_addr_n(imm_add_offset(info_base_addr, 1)) 'Make sure we have precisely enough indicies for the number of dimensions if dimensions <> ast_num_children(node) - 1 then imm_error "Incorrect number of indicies for array access" end if 'Array descriptor: ' - pointer to data ' - number of dimensions ' - lbound of leftmost dimension ' - ubound of leftmost dimension ' - etc. ' - lbound of rightmost dimension ' - ubound of rightmost dimension block_size = 1 for i = 1 to dimensions dim index as imm_value_t lower_bound = imm_get_at_addr_n(imm_add_offset(info_base_addr, i * 2)) upper_bound = imm_get_at_addr_n(imm_add_offset(info_base_addr, i * 2 + 1)) imm_eval ast_get_child(node, i + 1), index if index.n < lower_bound or index.n > upper_bound then imm_error "Array access out of bounds" end if offset = offset + (index.n - lower_bound) * block_size block_size = upper_bound - lower_bound + 1 next i offset = offset * type_fixed_size(element_type) imm_get_addr_loc = imm_add_offset(imm_get_at_addr_n(info_base_addr), offset) case else imm_error "Attempt to take address of something not an lvalue" end select end function sub imm_set_at_addr(addr, v as imm_value_t) $if DEBUG_MEM_TRACE then debuginfo "Write [" + str$(addr) + " ] = " + str$(v.n) + " " + v.s $end if if addr < 0 then imm_heap(-addr) = v elseif addr > 0 then imm_stack(addr) = v else imm_error "Null pointer value write" end if end sub sub imm_set_at_addr_s(addr, v$) $if DEBUG_MEM_TRACE then debuginfo "Write [" + str$(addr) + " ] =" + v$ $end if if addr < 0 then imm_heap(-addr).s = v$ elseif addr > 0 then imm_stack(addr).s = v$ else imm_error "Null pointer string write" end if end sub sub imm_set_at_addr_n(addr, n as _float) $if DEBUG_MEM_TRACE then debuginfo "Write [" + str$(addr) + " ] =" + str$(n) $end if if addr < 0 then imm_heap(-addr).n = n elseif addr > 0 then imm_stack(addr).n = n else imm_error "Null pointer numeric write" end if end sub sub imm_get_at_addr(addr, v as imm_value_t) $if DEBUG_MEM_TRACE then debuginfo "Read [" + str$(addr) + " ]" $end if if addr < 0 then v = imm_heap(-addr) elseif addr > 0 then v = imm_stack(addr) else imm_error "Null pointer value read" end if $if DEBUG_MEM_TRACE then debuginfo "=" + str$(v.n) + " " + v.s $end if end sub function imm_get_at_addr_s$(addr) $if DEBUG_MEM_TRACE then debuginfo "Read [" + str$(addr) + " ]" $end if if addr < 0 then r$ = imm_heap(-addr).s elseif addr > 0 then r$ = imm_stack(addr).s else imm_error "Null pointer string read" end if imm_get_at_addr_s$ = r$ $if DEBUG_MEM_TRACE then debuginfo "=" + r$ $end if end sub function imm_get_at_addr_n##(addr) $if DEBUG_MEM_TRACE then debuginfo "Read [" + str$(addr) + " ]" $end if if addr < 0 then r## = imm_heap(-addr).n elseif addr > 0 then r## = imm_stack(addr).n else imm_error "Null pointer numeric read" end if imm_get_at_addr_n## = r## $if DEBUG_MEM_TRACE then debuginfo "=" + str$(r##) $end if end function sub imm_memset(addr, size, value as imm_value_t) $if DEBUG_MEM_TRACE then debuginfo "Write [" + str$(addr) + "+" + str$(size) + "] =" + str$(value.n) + " " + value.s $end if if addr < 0 then for i = addr to imm_add_offset(addr, size - 1) step -1 imm_heap(-i).s = value.s imm_heap(-i).n = value.n next i elseif addr > 0 then for i = addr to imm_add_offset(addr, size - 1) imm_stack(i).s = value.s imm_stack(i).n = value.n next i else imm_error "Null pointer write" end if end sub 'Copyright 2020 Luke Ceddia 'SPDX-License-Identifier: Apache-2.0 'select.bm - Executor for SELECT statement sub imm_do_select(node) if imm_next_jump then 'We're GOTOing a point imm_trim_jump 'Remove AST_SELECT_LIST or AST_SELECT_ELSE imm_run imm_next_jump exit sub end if dim base_expr as imm_value_t base_node = ast_get_child(node, 1) base_type = type_of_expr(base_node) imm_eval base_node, base_expr for i = 2 to ast_num_children(node) child = ast_get_child(node, i) select case ast_nodes(child).typ case AST_SELECT_LIST 'If any of the guards are true, execute the block for j = 1 to ast_num_children(child) - 1 guard = ast_get_child(child, j) if imm_select_eval_guard(guard, base_type, base_expr) then imm_run ast_get_child(child, ast_num_children(child)) exit sub end if next j case AST_SELECT_ELSE imm_run ast_get_child(child, 1) exit sub case else imm_error "Malformed SELECT CASE" end select next i end sub function imm_select_eval_guard(guard, base_type, base_expr as imm_value_t) dim as imm_value_t l, r select case ast_nodes(guard).typ case AST_SELECT_RANGE imm_eval ast_get_child(guard, 1), l imm_eval ast_get_child(guard, 2), r if type_is_number(base_type) then if l.n <= base_expr.n and base_expr.n <= r.n then imm_select_eval_guard = TRUE elseif base_type = TYPE_STRING then if l.s <= base_expr.s and base_expr.s <= r.s then imm_select_eval_guard = TRUE else imm_error "Cannot evaluate range" end if case AST_SELECT_IS 'Because evaluating a guard could result in calling a function 'that uses SELECT CASE, we ensure the select value is current here. imm_select_value = base_expr imm_eval guard, l imm_select_eval_guard = l.n end select end function