Re: EDB.EXW Database Browser
- Posted by jimcbrown (admin) Sep 11, 2010
- 1715 views
ghaberek said...
It seems to me that euscript.e is shrouded in the old Euphoria 2.x encrypted shroud format.
Can it be unshrouded?
I have a copy of euscript.e somewhere, if it helps..
with trace ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- --/topic Introduction --/info -- -- EuScript v0.2<br> -- (C) 2003 Matt Lewis -- converted to scripting engine -- -- Euphoria emulator v. 0.3<br> -- (c) 1999 David Cuny up to 0.2b<br> -- (C) Dec, 1999 Delroy Gayle -- --This was originally released as Eu.ex by David Cuny, later taken over by --Delroy Gayle, whose last release was in December of 1999. It was meant --to be a Euphoria interpreter written in Euphoria, and was used in the --same way (i.e., at the command line: "ex eu.ex myapp.ex"). -- --In 2000, Matt Lewis converted Eu.ex in euscript.e, which allows it to be used --as an embedded scripting engine for his Euphoria programs. In 2003, he --cleaned it up and released it to the public. -- --/code --LICENSE: --THIS SOFTWARE IS FREEWARE. YOU MAY DO WHAT YOU WISH WITH IT, BUT YOU MUST --GIVE CREDIT TO THE ORIGINAL AUTHORS. -- --DISCLAIMER: --THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, --INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY --AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, --OR CONSEQUENTIAL DAMGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF --SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFIT; OR BUSINESS --INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN --CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) --ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE --POSSIBILITY OF SUCH DAMAGE. --/endcode -- Eu.ex -- -- Euphoria emulator v. 0.3 -- (c) 1999 David Cuny up to 0.2b -- (C) Dec, 1999 Delroy Gayle -- (C) 2003 Matt Lewis -- converted to scripting engine --/topic Changes --/info --History of euscript --/code -- -- v0.2 -- 9/2/03 - Fixed include mechanism -- -- v0.1 -- 7/14/03 - Released as euscript -- -- v0.0 --12/12/00 -- EuScript .01 Matt Lewis -- Converting Eu to run Euphoria scripts instead of full programs -- * Put var initialization into init_eu() -- * Added majukscript extensions -- * Commented out non-scriptible routines (ie, print, peek, etc) -- * namespace collisions with Win32Lib (True/False, returnValue) -- -- Eu.ex Change history: -- -- 09.14.99 - DC -- added platform() -- -- 3.12.99 - DG -- Tested Eu with DOS32lib.e ... works fine except for EX06, EX18 & EX15 -- -- While testing, EU found a bug with 'font.e' in conjunction with EX15!! -- via EU typechecking -- font.e line 22 'chars' is 67 when it ought to be a sequence! -- -- It seems that EU has a problem with 'menu-handling' -- -- While testing, EU found a bug with 'dos32lib.e v.4'!! -- via EU routine_id -- line 3496 should be saying -- classShow[ List ] = routine_id( "showListBox" ) -- NOT classShow[ List ] = routine_id( "showList" ) -- -- implemented: -- routine_id - amended 'call_func_', 'call_proc_', 'routine_id_' -- accordingly - 30.10.1999 - Delroy Gayle -- -- SANITY15 (1.5 version) ok ... takes between 2-3 mins on a P150 with EU -- LW15.EX (1.5 version) ok ... with NO SHORT-CIRCUITING -- -- PLEASE NOTE: when testing 'SANITY, LW & DOS32LIB' i.e. graphic programs -- in general; set TRACE_LINES to 0 not 5, -- because of EU's usage of 'position/get_position' -- -- PLEASE NOTE: when testing 'LW15' keep shortCircuitFlag 0 not 1 -- within routine 'parse'; because AND_CIRCUITING was not before 2.1 -- -- While testing, EU found a bug with 'queens.ex'!! -- via EU typechecking -- line 85 should be 'integer r' not 'row r' because r can be > N!! -- you can verify this by switching type-checking ON in queens.ex! -- -- 29.10.99 - DG -- In this version, add the missing features: -- short-circuited 'or' & routine_id -- DG15 DG16 -- -- 'or' must be short-circuited in IF & WHILE -- -- hence CSORT.EX ok -- ALLSORTS.EX ok -- SANITY21.EX ok ... takes between 2-3 mins on a P150 with EU -- LW.EX (2.1 version) ok -- ONLY when type-checking is OFF i.e. typeCheckFlag=0 !!! Because -- there is an actual type/check error in SCREEN.E concerning the -- global type 'image' ... you can reproduce this by switching on -- type-checking on in LW.EX and you will see the error at -- line 221 -- --------- concerning the FOR LOOP bug -- Dear David Cuny - it appears that there is a 'nested FOR loop' bug -- in EUPHORIA!!! -- After fixing the bug that was 'removing' the wrong variables - DG6 -- I attempted to run a simple 'nested FOR loop' and it failed! -- See Test36.ex & Test37.ex - look at the profile files as well -- The inner loop runs 6 times but the outer loop ONLY ONCE!! -- I traced it and there is no logical reason why the outer loop -- should not loop 5 times ... hence a BUG IN EUPHORIA 2.1 !!! -- I have informed RDS -- -- Therefore, changed the FOR Loop into a WHILE LOOP - DG18 -- -- 20.10.99 - DG -- Will commence to 'debug' this program!! -- 1) change all while 1 do ==> while true do -- 'TRUE' already in use! -- 2) automatically supply '.ex' -- 3) show which missing quote (" or ') -- 4) make the scanner TIGHTER for numbers (dec & hex) & identifiers -- 5) 'command_line()' IS A FUNCTION not a procedure! -- 'find(x,s)' s -- sequence! -- 'power(x1,x2)' -- BOTH objects not atoms! -- 'prepend(s1,x)' -- x IS A object not atom! -- 'system_exec(st,i2)' IS A FUNCTION not a procedure! --- 6) FOR Loop bug is fixed - introduced FOR_LOOP_INDEX -- 7) When subscripting, positive decimal numbers CAN BE USED -- which are in turn ROUNDED DOWN (FLOORed) i.e. -- y[2.4]==>y[2] y[1.3]==>y[1] -- 8) return NO_OP as a sequence i.e.{ { NO_OP } } -- since ALL procedures are 'a sequence of a sequence' -- 9) the parser DID NOT reflect that * / had HIGHER precedence than + - etc -- Also, there was an Associativity bug with arithmetic -- 5-1+1==>5 was being parsed as (5-(1+1))==>3 -- The Parser ought to associate to the LEFT -- i.e. reflect LEFT-TO-RIGHT evaluation -- Likewise for multiplication, division and concatenation -- Likewise for the comparison operators -- 10) 'xor_bits_' not 'xor_bit' hence causing an illegal 'routine_id' -- 11) wasn't restoring the 'lineNumber' of the stack! and other -- various 'lineNumber' bugs fixed -- 12) wasn't using the 'current sourceline' to report RunTime Errors -- introduced CURRENT_LINE_INDEX -- 13) Added type-checking to ASSIGNMENTS! -- typeCheckFlag was never ever set! -- 14) 'elsif' and 'while'expressions were NOT being short-circuited! -- it was only being done for 'if' -- -- 29.10.99 - DG -- Will commence to add 'short-circuited OR', 'call_func_' and -- amend 'routine_id_', 'call_proc_' this program!! -- 15) Added short-circuited 'or' for IF & WHILE statements -- 16) Amended 'routine_id_' -- Discovered an interesting feature whilst testing 'routine_id' -- Because the programs PARSES a statement at a time THEN executes it -- if the last line of an INCLUDED file contains the 'routine_id' -- a) it picks up EOF BEFORE execution -- b) hence it resets pVisible[scope] making the routines which really -- are STILL IN SCOPE, INVISIBLE to 'routine_id_' -- hence it returns -1 although it is executing -- the LAST LINE of the INCLUDED File which contains the routine! -- Solution: add the 'fileIndex' to pUser and check -- BOTH name & fileindex when searching for the routine; -- hence need to restore fileIndex's value from stack also! -- -- 17) Bug discovered with the usage of 'parse()' whilst running 'lw.ex' -- This bug occurs where types & variables, etc share THE SAME NAME -- a) Because parse() searches for TYPES before VARS! -- b) But more to the point it will find a TYPE in GLOBAL space -- whilst there may exist a VARIABLE with the same name within MODULE -- space hence EU would fail with such programs as test34 & test35 -- Solution: change the search order when seeking for -- vars/constants/types/procs/funcs -- Hence, when determining the meaning of a 'word' -- i) when applicable search for 'vars' in ROUTINE space first -- ii) else search for vars/constants/types/procs/funcs -- in visible MODULE space -- iii) Otherwise, search vars/constants/types/procs/funcs -- in GLOBAL space -- However, search for vars/constants & types/procs/funcs -- collectively! -- 18) To workaround a 'Euphoria 2.1 nested For loop' bug -- change the FOR loop within 'for_' to a WHILE loop -- --/endcode --without trace without type_check without warning constant Debug = 0 -- display debugging information constant Echo = 0 -- echo lines read constant True = 1 constant False = 0 type boolean(integer x) return x = 0 or x = 1 end type include graphics.e include get.e include file.e include sprint.e constant Version = "EuScript version 0.2 alpha (Eu v0.3)" -- was 0.1 -- parser.ex include wildcard.e sequence words sequence wordPos sequence thisLine atom FOR_LOOP_INDEX object CURRENT_LINE_INDEX object LAST_FOUND,FOUND_INDEX object currentWord words = {} thisLine = {} constant EOF = "<End of File>" ----------------------------------------------------------------------------- -- for include files constant EuPlace = getenv( "EUDIR" ), Place = { "", EuPlace & "\\", EuPlace & "\\INCLUDE\\" } ----------------------------------------------------------------------------- -- variable constant V_NAME = 1, -- variable name V_VALUE = 2, -- value V_TYPE = 3, -- data type V_INIT = 4 -- has it been initialized? -- procedure/function attributes constant P_NAME = 1, -- module name P_TYPE = 2, -- module type (func/proc/type) P_ARGS = 3, -- argument count P_CODE = 4, -- executable code P_VARS = 5, -- variable names P_VTYPE = 6, -- variable data types P_FILEINDEX = 7 -- the index of the file that contains this routine -- scope of an item. these are arranged in search order constant ROUTINE = 1, -- n/a for procedures MODULE = 2, GLOBAL = 3 constant DEBUG = 0, WARNING = 1 constant -- data types OBJECT = -1, -- object data type ATOM = -2, -- atom data type INTEGER = -3, -- integer data type SEQUENCE = -4, -- sequence data type CONSTANT = -5 -- constant, can't assign value global constant -- procedures EUFUNC = 1, -- builtin function PROC = 2 -- builtin procedure constant RETURN_EUFUNC = 3, -- function returns a value RETURN_PROC = 4, -- procedure return, no value FOR = 5, -- for loop EXIT = 6, -- exit from loop IF = 7, -- if statement WHILE = 8, -- while statement USER_PROC = 9, -- user defined procedure USER_EUFUNC = 10, -- user defined function USER_TYPE = 11, -- user defined type NO_OP = 12, -- no op TRUE = 13, -- return true -- for ELSE statements -- fetching values GET_LOCAL = 20, -- fetch local from routine GET_MODULE = 21, -- fetch var from module SET_LOCAL = 22, -- set local in routine SET_MODULE = 24, -- set var in module GET_INDEX_LOCAL = 25, -- fetching from index GET_INDEX_MODULE = 26, -- fetching from index SET_INDEX_LOCAL = 27, -- set an index SET_INDEX_MODULE = 28, -- set an index GET_SLICE_LOCAL = 29, -- set a slice to a value GET_SLICE_MODULE = 30, -- set a slice to a value SET_SLICE_LOCAL = 31, -- set a slice to a value SET_SLICE_MODULE = 32, -- set a slice to a value SET_CONSTANT = 33, -- set a constant -- data operations ADD = 40, -- add (+) SUB = 41, -- subtract (-) MUL = 42, -- multiply (*) DIV = 43, -- divide (/) NEGATE = 44, -- unary minus CONCAT = 45, -- concatenate sequences (&) NOT = 46, -- logical not AND = 47, -- logical and SHORT_AND = 48, -- logical and with short-circuiting OR = 49, -- logical or XOR = 50, -- logical xor EQ = 51, -- equal NE = 52, -- not equal GT = 53, -- greater than GE = 54, -- greater or equal LT = 55, -- less than LE = 56, -- less or equal SHORT_OR = 57, -- logical or with short-circuiting -- embedded constants DATA = 60, -- data in "raw" form SEQ = 62, -- sequence of data EUEMPTY = 63 -- empty sequence constant TRACE_LINES = 10 -- how many lines to show during trace -- set to 0 when testing 'sanity.ex, LW, DOS32LIB, ...' etc. sequence builtin, -- builtin routines pVisible, -- names of all visible routines pUser, -- user defined procs vList, -- names of visible variables, and their indexes vName, -- names of module/global variables vValue, -- list of module/global variable values vType, -- data type of module/global variables vInit, -- holds list of module/global variable init flags uValue, -- current routine's values uInit, -- current routines initialization values stack, -- stack for include files included, -- list of included files source, -- source file traceStack -- stack of trace integer exprRoutineId, -- routine id of expr() parseRoutineId, -- routine id of parse() globalFlag, -- true if keyword "global" was encountered theProc, -- holds index of procedure being defined runProc, -- holds index of procedure being run returnFlag, -- if true, return statement was encountered returnInit, -- if true, returned a value from the function exitFlag, -- if true, exits loop typeCheckFlag, -- if true, type checking is enabled traceFlag, -- if true, trace enabled shortCircuitFlag, -- if true, use short circuiting sourceHandle, -- handle to file being read fileIndex, -- index to included, points to current file name lineNumber, -- current line number topTraceLine, -- prior top line shown on trace screen traceDepth -- depth of tracing allowed object euReturnValue -- value returned from function sequence script ----------------------------------------------------------------------------- function makePrintable( object o ) -- used to make error values printable sequence s if not sequence( o ) then -- return REAL numbers appropriately if not integer( o ) then return sprintf( "%g", {o} ) else return sprintf( "%d", {o} ) end if else s = "{" for i = 1 to length( o ) do if atom( o[i] ) then if o[i] >= 32 and o[i] <= 126 then -- number and printable char s &= sprintf( "%d'%s'", {o[i],o[i]} ) else -- just number s &= sprintf( "%d", {o[i]} ) end if else s &= makePrintable( o[i] ) end if if i != length( o ) then s &= "," end if end for s &= "}" end if return s end function ----------------------------------------------------------------------------- integer err_file err_file = open( "euscript.err", "w" ) procedure debug( sequence s1, sequence s2 ) -- debugging, used in development if Debug then printf( err_file, s1 & "\n", s2 ) end if end procedure ----------------------------------------------------------------------------- global integer err_routine, err_handled err_routine = 0 err_handled = 0 procedure syntaxErr( sequence s1, sequence s2 ) -- report error and abort sequence text if err_routine then err_handled = 1 text = source[length( source )] text = text[3..length(text)] call_proc( err_routine, { s1, s2, text, lineNumber } ) return end if -- error printf( err_file, "Syntax error - %s\n", {sprintf( s1, s2 )} ) if theProc then text = pUser[theProc][P_NAME] else text = "N/A" end if -- location printf( err_file, "Routine: %s Line: %d\n", { text, --included[length(included)], lineNumber} ) -- display offending line text = source[length( source )] text = text[3..length(text)] if length( text ) > 78 then text = text[1..78] end if puts( err_file, text ) -- abort ? 1/0 abort(0) end procedure ----------------------------------------------------------------------------- procedure runErr( sequence s1, sequence s2 ) -- report error and abort sequence text -- error puts( err_file, "\nError - " & sprintf( s1, s2 ) & "\n" ) -- location if err_routine then call_proc( err_routine, {s1, s2, "", CURRENT_LINE_INDEX}) err_handled = 1 return end if CURRENT_LINE_INDEX = source[CURRENT_LINE_INDEX] printf( err_file, "Module: %s Line: %d\n", {included[CURRENT_LINE_INDEX[2]], CURRENT_LINE_INDEX[1]} ) -- offending line text = CURRENT_LINE_INDEX puts( err_file, text[3..length(text)] ) -- abort abort(0) end procedure ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- parsing ----------------------------------------------------------------------------- function isdigit(integer char) return ( char >= '0' and char <= '9' ) end function function isalphanum(integer char) -- short circuit if ( char >= 'A' and char <= 'Z' ) or ( char >= 'a' and char <= 'z' ) or ( char >= '0' and char <= '9' ) or char = '_' then return True else return False end if end function function ishex(integer char) -- short circuit if isdigit(char) or ( char >= 'A' and char <= 'F' ) then return True else return False end if end function procedure accumulate_word(sequence word, atom i) -- add word, if any is accumulated if length( word ) then words = append( words, word ) wordPos = append( wordPos, i ) end if end procedure procedure parseLine( sequence text ) integer char, -- current letter nextChar, -- next letter quoted -- if true, in quotes sequence word -- accumulates characters boolean eflag -- exponent handling atom i,j,len -- clear words words = {} wordPos = {} -- add 2 spaces onto the end, to ensure it's all delimited -- second space prevents nextChar from crashing text = text & " " -- extract the words word = "" quoted = 0 -- scan line i = 0 len = length( text )-1 while True do i += 1 if i > len then exit end if -- read chars char = text[i] nextChar = text[i+1] -- ignore? if char = 0 then -- zapped. had been a special character -- close quote? elsif quoted and char = quoted then -- add end quote word = word & quoted -- check size on single quote if quoted = '\'' then -- special char? if length( word ) = 4 then if word[2] != '\\' then syntaxErr( "character constant is missing a closing '", {} ) end if -- too small? elsif length( word ) != 3 then syntaxErr( "single-quote character is empty", {} ) elsif length( word ) < 1 then syntaxErr( "character constant is missing a closing '", {} ) end if end if if err_handled then err_handled = 0 return end if -- add to words words = append( words, word ) wordPos = append( wordPos, i ) -- clear word word = "" -- clear flag quoted = 0 -- special character elsif char = '\\' then -- must be quoted if not quoted then syntaxErr( "illegal character.", {} ) end if if err_handled then err_handled = 0 return end if -- special character if nextChar = 'n' then char = '\n' elsif nextChar = 'r' then char = '\r' elsif nextChar = 't' then char = '\t' elsif nextChar = '\\' then char = '\\' elsif nextChar = '\'' then char = '\'' elsif nextChar = '\"' then char = '\"' else syntaxErr( "unknown escape character.", {} ) end if -- accumulate word = word & char -- zap the next so it won't be read text[i+1] = 0 -- inside quote elsif quoted then -- accumulate word = word & char -- start of quote elsif ( char = '"' or char = '\'') and not quoted then -- add word, if any is accumulated accumulate_word(word,i) -- start quote word = {char} -- set flag quoted = char -- comment? elsif char = '-' and nextChar = '-' then -- store accumulated word? accumulate_word(word,i) -- ignore rest if line return -- white space? elsif char = ' ' or char = '\n' or char = '\r' -- mwl added 7/22/03 or char = '\t' then -- add to word if length( word ) then words = append( words, word ) wordPos = append( wordPos, i ) word = "" end if -- non-delimiter? -- numbers: elsif ( char >= '0' and char <= '9' ) then accumulate_word(word,i) word = {char} j = i eflag = False for k=i+1 to len do char = text[k] nextChar = text[k+1] if isdigit(char) then word &= char eflag = False elsif char = '.' then -- decimals if nextChar='.' then exit -- e.g. 1..2 elsif not isdigit(nextChar) then syntaxErr("fractional part of the number is " & "missing", {}) else word &= char -- add '.' AND CONTINUE end if elsif find(char,{'e','E'}) then -- exponents if isdigit(nextChar) or find(nextChar,{'-','+'}) then -- e-99, e+99 etc word &= 'e' -- add 'e' AND CONTINUE eflag = True else syntaxErr("number not formed correctly", {}) end if elsif find(char,{'-','+'}) then -- exponents if eflag then -- part of an exponent eflag = False word &= char -- add '-/+' AND CONTINUE else exit -- finish at this point e.g. 123+123 end if else exit -- non-number -- finish end if if err_handled then err_handled = 0 return end if -- keep note of position j = k end for -- accumulate the number and CONTINUE loop with i=j accumulate_word(word,j) word="" i = j -- non-delimiter? -- IDENTIFIERS which can't begin with '_' elsif ( char >= 'A' and char <= 'Z' ) or ( char >= 'a' and char <= 'z' ) then accumulate_word(word,i) word = {char} j = i for k = i+1 to len do char = text[k] if isalphanum(char) then word &= char else exit -- non-alphanumeric -- finish end if -- keep note of position j = k end for -- accumulate the IDENTIFIER and CONTINUE loop with i=j accumulate_word(word,j) word = "" i = j -- non-delimiter? -- hexadecimals! elsif char = '#' then accumulate_word(word,i) -- returned as TWO parts {'#',num} words = append( words, {'#'}) wordPos = append( wordPos, i ) word = "" j = i for k=i+1 to len do char = text[k] if ishex(char) then -- soley CAPITAL A-F & digits! word &= char else exit -- non-hex-LETTER/digit -- finish end if -- keep note of position j = k end for if length(word)=0 then syntaxErr("hex number not formed correctly", {}) end if if err_handled then err_handled = 0 return end if -- accumulate the HEX and CONTINUE loop with i=j accumulate_word(word,j) word = "" i = j elsif char='_' then syntaxErr( "illegal character >> %s <<.", {char} ) if err_handled then err_handled = 0 return end if -- delimiter else -- accumulated word? accumulate_word(word,i) -- special delimiter? if char = '!' and nextChar = '=' then word = "!=" elsif char = '<' and nextChar = '=' then word = "<=" elsif char = '>' and nextChar = '=' then word = ">=" elsif char = '+' and nextChar = '=' then word = "+=" elsif char = '-' and nextChar = '=' then word = "-=" elsif char = '*' and nextChar = '=' then word = "*=" elsif char = '/' and nextChar = '=' then word = "/=" elsif char = '&' and nextChar = '=' then word = "&=" elsif char = '.' and nextChar = '.' then word = ".." else word = {char} end if -- remove next char? if length( word ) = 2 then -- zap it so it won't be read text[i+1] = 0 end if -- add word words = append( words, word ) wordPos = append( wordPos, i ) -- clear it word = "" end if end while -- end for if quoted then syntaxErr( "End of line reached with no closing " & quoted, {} ) end if if err_handled then err_handled = 0 return end if end procedure ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- handle include files ----------------------------------------------------------------------------- function getIncludeName( sequence data ) -- if the statement is an include statement, return the file name integer at -- include statement missing? if not match( "include ", data ) then return "" end if -- trim white space while find( data[1], " \t" ) do data = data[2..length( data ) ] end while -- line feed? if find( '\n', data ) then data = data[1..length(data)-1] end if -- not first statement? if not equal( data[1..8], "include " ) then -- not an include statement return "" else -- remove statement data = data[9..length(data)] end if -- remove data after space at = find( ' ', data ) if at then data = data[1..at-1] end if return data end function ----------------------------------------------------------------------------- procedure includeFile( sequence fName ) -- returns where a file is -- looks in the usual places sequence fullName -- no full name found yet fullName = {} -- look in the usual places for i = 1 to length( Place ) do if sequence( dir( Place[i] & fName ) ) then fullName = Place[i] & fName exit end if end for -- not found? if length( fullName ) = 0 then -- not exactly Euphoria's error message syntaxErr( "Can't locate file %s", {fName} ) end if if err_handled then err_handled = 0 return end if -- already included? if find( fullName, included ) then -- do nothing return else -- add to list included = append( included, fullName ) end if -- store the current module information stack = prepend( stack, { vList[ MODULE ], -- module variables pVisible[ MODULE ], -- module routines sourceHandle, -- file handle lineNumber, -- current line number fileIndex } ) -- index to name -- make the current module invisible vList[ MODULE ] = {} pVisible[ MODULE ] = {} -- open the file sourceHandle = open( fullName, "r" ) if sourceHandle = -1 then syntaxErr( "error opening file %s", {fName} ) end if if err_handled then err_handled = 0 return end if -- clear the line number lineNumber = 0 -- current file fileIndex = length( included ) end procedure ----------------------------------------------------------------------------- procedure readSourceLine() -- read a line of source code -- convert to words integer last -- position of last character in line sequence includeName -- include file name object data -- line from file thisLine = "" -- read -- 9/2/03: fix for include files mwl if sourceHandle > 0 then data = gets( sourceHandle ) trace(1) else if length( script ) then data = script[1] else data = 0 end if if length(script) > 1 then script = script[2..length(script)] else script = {} end if end if -- end of file? if integer( data ) then -- close the file REGARDLESS of whether anything on stack if sourceHandle > 0 then close( sourceHandle ) end if -- is there an file to return to? if length( stack ) then -- pop the stack data = stack[1] stack = stack[2..length(stack)] -- restore data from stack vList[ MODULE ] = data[1] pVisible[ MODULE ] = data[2] sourceHandle = data[3] lineNumber = data[4] -- restore the line no. in order to display the correct location fileIndex = data[5] -- treat as blank line words = {} return else words = { EOF } return end if end if -- ONLY increment the line number IF NOT EOF lineNumber += 1 -- echo text on screen --if Echo then -- puts( 1, ">" & data ) --end if -- remove line feed -- check for \r on unix systems... last = length( data ) if data[last] = '\n' then data = data[1..last-1] -- 9/2/03 added test for length of data. mwl if last > 1 and data[last-1] = '\r' then data = data[1..last-2] end if end if -- add to source listing source = append( source, { lineNumber, fileIndex } & data ) -- is this an include file? includeName = getIncludeName( data ) if length( includeName ) then -- switch to include file includeFile( includeName ) -- treat as a blank line words = {} return end if -- save line for errors thisLine = data -- parse into words parseLine( data ) end procedure ----------------------------------------------------------------------------- function thisWord() -- returns current word being parsed -- if list is empty, reads a new line -- read until non-blank, or eof while not length( words ) do readSourceLine() end while return words[1] end function ----------------------------------------------------------------------------- function isWord( sequence s ) -- true if s matches current word being parsed return equal( thisWord(), s ) end function ----------------------------------------------------------------------------- function isCurWord( sequence s ) -- true if s matches current word being parsed return equal( currentWord, s ) end function ----------------------------------------------------------------------------- function isNumber() -- true if thisWord is a number sequence s s = thisWord() return (s[1] >= '0' and s[1] <= '9') end function ----------------------------------------------------------------------------- function isString() -- true if thisWord is a string sequence s s = thisWord() return (s[1] = '"') end function ----------------------------------------------------------------------------- function isChar() -- true if thisWord is a char sequence s s = thisWord() return (s[1] = '\'') end function ----------------------------------------------------------------------------- procedure checkEOF() -- if eof, issue error if isWord( EOF ) then syntaxErr( "expected to see possibly 'end', not end of file", {} ) end if if err_handled then err_handled = 0 return end if end procedure ----------------------------------------------------------------------------- procedure moveAhead() -- removes word from head of list if length( words ) then -- chop word off beginning of list words = words[2..length(words)] wordPos = wordPos[2..length(wordPos)] end if end procedure ----------------------------------------------------------------------------- procedure require( sequence s ) -- generates error if s does not match -- otherwise, accepts and moves to next word if not isWord( s ) then syntaxErr( "Expected to see possibly '%s', not '%s'.", {s, thisWord()} ) if err_handled then err_handled = 0 return end if else moveAhead() end if end procedure ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- internal structure tracking ----------------------------------------------------------------------------- function findIndex( object index, sequence s ) -- find the index for something for i = 1 to length( s ) do if equal( index, s[i][1] ) then -- save the value FOUND_INDEX = i return i end if end for return False end function ----------------------------------------------------------------------------- -- changed to global. mwl 12/12/00 --/topic Reference --/func findRoutine( sequence name ) -- --Returns 1 if the routine /b name exists within the current --scope of the script, 0 otherwise. This can be used to check --for the existence of a routine within the script. global function findRoutine( sequence name ) -- return true if exists integer at -- look for it in all the scopes for scope = MODULE to GLOBAL do at = findIndex( name, pVisible[scope] ) if at then -- save the value FOUND_INDEX = pVisible[scope][at][2] -- return index return pVisible[scope][at][2] end if end for return False end function ----------------------------------------------------------------------------- function isType( sequence name ) -- returns true if is a routine integer index -- check against builtin types if find( name, {"object", "atom", "integer", "sequence" } ) then return True end if -- is it a routine? index = findRoutine( name ) if index then -- is it a user defined type? if pUser[index][P_TYPE] = USER_TYPE then return True end if end if return False end function ----------------------------------------------------------------------------- function findVar( sequence name ) -- find where the variable is -- returns { scope, index } integer at, index for scope = ROUTINE to GLOBAL do at = findIndex( name, vList[scope] ) if at then -- get index index = vList[scope][at][2] -- return value return { scope, index } end if end for syntaxErr( "%s has not been declared (expected variable)", {name} ) if err_handled then err_handled = 0 return {} end if end function ----------------------------------------------------------------------------- function isVar( sequence name ) -- return true if exists integer at integer index for scope = ROUTINE to GLOBAL do at = findIndex( name, vList[scope] ) if at then -- get index index = vList[scope][at][2] -- save the value LAST_FOUND = { scope, index } return True end if end for return False end function ----------------------------------------------------------------------------- procedure createVar( integer scope, integer typeOf, sequence name ) -- create a variable. negative typeOf indicates a builtin type, -- otherwise it's the index of a user type integer index -- not a stack variable? if scope = ROUTINE then -- add to proc pUser[theProc][P_VARS] = append( pUser[theProc][P_VARS], name ) pUser[theProc][P_VTYPE] = append( pUser[theProc][P_VTYPE], typeOf ) -- index index = length( pUser[theProc][P_VARS] ) else -- create an uninitialized variable vValue = append( vValue, 0 ) vName = append( vName, name ) vType = append( vType, typeOf ) vInit = append( vInit, 0 ) -- get index index = length( vValue ) end if -- add to visible list vList[scope] = append( vList[scope], {name, index} ) -- LOOP INDEX BUG FIX FOR_LOOP_INDEX = length(vList[scope]) end procedure ----------------------------------------------------------------------------- procedure removeVar( sequence name ) -- remove a loop variable integer scope, index sequence info -- find the variable info = findVar( name ) scope = info[1] index = info[2] -- make it invisible vList[scope][FOR_LOOP_INDEX][1] = "" end procedure ----------------------------------------------------------------------------- function expr() -- forward reference -- parses expressions return call_func( exprRoutineId, {} ) end function ----------------------------------------------------------------------------- function parseArgs( sequence name, integer argCount ) -- parse arg list integer args sequence code require( "(" ) -- read the args args = 0 code = {} if not isWord( ")" ) then while TRUE do -- add an argument -- this makes a forward reference call to expr() code = append( code, expr() ) -- increment argument count args += 1 -- exit? if not isWord(",") then exit else require(",") end if end while end if require( ")" ) -- check arg count if args != argCount then syntaxErr( "%s takes %d arguments", {name, argCount} ) end if if err_handled then err_handled = 0 return {} end if return code end function ----------------------------------------------------------------------------- function subExpr() sequence code object a, b, c -- evaluate a single expression, return code if isWord( "(" ) then -- ( <expr> ) moveAhead() code = expr() require( ")" ) elsif isWord( "-" ) then -- - <expr> moveAhead() code = { NEGATE, subExpr() } elsif isWord( "+" ) then -- + <expr> moveAhead() code = subExpr() elsif isWord( "not" ) then -- not <expr> moveAhead() code = { NOT, subExpr() } elsif isWord( "{" ) then -- { <sequence> } moveAhead() code = {} -- need to read expression? if not isWord( "}" ) then -- loop until no more commas while True do -- check eof checkEOF() -- parse next expression code = append( code, expr() ) -- comma? if isWord( "," ) then moveAhead() else exit end if end while end if require( "}" ) -- empty sequence? if length( code ) = 0 then -- empty sequence code = { EUEMPTY } else -- sequence data code = { SEQ } & code end if elsif isNumber() or isWord(".") then -- decimal only if isWord(".") then moveAhead() -- get number after digit if not isNumber() then syntaxErr( "number not formed correctly", {} ) if err_handled then err_handled = 0 return {} end if end if a = "." & thisWord() moveAhead() else -- get the integer portion a = thisWord() moveAhead() -- decimal? if isWord( "." ) then -- move past digit moveAhead() -- anything past decimal point? if isNumber() then a = a & "." & thisWord() moveAhead() end if end if end if -- evaluate number a = value( a ) -- place value in code code = { DATA, a[2] } elsif isWord( "#" ) then -- parse hex word moveAhead() -- evaluate number a = value( "#" & thisWord() ) moveAhead() -- embed data code = { DATA, a[2] } elsif isChar() then -- get literal a = thisWord() -- embed data code = { DATA, a[2] } moveAhead() elsif isString() then -- remove quotes from string a = thisWord() a = a[2..length(a)-1] -- create code code = { DATA, a } moveAhead() elsif isVar( thisWord() ) then a = findVar( thisWord() ) moveAhead() -- allow slicing if isWord( "[" ) then -- indexed fetch if a[1] = ROUTINE then b = GET_INDEX_LOCAL else b = GET_INDEX_MODULE end if -- assignment to slices c = { SEQ } while True do -- opening paren require( "[" ) -- read an index c = append( c, expr() ) if isWord( ".." ) then -- set slice if a[1] = ROUTINE then b = GET_SLICE_LOCAL else b = GET_SLICE_MODULE end if moveAhead() -- read the end slice c = append( c, expr() ) -- better be end require("]") exit end if -- closing paren require("]") -- exit if no more indexes if not isWord( "[" ) then exit end if end while -- either GET_INDEX_xxx or GET_SLICE_xxx code = { b, a[2], c } else -- normal fetch if a[1] = ROUTINE then -- simple fetch code = { GET_LOCAL, a[2] } else code = { GET_MODULE, a[2] } end if end if elsif findRoutine( thisWord() ) then -- user defined function -- get the index a = findRoutine( thisWord() ) moveAhead() -- procedure? if pUser[a][P_TYPE] = PROC then -- error syntaxErr( "expected to see an expression, not a procedure", {} ) if err_handled then err_handled = 0 return {} end if end if -- append EUFUNC, index and arg list code = { USER_EUFUNC, a } & parseArgs( pUser[a][P_NAME], pUser[a][P_ARGS] ) elsif findIndex( thisWord(), builtin ) then -- builtin function -- this follows user-defined functions, so users can redefine code -- it's a builtin procedure a = FOUND_INDEX moveAhead() -- procedure? if builtin[a][P_TYPE] = PROC then -- error syntaxErr( "expected to see an expression, not a procedure", {} ) if err_handled then err_handled = 0 return {} end if end if -- append EUFUNC, index and arg list code = { EUFUNC, a } & parseArgs( builtin[a][P_NAME], builtin[a][P_ARGS] ) else -- no idea what it is syntaxErr( "%s has not been declared (expected expression)", {thisWord()} ) if err_handled then err_handled = 0 return {} end if end if return code end function ----------------------------------------------------------------------------- function binaryExpr_mul_div() -- * / have HIGHER precedence than + - & -- parse a operator expression sequence code,code2 integer operator code = subExpr() -- parse a*b*c as (a*b)*c & a/b/c as (a/b)/c & a/b*c as (a/b)*c etc while True do -- read expression if isWord( "*" ) then operator = MUL elsif isWord( "/" ) then operator = DIV else exit end if moveAhead() code2 = subExpr() code = { operator, code, code2 } end while return code end function ----------------------------------------------------------------------------- function binaryExpr_add_sub() -- parse a operator expression -- + - have HIGHER precedence than & sequence code,code2 integer operator code = binaryExpr_mul_div() -- parse a+b+c as (a+b)+c & a-b+c as (a-b)+c while True do -- read expression if isWord( "+" ) then operator = ADD elsif isWord( "-" ) then operator = SUB else exit end if moveAhead() code2 = binaryExpr_mul_div() code = { operator, code, code2 } end while return code end function ----------------------------------------------------------------------------- function binaryExpr() -- parse a operator expression -- & then has HIGHER precedence than the comparison operators, etc. sequence code code = binaryExpr_add_sub() -- read expression if isWord( "&" ) then moveAhead() code = { CONCAT, code, binaryExpr() } end if return code end function ----------------------------------------------------------------------------- function compExpr() -- parse a comparison operator expression sequence code,code2 integer operator code = binaryExpr() while True do -- read expression if isWord( "=" ) then operator = EQ elsif isWord( "!=" ) then operator = NE elsif isWord( ">" ) then operator = GT elsif isWord( ">=" ) then operator = GE elsif isWord( "<" ) then operator = LT elsif isWord( "<=" ) then operator = LE else exit end if moveAhead() code2 = binaryExpr() code = { operator, code, code2 } end while return code end function ----------------------------------------------------------------------------- function boolExpr() -- parse a logical expression sequence code code = compExpr() -- read expression if isWord("and") then moveAhead() if shortCircuitFlag then -- short-circuiting and code = { SHORT_AND, code, boolExpr() } else -- normal and code = { AND, code, boolExpr() } end if -- 'or' must be short-circuited in IF & WHILE elsif isWord("or") then moveAhead() if shortCircuitFlag then -- short-circuiting and code = { SHORT_OR, code, boolExpr() } else -- normal or code = { OR, code, boolExpr() } end if elsif isWord("xor") then moveAhead() code = { XOR, code, boolExpr() } end if return code end function ----------------------------------------------------------------------------- -- resolve forward reference exprRoutineId = routine_id( "boolExpr" ) ----------------------------------------------------------------------------- procedure procArgList() -- parse an arg list for a new procedure object typeOf sequence name require( "(" ) if not isWord( ")" ) then while True do -- get the type if isWord( "object" ) then typeOf = OBJECT elsif isWord( "atom" ) then typeOf = ATOM elsif isWord( "integer" ) then typeOf = INTEGER elsif isWord( "sequence" ) then typeOf = SEQUENCE else -- user defined type typeOf = findRoutine( thisWord() ) end if moveAhead() -- get the name name = thisWord() moveAhead() -- add to the variable list createVar( ROUTINE, typeOf, name ) -- update the proc pUser[theProc][P_ARGS] += 1 -- comma? if not isWord( "," ) then exit end if -- read past comma moveAhead() end while end if require( ")" ) end procedure ----------------------------------------------------------------------------- function parseBlock() -- read block of code until "end" is encountered sequence code object parsed -- accumulated code code = {} -- read until block end marker: end, elsif or else while not isWord( "end" ) and not isWord( "elsif" ) and not isWord( "else" ) do -- check for end of file checkEOF() -- parse the code; forward reference to parse() parsed = call_func( parseRoutineId, {} ) if atom(parsed) then return {{NO_OP}} end if -- code generated? if length( parsed ) then code = append( code, parsed ) end if end while -- have to put something in block if length( code ) = 0 then code = { { NO_OP } } end if return code end function ----------------------------------------------------------------------------- -- used to find a variable with a given scope(s) function findVar_Scope( sequence name , integer scope1, integer scope2) -- find where the variable is -- returns { scope, index } integer at, index for scope = scope1 to scope2 do at = findIndex( name, vList[scope] ) if at then -- get index index = vList[scope][at][2] -- save the value LAST_FOUND = { scope, index } return True end if end for return False end function ----------------------------------------------------------------------------- -- New ... made the parsing of types into a separate routine function parse_found_type(boolean builtin_type) object a, b sequence code -- elsif isType( thisWord() ) then -- scope if theProc then a = ROUTINE elsif globalFlag then a = GLOBAL else a = MODULE end if -- data type if builtin_type then if isCurWord( "object" ) then b = OBJECT elsif isCurWord( "atom" ) then b = ATOM elsif isCurWord( "integer" ) then b = INTEGER elsif isCurWord( "sequence" ) then b = SEQUENCE end if else -- get index of user type b = FOUND_INDEX end if moveAhead() createVar( a, b, thisWord() ) moveAhead() -- read comma delimited list while isWord( "," ) do -- move past comma moveAhead() -- create a variable createVar( a, b, thisWord() ) moveAhead() end while -- no code generated code = {} -- clear flag globalFlag = 0 return code end function ----------------------------------------------------------------------------- function parse_found_variable(integer sourceLine) object a, b, c, d sequence code -- assignment to variable a = LAST_FOUND -- a = findVar( thisWord() ) - DG17 moveAhead() -- allow slicing if isWord( "[" ) then -- indexed assignment if a[1] = ROUTINE then b = SET_INDEX_LOCAL else b = SET_INDEX_MODULE end if -- assignment to slices c = { SEQ } while True do -- opening paren require( "[" ) -- read an index c = append( c, expr() ) if isWord( ".." ) then -- set slice if a[1] = ROUTINE then b = SET_SLICE_LOCAL else b = SET_SLICE_MODULE end if moveAhead() -- read the end slice c = append( c, expr() ) -- better be end require("]") exit end if -- closing paren require("]") -- exit if no more indexes if not isWord( "[" ) then exit end if end while else -- normal assignment if a[1] = ROUTINE then b = SET_LOCAL else b = SET_MODULE end if end if -- evaluate the operator if isWord("=" ) then d = EQ elsif isWord("+=" ) then d = ADD elsif isWord("-=" ) then d = SUB elsif isWord("*=" ) then d = MUL elsif isWord("/=" ) then d = DIV elsif isWord("&=" ) then d = CONCAT else syntaxErr( "expected to see =, +=, -=, *=, /= or &=", {} ) if err_handled then err_handled = 0 return {} end if end if moveAhead() if b = SET_LOCAL or b = SET_MODULE then -- simple assignment code = { b, sourceLine, d, a[2], expr() } else -- either SET_INDEX_xxx or SET_SLICE_xxx code = { b, sourceLine, d, a[2], c, expr() } end if return code end function ----------------------------------------------------------------------------- function parse_found_routine(integer sourceLine) object a sequence code -- user defined routine -- get routine index a = FOUND_INDEX -- a = findRoutine( thisWord() ) - DG17 moveAhead() -- function? if pUser[a][P_TYPE] = EUFUNC then -- error syntaxErr( "function result must be assigned or used", {} ) if err_handled then err_handled = 0 return {} end if end if -- append PROC, index and arg list code = { USER_PROC, sourceLine, a } & parseArgs( pUser[a][P_NAME], pUser[a][P_ARGS] ) return code end function ----------------------------------------------------------------------------- function parse() integer sourceLine object a, b, c, d, e sequence code integer save_for_index code = {} -- what source line are we on? sourceLine = length( source ) currentWord = thisWord() if isCurWord( "global" ) then -- turn on global flag globalFlag = 1 moveAhead() currentWord = thisWord() -- take note of the NEXT word -- make sure followed by legal word if not isCurWord( "constant" ) and not isCurWord( "procedure" ) and not isCurWord( "type" ) and not isCurWord( "function" ) and not isType( currentWord ) then syntaxErr( "a global must be followed by a constant, " & "procedure, type or function", {} ) if err_handled then err_handled = 0 moveAhead() return 0 end if end if -- no code code = {} elsif isCurWord( "procedure" ) or isCurWord( "function" ) or isCurWord( "type" ) then -- compile a procedure or a function -- is it a procedure or a function? if isCurWord("procedure") then a = PROC elsif isCurWord("function") then a = EUFUNC else a = USER_TYPE end if -- move past keyword moveAhead() -- create an empty procedure -- pUser = append( pUser, repeat( 0, 6 ) ) -- introduce slot 7 for the 'routine's fileindex' pUser = append( pUser, repeat( 0, 7 ) ) theProc = length( pUser ) -- initial values pUser[theProc][P_NAME] = thisWord() pUser[theProc][P_TYPE] = a pUser[theProc][P_ARGS] = 0 pUser[theProc][P_VARS] = {} pUser[theProc][P_VTYPE] = {} pUser[theProc][P_CODE] = {} -- attach the fileIndex for usage by 'routine_id_' pUser[theProc][P_FILEINDEX] = fileIndex -- what's the scope? if globalFlag then b = GLOBAL else b = MODULE end if -- add the proc name and index to list pVisible[b] = append( pVisible[b], { thisWord(), theProc } ) moveAhead() -- process the arg list procArgList() -- type only has 1 arg if a = USER_TYPE and pUser[theProc][P_ARGS] != 1 then syntaxErr( "types must have exactly one parameter", {} ) end if if err_handled then err_handled = 0 moveAhead() return 0 end if -- read the code code = parseBlock() -- end procedure/function require( "end" ) if a = PROC then require( "procedure" ) elsif a = EUFUNC then require( "function" ) else require( "type" ) end if -- store code pUser[theProc][P_CODE] = code -- clear flags theProc = 0 code = {} -- clear flag globalFlag = 0 -- destroy all local variables vList[ROUTINE] = {} -- check against builtin types elsif find( currentWord, {"object", "atom", "integer", "sequence" } ) then code = parse_found_type(True) -- parse the type elsif isCurWord( "constant" ) then -- build code to initialize constants -- { SET_CONSTANT, line, <index1>, <expr1>, <index2>, <expr2> ... } moveAhead() -- what's the scope? if globalFlag then -- global constants a = GLOBAL else -- module level constants a = MODULE end if -- set code code = { SET_CONSTANT, sourceLine } while True do -- read the constant name b = thisWord() moveAhead() -- create it - pass scope, type and name createVar( a, CONSTANT, b ) require( "=" ) -- add to code code = code & { findVar( b ), expr() } -- comma follows? if not isWord( "," ) then -- all done exit else -- move past moveAhead() end if end while -- clear flag globalFlag = 0 elsif isCurWord( "exit" ) then -- exit -- { EXIT, line } moveAhead() code = { EXIT, sourceLine } elsif isCurWord( "return" ) then -- return -- { RETURN_EUFUNC, line, expr } -- { RETURN_PROC, line } moveAhead() -- in a procedure or function? if theProc = 0 then syntaxErr( "return must be inside a procedure or function", {} ) if err_handled then err_handled = 0 moveAhead() return 0 end if end if -- function or procedure if pUser[theProc][P_TYPE] = PROC then code = { RETURN_PROC, sourceLine } else -- function returns a value code = { RETURN_EUFUNC, sourceLine, expr() } end if elsif isCurWord( "with" ) or isCurWord( "without" ) then -- on or off? a = isCurWord( "with" ) moveAhead() currentWord = thisWord() -- take note of the next word -- this is simply ignored if isCurWord( "profile" ) or isCurWord( "profile_time" ) or isCurWord( "warning" ) or isCurWord( "trace" ) or isCurWord( "type_check" ) or isNumber() then -- ignore code = {} else -- error syntaxErr( "unknown with/without option", {} ) if err_handled then err_handled = 0 moveAhead() return 0 end if end if -- move past option moveAhead() elsif isCurWord( "?" ) then -- print statement -- this is an exception to the rule moveAhead() -- find the index of the print statement a = findIndex( "?", builtin ) code = {} -- compile a call to "?" code = { PROC, sourceLine, a, expr() } elsif isCurWord( "if" ) then -- if statement -- { IF, test1, line1, block1, test2, line2, block2 ... } moveAhead() -- activate short-circuit flag shortCircuitFlag = 1 -- when testing 'lw.ex 1.5' set to 0 -- read the expression a = expr() require( "then" ) -- deactivate short-circuit flag shortCircuitFlag = 0 -- start of if clause code = { IF } while True do -- code to execute b = parseBlock() -- append test and code to execute code = code & { a, sourceLine, b } -- elsif if isWord("elsif") then -- next clause sourceLine = length( source ) moveAhead() -- activate short-circuit flag shortCircuitFlag = 1 -- when testing 'lw.ex 1.5' set to 0 -- read the expression a = expr() require("then") -- deactivate short-circuit flag shortCircuitFlag = 0 -- else elsif isWord("else") then -- last clause sourceLine = length( source ) moveAhead() -- true forces execution code = code & { {TRUE}, sourceLine, parseBlock() } -- exit exit -- end if elsif isWord("end") then exit else -- non-euphoria error syntaxErr( "expected elsif, else, or end if", {} ) if err_handled then err_handled = 0 moveAhead() return 0 end if end if end while require("end") require("if") elsif isCurWord( "while" ) then -- while loop -- { WHILE, sourceLine, test, instr1, instr2 ... } moveAhead() -- activate short-circuit flag shortCircuitFlag = 1 -- read the expression a = expr() require("do") -- deactivate short-circuit flag shortCircuitFlag = 0 -- read the block b = parseBlock() require( "end" ) require( "while" ) -- build code code = { WHILE, sourceLine, a, b } elsif isCurWord( "for" ) then -- for loop -- { FOR, line, var, start, end, step, block } moveAhead() -- read the variable a = thisWord() -- is this in a routine? if theProc then -- create with routine createVar( ROUTINE, ATOM, a ) else -- create with module createVar( MODULE, ATOM, a ) end if moveAhead() require( "=" ) -- read the start value b = expr() -- read the end value require( "to" ) c = expr() -- step? if isWord( "by" ) then -- read step moveAhead() d = expr() else -- default step value d = { DATA, 1 } end if -- save the value of 'FOR_LOOP_INDEX' since the block that is -- about to be parsed may contain FOR LOOPs i.e. nested FOR loops save_for_index = FOR_LOOP_INDEX -- accumulated code require( "do" ) e = parseBlock() require( "end" ) require( "for" ) -- build code code = { FOR, sourceLine, findVar(a), b, c, d, e } -- restore FOR_LOOP_INDEX for this current FOR LOOP -- which will ensure that the corres. FOR LOOP variable -- is correctly removed FOR_LOOP_INDEX = save_for_index removeVar( a ) -- NOW determine whether var, constant, type, or routine -- this is checked BEFORE the user defined routines, so -- the user can re-define routines -- 1) Firstly, check if it is a ROUTINE or MODULE VARIABLE -- i.e. defined within a Current ROUTINE or defined within the -- Current MODULE/FILE elsif findVar_Scope(currentWord, ROUTINE, MODULE) then code = parse_found_variable(sourceLine) -- YES - parse it -- 2) check if it is a proc/func/type within the Current ROUTINE or -- defined GLOBALLY elsif findRoutine(currentWord) then -- is it a user-type or func/proc? if pUser[FOUND_INDEX][P_TYPE] = USER_TYPE then code = parse_found_type(False) -- parse the User Type else -- it is a user defined routine - parse it code = parse_found_routine(sourceLine) end if -- 3) check if it is a GLOBALLY defined variable elsif findVar_Scope(currentWord, GLOBAL, GLOBAL) then code = parse_found_variable(sourceLine) -- YES - parse it -- otherwise check for builtin! elsif findIndex( currentWord, builtin ) then -- builtin routine -- this is checked after the user defined routines, so -- the user can re-define routines -- it's a builtin a = FOUND_INDEX -- a = findIndex( thisWord(), builtin ) - DG17 moveAhead() -- function? if builtin[a][P_TYPE] = EUFUNC then -- error syntaxErr( "function result must be assigned or used", {} ) if err_handled then err_handled = 0 moveAhead() return 0 end if end if -- append PROC, index and arg list code = { PROC, sourceLine, a } & parseArgs( builtin[a][P_NAME], builtin[a][P_ARGS] ) else syntaxErr( "%s has not been declared (expected statement)", {thisWord()} ) if err_handled then err_handled = 0 moveAhead() return 0 end if end if return code end function ----------------------------------------------------------------------------- -- resolve forward reference to parse() parseRoutineId = routine_id("parse") ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- The Run Time Portion -- -- sequence opCode, opName opCode = repeat( -1, 100 ) opName = repeat( "", 100 ) integer trace_file trace_file = open( "trace.err", "w" ) ----------------------------------------------------------------------------- procedure traceLine( sequence s ) -- trace a line of code integer index, key sequence at, line CURRENT_LINE_INDEX = s[2] -- current sourceline's index if not traceFlag then return end if -- greater than trace depth? if length( traceStack ) > traceDepth then -- don't display return end if -- save position at = get_position() -- trace stack position( 1, 1 ) puts( 1, repeat( ' ', 80 ) ) position( 1, 1 ) for i = 1 to length( traceStack ) do puts( 1, pUser[traceStack[i]][P_NAME] & " " ) end for -- will it show without moving the line? if s[2] < topTraceLine or s[2] > topTraceLine + TRACE_LINES-2 then topTraceLine = s[2] end if -- display for i = 1 to TRACE_LINES-1 do -- line to display index = topTraceLine + i - 1 -- position cursor position( i+1, 1 ) -- is this a real line? if index > 0 and index <= length( source ) then line = source[index] & repeat( ' ', 80 ) line = line[1..70] if index = s[2] then -- draw with arrow printf( 1, "%3d==> %s", {line[1], line[3..length(line)]} ) else -- normal line printf( 1, "%3d: %s", {line[1], line[3..length(line)]} ) end if else -- blank line puts( 1, repeat( ' ', 80 ) ) end if end for -- wait for a key key = wait_key() -- key = 13 -- escape? if key = 27 or key = '!' then -- abort runErr( "user pressed exit key", {} ) elsif key = 13 then -- allow nesting traceDepth = 9999 elsif key = 'q' then -- cancel trace traceFlag = 0 else -- set trace depth to current depth traceDepth = length( traceStack ) end if -- return to prior position position( at[1], at[2] ) end procedure ----------------------------------------------------------------------------- function opFunc( sequence code ) -- evaluate an expression if not length(code) then return code end if debug( "func opcode %d [%s]", {code[1],opName[code[1]]} ) return call_func( opCode[code[1]], {code} ) end function ----------------------------------------------------------------------------- procedure opProc( sequence code ) -- evaluate an expression debug( "proc opcode %d [%s]", {code[1],opName[code[1]]} ) call_proc( opCode[code[1]], {code} ) end procedure procedure proc_( sequence s ) -- run a built-in procedure -- { PROC, line, proc, arg1, arg2 ... } integer proc sequence args -- trace traceLine( s ) proc = s[3] args = s[4..length(s)] debug( "proc calling %s", {builtin[proc][P_NAME]} ) -- evaluate the arguments for i = 1 to length( args ) do args[i] = opFunc( args[i] ) end for -- run the proc call_proc( builtin[proc][P_CODE], args ) end procedure ----------------------------------------------------------------------------- function func_( sequence s ) -- run a built-in function -- { EUFUNC, function, arg1, arg2 ... } integer proc sequence args proc = s[2] args = s[3..length(s)] debug( "func calling %s", {builtin[proc][P_NAME]} ) -- evaluate the arguments for i = 1 to length( args ) do args[i] = opFunc( args[i] ) end for return call_func( builtin[proc][P_CODE], args ) end function ----------------------------------------------------------------------------- procedure checkType( integer procIndex, integer varIndex, object val ) -- type check a value -- procIndex of 0 = module level integer failed, typeOf sequence name if not typeCheckFlag then return end if -- get type from variable if procIndex = 0 then -- get from local typeOf = vType[ varIndex ] else -- get from procedure typeOf = pUser[procIndex][P_VTYPE][varIndex] end if -- check type if typeOf = OBJECT then failed = 0 elsif typeOf = ATOM then failed = not atom( val ) elsif typeOf = INTEGER then failed = not integer( val ) elsif typeOf = SEQUENCE then failed = not sequence( val ) elsif typeOf = CONSTANT then -- non-euphoria error message runErr( "attempt to assign value to a constant", {} ) else -- synthesize a call to the user function failed = not opFunc( { USER_EUFUNC, typeOf, { DATA, val } } ) end if if failed then -- get type from variable if procIndex then -- get name from procedure locals name = pUser[procIndex][P_VARS][varIndex] else -- get name from module name = vName[varIndex] end if runErr( "type_check error, %s is %s", {name, makePrintable(val)} ) end if end procedure ----------------------------------------------------------------------------- procedure user_proc_( sequence s ) -- run a user defined procedure -- { USER_PROC, line, proc, arg1, arg2 ... } -- { USER_EUFUNC, func, arg1, arg2 ... } integer priorProc, vars, theProc sequence args, priorVals, priorInits, code -- don't trace USER_EUFUNC, it doesn't have a trace line if s[1] = USER_PROC then -- trace traceLine( s ) -- get proc index theProc = s[3] -- get args args = s[4..length(s)] debug( "user proc %s", {pUser[theProc][P_NAME]} ) else -- get proc index theProc = s[2] -- get args args = s[3..length(s)] debug( "user func %s", {pUser[theProc][P_NAME]} ) end if -- add to trace stack traceStack = append( traceStack, theProc ) -- evaluate the arguments -- this is first, because the arguments could reference -- variables from the modules. for i = 1 to length( args ) do -- assign local value args[i] = opFunc( args[i] ) -- type check -- added type checking for 'argument' assignment checkType( theProc, i, args[i] ) end for -- store prior data priorProc = runProc priorVals = uValue priorInits = uInit -- new proc runProc = theProc -- create space vars = length( pUser[runProc][P_VARS] ) uValue = repeat( 0, vars+1 ) uInit = repeat( 0, vars ) -- move the args uValue[1..length(args)] = args uInit[1..length(args)] = 1 returnFlag = 0 -- run the code code = pUser[runProc][P_CODE] for i = 1 to length( code ) do -- run the code opProc( code[i] ) -- exit? if returnFlag then -- exit returnFlag = 0 exit end if end for -- restore runProc = priorProc uValue = priorVals uInit = priorInits -- pop trace stack if length(traceStack) then traceStack = traceStack[1..length(traceStack)-1] end if end procedure ----------------------------------------------------------------------------- function user_func_( sequence s ) -- user defined function -- { USER_EUFUNC, function, arg1, arg2 ... } -- run as if it were a procedure user_proc_( s ) if returnInit = 0 then runErr( "no value returned from %s", {pUser[s[2]][P_NAME]} ) end if -- clear init returnInit = 0 -- return value return euReturnValue end function global procedure euProc( sequence proc, sequence params ) integer proc_id proc_id = findRoutine( proc ) user_proc_( { USER_PROC, 0, proc_id } & params) --opProc( { proc_id, params } ) end procedure --euproc = routine_id( "euProc" ) global function euFunc( sequence func, sequence params ) integer func_id func_id = findRoutine( func ) return user_func_( { USER_EUFUNC, func_id} & params ) end function --eufunc = routine_id( "eufunc" ) ----------------------------------------------------------------------------- function get_local_( sequence s ) -- get a variable -- { GET_LOCAL, index } integer index -- get the index index = s[2] if uInit[ index ] != 0 then -- return value return uValue[ index ] end if -- not initialized runErr( "variable %s has not been assigned", {pUser[runProc][P_VARS][index]} ) end function ----------------------------------------------------------------------------- function get_module_( sequence s ) -- get a variable -- { GET, index } integer index -- get the index index = s[2] if vInit[ index ] != 0 then -- return value return vValue[ index ] end if -- not initialized runErr( "variable %s has not been assigned", {vName[index]} ) return -1 end function ----------------------------------------------------------------------------- procedure set_local_( sequence s ) -- set a local variable -- { SET_LOCAL, line, op, index, expression } integer op, index -- trace traceLine( s ) -- get the scope and index op = s[3] index = s[4] -- not initialized? if op != EQ and uInit[index] = 0 then -- not initialized runErr( "variable %s has not been assigned", {pUser[runProc][P_VARS][index]} ) end if -- should add type checking... if op = EQ then uValue[ index ] = opFunc( s[5] ) elsif op = ADD then uValue[ index ] += opFunc( s[5] ) elsif op = SUB then uValue[ index ] -= opFunc( s[5] ) elsif op = MUL then uValue[ index ] *= opFunc( s[5] ) elsif op = DIV then uValue[ index ] /= opFunc( s[5] ) elsif op = CONCAT then uValue[ index ] &= opFunc( s[5] ) end if -- added type checking for LOCAL assignment checkType( runProc, index, uValue[ index ] ) -- set initialized flag uInit[ index ] = 1 end procedure ----------------------------------------------------------------------------- procedure set_module_( sequence s ) -- set a module variable -- { SET_MODULE, line, op, index, expression } integer op, index -- trace traceLine( s ) -- get the scope and index op = s[3] index = s[4] -- not initialized? if op != EQ and vInit[index] = 0 then -- not initialized runErr( "variable %s has not been assigned", {vName[index]} ) end if -- should add type checking... if op = EQ then vValue[ index ] = opFunc( s[5] ) elsif op = ADD then vValue[ index ] += opFunc( s[5] ) elsif op = SUB then vValue[ index ] -= opFunc( s[5] ) elsif op = MUL then vValue[ index ] *= opFunc( s[5] ) elsif op = DIV then vValue[ index ] /= opFunc( s[5] ) elsif op = CONCAT then vValue[ index ] &= opFunc( s[5] ) end if -- added type checking for MODULE assignment checkType( 0, index, vValue[ index ] ) -- store global and mark vInit[ index ] = 1 end procedure ----------------------------------------------------------------------------- procedure checkIndex( integer index, object o ) -- make sure index is in range -- not a sequence if not sequence( o ) then -- error runErr( "attempt to subscript an atom (reading from it)", {} ) end if -- out of range if index < 0 or index > length( o ) then runErr( "subscript value of %d is out of bounds, " & "reading from sequence of length %d\n%s", {index, length(o), makePrintable( o ) } ) end if end procedure ----------------------------------------------------------------------------- procedure checkSlice( integer i1, integer i2, object o ) -- make sure a slice is good -- not a sequence? if not sequence( o ) then -- error runErr( "attempt to subscript an atom (reading from it)", {} ) end if if i1 < 1 then runErr( "slice lower index is less that 1 (%d)", {i1} ) elsif i1 > length( o ) and i2 > i1 then runErr( "slice starts past end of sequence (%d > %d)", {i1,length(o)} ) elsif i1 > i2 and i1-i2 != 1 then runErr("slice length is less than 0 (%d)", {i2-i1+1}) elsif i2 > length(o) then runErr("slice ends past end of sequence (%d > %d)", {i2,length(o)}) end if end procedure ----------------------------------------------------------------------------- function changeIndex( object s, sequence indexes, object val, integer op, integer thisIndex ) integer index if thisIndex <= length( indexes ) then -- get current index -- FLOOR it because INDEXES can be decimal e.g. 1.5 -- index = indexes[thisIndex] index = floor(indexes[thisIndex]) -- check range checkIndex( index, s ) -- recurse s[index] = changeIndex( s[index], indexes, val, op, thisIndex+1 ) else -- set value if op = EQ then return val elsif op = ADD then return s + val elsif op = SUB then return s - val elsif op = MUL then return s * val elsif op = DIV then return s / val elsif op = CONCAT then return s & val end if end if return s end function ----------------------------------------------------------------------------- function get_index_local_( sequence s ) -- get a value from a local variable -- { GET_INDEX_LOCAL, index, list of indexes } integer index, j sequence indexes object expr -- evaluate index = s[2] indexes = opFunc( s[3] ) -- not initialized? if uInit[index] = 0 then runErr( "variable %s has not been assigned", {pUser[runProc][P_VARS][index]} ) end if -- get value expr = uValue[index] -- extract value for i = 1 to length( indexes ) do -- get index j = indexes[i] -- check range checkIndex( j, expr ) -- get indexed expr = expr[ j ] end for return expr end function ----------------------------------------------------------------------------- function get_index_module_( sequence s ) -- get a value from a local variable -- { GET_INDEX_MODULE, index, list of indexes } integer index, j sequence indexes object expr -- evaluate index = s[2] indexes = opFunc( s[3] ) -- not initialized? if vInit[index] = 0 then runErr( "variable %s has not been assigned", {vName[index]} ) end if -- get value expr = vValue[index] -- extract value for i = 1 to length( indexes ) do -- get index j = indexes[i] -- check range checkIndex( j, expr ) -- get indexed expr = expr[ j ] end for return expr end function ----------------------------------------------------------------------------- procedure set_index_local_( sequence s ) -- set an index in a sequence variable -- { SET_INDEX_LOCAL, sourceLine, op, index, list of indexes, value } integer index, op sequence indexes object expr -- trace -- e.g. loc[1]=routine_id(...) traceLine( s ) -- evaluate op = s[3] index = s[4] indexes = opFunc( s[5] ) expr = opFunc( s[6] ) -- not initialized? if op != EQ and uInit[index] = 0 then runErr( "variable %s has not been assigned", {pUser[runProc][P_VARS][index]} ) end if -- set value and mark as initialized uValue[ index ] = changeIndex( uValue[ index ], indexes, expr, op, 1 ) uInit[ index ] = 1 end procedure ----------------------------------------------------------------------------- procedure set_index_module_( sequence s ) -- set an index in a sequence variable -- { SET_, sourceLine, op, index, list of indexes, value } integer index, op sequence indexes object expr -- trace -- e.g. mod[1]=routine_id(...) traceLine( s ) -- evaluate op = s[3] index = s[4] indexes = opFunc( s[5] ) expr = opFunc( s[6] ) -- not initialized? if op != EQ and vInit[index] = 0 then runErr( "variable %s has not been assigned", {vName[index]} ) end if -- set value and mark as initialized vValue[ index ] = changeIndex( vValue[ index ], indexes, expr, op, 1 ) vInit[ index ] = 1 end procedure ----------------------------------------------------------------------------- function changeSlice( object o, sequence indexes, object val, integer op ) integer i1, i2 -- get first index i1 = indexes[1] if length( indexes ) > 2 then -- check range checkIndex( i1, o ) -- recurse o[i1] = changeSlice( o[i1], indexes[2..length(indexes)], val, op ) else -- get second index i2 = indexes[2] -- check range checkSlice( i1, i2, o ) -- set value if op = EQ then o[i1..i2] = val elsif op = ADD then o[i1..i2] += val elsif op = SUB then o[i1..i2] -= val elsif op = MUL then o[i1..i2] *= val elsif op = DIV then o[i1..i2] /= val elsif op = CONCAT then o[i1..i2] &= val end if end if return o end function ----------------------------------------------------------------------------- function get_slice_local_( sequence s ) -- get a slice from a local -- slice can be indexed, for example: s[1][2..3] --> {1,2,3} -- { GET_SLICE_LOCAL, index, list of indexes } integer index, j, i1, i2 sequence indexes object expr -- evaluate index = s[2] indexes = opFunc( s[3] ) -- not initialized? if uInit[index] = 0 then -- not initialized runErr( "variable %s has not been assigned", {pUser[runProc][P_VARS][index]} ) end if -- expression expr = uValue[index] -- index into for i = 1 to length( indexes ) - 2 do -- get index j = indexes[i] -- check range checkIndex( j, expr ) -- index into expr = expr[j] end for -- slice range i1 = indexes[length(indexes)-1] i2 = indexes[length(indexes)] -- check slice checkSlice( i1, i2, expr ) -- return slice return expr[i1..i2] end function ----------------------------------------------------------------------------- function get_slice_module_( sequence s ) -- get a slice from a local -- slice can be indexed, for example: s[1][2..3] --> {1,2,3} -- { GET_SLICE_LOCAL, index, list of indexes } integer index, j, i1, i2 sequence indexes object expr -- evaluate index = s[2] indexes = opFunc( s[3] ) -- not initialized? if vInit[index] = 0 then -- not initialized runErr( "variable %s has not been assigned", {vName[index]} ) end if -- expression expr = vValue[index] -- index into for i = 1 to length( indexes ) - 2 do -- get index j = indexes[i] -- check range checkIndex( j, expr ) -- index into expr = expr[j] end for -- slice range i1 = indexes[length(indexes)-1] i2 = indexes[length(indexes)] -- check slice checkSlice( i1, i2, expr ) -- return slice return expr[i1..i2] end function ----------------------------------------------------------------------------- procedure set_slice_local_( sequence s ) -- set an index in a sequence variable -- this is slightly different than set_index; the slice value is in -- the last two values. for example, s[1][2..3] -> {1,2,3} -- { SET_SLICE_LOCAL, sourceLine, op, index, list of indexes, value } integer index, op sequence indexes object expr -- trace -- e.g. loc[b..c]=routine_id(...) traceLine( s ) -- evaluate op = s[3] index = s[4] indexes = opFunc( s[5] ) expr = opFunc( s[6] ) -- not initialized? if op != EQ and uInit[index] = 0 then -- not initialized runErr( "variable %s has not been assigned", {pUser[runProc][P_VARS][index]} ) end if -- set value and mark as initialized uValue[ index ] = changeSlice( uValue[ index ], indexes, expr, op ) uInit[ index ] = 1 end procedure ----------------------------------------------------------------------------- procedure set_slice_module_( sequence s ) -- see set_slice_local for details -- { SET_SLICE_module, sourceLine, op, index, list of indexes, value } integer index, op sequence indexes object expr -- trace -- e.g. mod[b..c]=routine_id(...) traceLine( s ) -- evaluate op = s[3] index = s[4] indexes = opFunc( s[5] ) expr = opFunc( s[6] ) -- not initialized? if op != EQ and vInit[index] = 0 then -- not initialized runErr( "variable %s has not been assigned", {vName[index]} ) end if -- set value and mark as initialized vValue[ index ] = changeSlice( vValue[ index ], indexes, expr, op ) vInit[ index ] = 1 end procedure ----------------------------------------------------------------------------- procedure set_constant_( sequence s ) -- set a constant -- { SET_CONSTANT, line, var1, expr1, var2, expr2 ... } integer index -- trace traceLine( s ) -- assign values to each constant for i = 3 to length( s ) by 2 do -- get the index index = s[i][2] -- evaluate, and store constant in module vValue[ index ] = opFunc( s[i+1] ) vInit[ index ] = 1 end for end procedure ----------------------------------------------------------------------------- procedure no_op_( sequence s ) -- do nothing -- { NO_OP } end procedure ----------------------------------------------------------------------------- function true_( sequence s ) -- return true, used in ELSE clauses -- { TRUE } return True end function ----------------------------------------------------------------------------- procedure return_proc_( sequence s ) -- return from a procedure -- { RETURN_PROC, line } -- trace traceLine( s ) -- set the return flag returnFlag = 1 end procedure ----------------------------------------------------------------------------- procedure return_func_( sequence s ) -- return from a function with a value -- { RETURN_EUFUNC, line, expr } -- trace traceLine( s ) -- evaluate expression euReturnValue = opFunc( s[3] ) -- flag a value is returned returnInit = 1 -- flag to exit loop returnFlag = 1 end procedure ----------------------------------------------------------------------------- procedure exit_( sequence s ) -- set exit flag -- { EXIT, line } -- trace traceLine( s ) -- set exit flag exitFlag = 1 end procedure ----------------------------------------------------------------------------- procedure if_( sequence s ) -- run if statement -- { IF, test1, line1, block1, test2, line2, block2 ... } sequence block -- examine each part of the if clause for i = 2 to length( s ) by 3 do -- trace, line information must be second element traceLine( s[i..i+1] ) -- get clause if opFunc( s[i] ) then -- run the block of code block = s[i+2] for j = 1 to length( block ) do -- execute it opProc( block[j] ) -- return or exit? if exitFlag or returnFlag then return end if end for -- exit the loop exit end if end for end procedure ----------------------------------------------------------------------------- procedure while_( sequence s ) -- run if statement -- { WHILE, line, test, block } sequence block -- get the block block = s[4] -- trace traceLine( s ) -- while the test is true... while opFunc( s[3] ) do -- execute each instruction of the block for j = 1 to length( block ) do -- execute instruction opProc( block[j] ) -- exit? if exitFlag then -- clear flag exitFlag = 0 -- leave return -- return? elsif returnFlag then -- leave return end if end for -- trace traceLine( s ) end while end procedure ----------------------------------------------------------------------------- -- there appears to be a 'nested for loop' bug in Euphoria 2.1 -- Workaround: change the FOR loop into a WHILE loop procedure for_( sequence s ) -- run for loop -- { FOR, line, var, start, end, step, codeBlock } integer index, scope atom forStart, forEnd, forStep atom forI sequence block -- trace traceLine( s ) -- index is in form { scope, index } scope = s[3][1] index = s[3][2] -- loop range forStart = opFunc( s[4] ) forEnd = opFunc( s[5] ) forStep = opFunc( s[6] ) -- non-euphoria error message if forStep = 0 then runErr( "the BY value of this FOR loop is ZERO", {} ) end if -- get the block of code block = s[7] -- mark index as intialized if scope = ROUTINE then uInit[ index ] = 1 else vInit[ index ] = 1 end if -- for loop -- need to change into a WHILE loop forI = forStart while True do if (forStep>0 and forI>forEnd) or (forStep<0 and forI<forEnd) then exit -- terminate loop end if -- update index variable if scope = ROUTINE then -- store and mark as initialized uValue[ index ] = forI -- i else -- store and mark as initialized vValue[ index ] = forI -- i end if for j = 1 to length( block ) do -- run code opProc( block[j] ) -- return? if returnFlag then return end if -- exit? if exitFlag then exitFlag = 0 return end if end for -- trace traceLine( s ) -- increment 'i' forI += forStep -- end for end while end procedure ----------------------------------------------------------------------------- function add_( sequence s ) -- add two values -- { ADD, expr1, expr2 } debug( "add", {} ) return opFunc( s[2] ) + opFunc( s[3] ) end function ----------------------------------------------------------------------------- function sub_( sequence s ) -- subtract two values -- { SUB, expr1, expr2 } debug( "sub", {} ) return opFunc( s[2] ) - opFunc( s[3] ) end function ----------------------------------------------------------------------------- function mul_( sequence s ) -- multiply two values -- { MUL, expr1, expr2 } debug( "mul", {} ) return opFunc( s[2] ) * opFunc( s[3] ) end function ----------------------------------------------------------------------------- function div_( sequence s ) -- divide two values -- { DIV, expr1, expr2 } debug( "div", {} ) return opFunc( s[2] ) / opFunc( s[3] ) end function ----------------------------------------------------------------------------- function negate_( sequence s ) -- negate a value -- { NEGATE, expr } debug( "negate", {} ) return - opFunc( s[2] ) end function ----------------------------------------------------------------------------- function concat_( sequence s ) -- concatenate two values -- { CONCAT, expr1, expr2 } debug( "concat", {} ) return opFunc( s[2] ) & opFunc( s[3] ) end function ----------------------------------------------------------------------------- function not_( sequence s ) -- logical not expression -- { NOT, expr ) debug( "not", {} ) return not opFunc( s[2] ) end function ----------------------------------------------------------------------------- function and_( sequence s ) -- logical and two values -- { AND, expr1, expr2 } debug( "and", {} ) return opFunc( s[2] ) and opFunc( s[3] ) end function ----------------------------------------------------------------------------- function short_and_( sequence s ) -- logical and two values -- allow short-circuiting -- { SHORT_AND, expr1, expr2 } debug( "short_and", {} ) -- first expression true? if opFunc( s[2] ) then -- evaluate second return opFunc( s[3] ) else -- return false, skip second return False end if end function ----------------------------------------------------------------------------- function or_( sequence s ) -- logical or two values -- { OR, expr1, expr2 } debug( "or", {} ) return opFunc( s[2] ) or opFunc( s[3] ) end function ----------------------------------------------------------------------------- -- 'or' must be short-circuited in IF & WHILE function short_or_( sequence s ) -- logical or two values -- allow short-circuiting -- { SHORT_OR, expr1, expr2 } debug( "short_or", {} ) -- first expression true? if opFunc( s[2] ) then -- return true, skip second return True else -- evaluate second return opFunc( s[3] ) end if end function ----------------------------------------------------------------------------- function xor_( sequence s ) -- logical xor two values -- { XOR, expr1, expr2 } debug( "xor", {} ) return opFunc( s[2] ) xor opFunc( s[3] ) end function ----------------------------------------------------------------------------- function eq_( sequence s ) -- equal -- { EQ, expr1, expr2 } debug( "eq", {} ) return opFunc( s[2] ) = opFunc( s[3] ) end function ----------------------------------------------------------------------------- function ne_( sequence s ) -- not equal -- { NE, expr1, expr2 } debug( "ne", {} ) return opFunc( s[2] ) != opFunc( s[3] ) end function ----------------------------------------------------------------------------- function gt_( sequence s ) -- greater than -- { GT, expr1, expr2 } debug( "gt", {} ) return opFunc( s[2] ) > opFunc( s[3] ) end function ----------------------------------------------------------------------------- function ge_( sequence s ) -- greater or equal than -- { GE, expr1, expr2 } debug( "ge", {} ) return opFunc( s[2] ) >= opFunc( s[3] ) end function ----------------------------------------------------------------------------- function lt_( sequence s ) -- less than -- { LT, expr1, expr2 } debug( "lt", {} ) return opFunc( s[2] ) < opFunc( s[3] ) end function ----------------------------------------------------------------------------- function le_( sequence s ) -- less or equal than -- { LE, expr1, expr2 } debug( "le", {} ) return opFunc( s[2] ) <= opFunc( s[3] ) end function ----------------------------------------------------------------------------- function data_( sequence s ) -- return value -- { DATA, value } return s[2] end function ----------------------------------------------------------------------------- function seq_( sequence s ) -- evalute sequence of data -- { SEQ, item1, item2 ... } sequence seq debug( "seq", {} ) seq = repeat( 0, length(s)-1 ) for i = 1 to length( seq ) do -- replace each item with value seq[i] = opFunc( s[i+1] ) end for return seq end function ----------------------------------------------------------------------------- function empty_( sequence s ) -- empty sequence -- { EUEMPTY } debug( "empty", {} ) return {} end function ----------------------------------------------------------------------------- -- sequence functions -- seq_fetch from Jiri Babor -- mwl 12/12/00 ----------------------------------------------------------------------------- function seq_fetch(object a, sequence b) for i = 1 to length(b) do a = a[b[i]] end for return a end function function seq_store(object a, object b, object c) integer len len = length(c) if len > 1 then -- recursively go into the sequence return seq_store(a, b[c[1]], c[2..len] ) end if -- get the index c = c[1] if c then b[c] = a else b = a end if return b end function -- set opcodes -- procedures opCode[ EUFUNC ] = routine_id( "func_" ) opCode[ PROC ] = routine_id( "proc_" ) opCode[ RETURN_EUFUNC ] = routine_id( "return_func_" ) opCode[ RETURN_PROC ] = routine_id( "return_proc_" ) -- variables opCode[ GET_LOCAL ] = routine_id( "get_local_" ) opCode[ GET_MODULE ] = routine_id( "get_module_" ) opCode[ SET_LOCAL ] = routine_id( "set_local_" ) opCode[ SET_MODULE ] = routine_id( "set_module_" ) opCode[ GET_INDEX_LOCAL ] = routine_id( "get_index_local_" ) opCode[ GET_INDEX_MODULE ] = routine_id( "get_index_module_" ) opCode[ SET_INDEX_LOCAL ] = routine_id( "set_index_local_" ) opCode[ SET_INDEX_MODULE ] = routine_id( "set_index_module_" ) opCode[ GET_SLICE_LOCAL ] = routine_id( "get_slice_local_" ) opCode[ GET_SLICE_MODULE ] = routine_id( "get_slice_module_" ) opCode[ SET_SLICE_LOCAL ] = routine_id( "set_slice_local_" ) opCode[ SET_SLICE_MODULE ] = routine_id( "set_slice_module_" ) opCode[ SET_CONSTANT ] = routine_id( "set_constant_" ) -- statements opCode[ FOR ] = routine_id( "for_" ) opCode[ EXIT ] = routine_id( "exit_" ) opCode[ IF ] = routine_id( "if_" ) opCode[ WHILE ] = routine_id( "while_" ) opCode[ USER_PROC ] = routine_id( "user_proc_" ) opCode[ USER_EUFUNC ] = routine_id( "user_func_" ) -- opCode[ USER_TYPE ] = routine_id( "user_type" ) NOT DEFINED HENCE -1 opCode[ NO_OP ] = routine_id( "no_op_" ) opCode[ TRUE ] = routine_id( "true_" ) -- data operations opCode[ ADD ] = routine_id( "add_" ) opCode[ SUB ] = routine_id( "sub_" ) opCode[ MUL ] = routine_id( "mul_" ) opCode[ DIV ] = routine_id( "div_" ) opCode[ NEGATE ] = routine_id( "negate_" ) opCode[ CONCAT ] = routine_id( "concat_" ) opCode[ NOT ] = routine_id( "not_" ) opCode[ AND ] = routine_id( "and_" ) opCode[ SHORT_AND ] = routine_id( "short_and_" ) opCode[ OR ] = routine_id( "or_" ) opCode[ XOR ] = routine_id( "xor_" ) opCode[ EQ ] = routine_id( "eq_" ) opCode[ NE ] = routine_id( "ne_" ) opCode[ GT ] = routine_id( "gt_" ) opCode[ GE ] = routine_id( "ge_" ) opCode[ LT ] = routine_id( "lt_" ) opCode[ LE ] = routine_id( "le_" ) -- 'or' must be short-circuited in IF & WHILE opCode[ SHORT_OR ] = routine_id( "short_or_" ) -- embedded constants opCode[ DATA ] = routine_id( "data_" ) opCode[ SEQ ] = routine_id( "seq_" ) opCode[ EUEMPTY ] = routine_id( "empty_" ) ----------------------------------------------------------------------------- -- set opcode names for tracing -- procedures opName[ EUFUNC ] = "func" opName[ PROC ] = "proc" opName[ RETURN_EUFUNC ] = "return_func" opName[ RETURN_PROC ] = "return_proc" -- variables opName[ GET_LOCAL ] = "get_local" opName[ GET_MODULE ] = "get_module" opName[ SET_LOCAL ] = "set_local" opName[ SET_MODULE ] = "set_module" opName[ GET_INDEX_LOCAL ] = "get_index_local" opName[ GET_INDEX_MODULE ] = "get_index_module" opName[ SET_INDEX_LOCAL ] = "set_index_local" opName[ SET_INDEX_MODULE ] = "set_index_module" opName[ GET_SLICE_LOCAL ] = "get_slice_local" opName[ GET_SLICE_MODULE ] = "get_slice_module" opName[ SET_SLICE_LOCAL ] = "set_slice_local" opName[ SET_SLICE_MODULE ] = "set_slice_module" opName[ SET_CONSTANT ] = "set_constant" -- statements opName[ FOR ] = "for" opName[ EXIT ] = "exit" opName[ IF ] = "if" opName[ USER_PROC ] = "user_proc" opName[ USER_EUFUNC ] = "user_func" opName[ NO_OP ] = "no_op" opName[ TRUE ] = "true" -- data operations opName[ ADD ] = "add" opName[ SUB ] = "sub" opName[ MUL ] = "mul" opName[ DIV ] = "div" opName[ NEGATE ] = "negate" opName[ CONCAT ] = "concat" opName[ NOT ] = "not" opName[ AND ] = "and" opName[ OR ] = "or" opName[ XOR ] = "xor" opName[ EQ ] = "eq" opName[ NE ] = "ne" opName[ GT ] = "gt" opName[ GE ] = "ge" opName[ LT ] = "lt" opName[ LE ] = "le" -- embedded constants opName[ DATA ] = "data" opName[ SEQ ] = "seq" opName[ EUEMPTY ] = "empty" ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- wrappers for builtins ----------------------------------------------------------------------------- procedure qprint_( object o ) ? o end procedure ----------------------------------------------------------------------------- procedure abort_( integer i ) abort(i) end procedure ----------------------------------------------------------------------------- function and_bits_( object x1, object x2 ) return and_bits( x1, x2 ) end function ----------------------------------------------------------------------------- function append_( sequence s1, object x ) return append( s1, x ) end function ----------------------------------------------------------------------------- function arctan_( object x1 ) return arctan( x1 ) end function ----------------------------------------------------------------------------- function atom_( object x ) return atom( x ) end function ----------------------------------------------------------------------------- procedure call_( atom a ) call( a ) end procedure ----------------------------------------------------------------------------- function c_func_( integer i, sequence s ) return c_func( i, s ) end function ----------------------------------------------------------------------------- procedure c_proc_( integer i, sequence s ) c_proc( i, s ) end procedure ----------------------------------------------------------------------------- -- added to handle IDs in conjunction with 'routine_id_' function call_func_( integer i, sequence s ) -- 'id' has the routine's index with pUser if i < 0 then runErr( "invalid routine id", {} ) end if -- 'i' is equivalent to 'theProc' i.e. the routine's index within pUser -- check that it is indeed a 'function' if pUser[i][P_TYPE] = PROC then runErr( "no value returned from %s", {pUser[i][P_NAME]} ) end if -- since ALL the arguments have ALREADY been evaluated by 'func_' -- embed AS data for k = 1 to length(s) do s[k] = { DATA, s[k] } end for -- 'i' is equivalent to 'theProc' i.e. the routine's index within pUser -- therefore run as if it were a procedure WITHOUT a sourceline -- as a 'user function' would be defined -- { USER_EUFUNC, function, arg1, arg2 ... } -- append EUFUNC, index and arg list s = {USER_EUFUNC, i} & s return user_func_( s ) end function ----------------------------------------------------------------------------- procedure call_proc_( integer i, sequence s ) -- 'id' has the routine's index with pUser if i < 0 then runErr( "invalid routine id", {} ) end if -- 'i' is equivalent to 'theProc' i.e. the routine's index within pUser -- check that it is indeed a 'procedure' if pUser[i][P_TYPE] != PROC then runErr( "function result of %s must be assigned or used", {pUser[i][P_NAME]} ) end if -- since ALL the arguments have ALREADY been evaluated by 'proc_' -- embed AS data for k = 1 to length(s) do s[k] = { DATA, s[k] } end for -- 'i' is equivalent to 'theProc' i.e. the routine's index within pUser -- therefore run as if it were a procedure WITHOUT a sourceline -- as a 'user function' would be defined -- { USER_EUFUNC, function, arg1, arg2 ... } -- append EUFUNC, index and arg list s = {USER_EUFUNC, i} & s user_proc_( s ) end procedure ----------------------------------------------------------------------------- procedure clear_screen_() clear_screen() -- move below debugging position( TRACE_LINES+1, 1 ) end procedure ----------------------------------------------------------------------------- procedure close_( integer fn ) close( fn ) end procedure ----------------------------------------------------------------------------- function command_line_() return command_line() end function ----------------------------------------------------------------------------- function compare_( object x1, object x2 ) return compare( x1, x2 ) end function ----------------------------------------------------------------------------- function cos_( object x1 ) return cos( x1 ) end function ----------------------------------------------------------------------------- function date_() return date() end function ----------------------------------------------------------------------------- function equal_( object x1, object x2 ) return equal( x1, x2 ) end function ----------------------------------------------------------------------------- function find_( object x, sequence s ) return find( x, s ) end function ----------------------------------------------------------------------------- function floor_( object x1 ) return floor( x1 ) end function ----------------------------------------------------------------------------- function get_key_() return get_key() end function ----------------------------------------------------------------------------- function get_pixel_( sequence s ) return get_pixel( s ) end function ----------------------------------------------------------------------------- function getc_( integer fn ) return getc( fn ) end function ----------------------------------------------------------------------------- function getenv_( sequence s ) return getenv( s ) end function ----------------------------------------------------------------------------- function gets_( integer fn ) return gets( fn ) end function ----------------------------------------------------------------------------- function integer_( object x ) return integer( x ) end function ----------------------------------------------------------------------------- function length_( sequence s ) return length( s ) end function ----------------------------------------------------------------------------- function log_( object x1 ) return log( x1 ) end function ----------------------------------------------------------------------------- function machine_func_( atom a, object x ) return machine_func( a, x ) end function ----------------------------------------------------------------------------- procedure machine_proc_( atom a, object x ) machine_proc( a, x ) end procedure ----------------------------------------------------------------------------- function match_( sequence s1, sequence s2 ) return match( s1, s2 ) end function ----------------------------------------------------------------------------- procedure mem_copy_( atom a1, atom a2, integer i ) mem_copy( a1, a2, i ) end procedure ----------------------------------------------------------------------------- procedure mem_set_( atom a1, atom a2, integer i ) mem_set( a1, a2, i ) end procedure ----------------------------------------------------------------------------- function not_bits_( object x1 ) return not_bits( x1 ) end function ----------------------------------------------------------------------------- function object_( object x ) return object( x ) end function ----------------------------------------------------------------------------- function open_( sequence st1, sequence st2 ) return open( st1, st2 ) end function ----------------------------------------------------------------------------- function or_bits_( object x1, object x2 ) return or_bits( x1, x2 ) end function ----------------------------------------------------------------------------- function peek_( object a ) return peek( a ) end function ----------------------------------------------------------------------------- function peek4s_( object a ) return peek4s( a ) end function ----------------------------------------------------------------------------- function peek4u_( object a ) return peek4u( a ) end function ----------------------------------------------------------------------------- function platform_() return platform() end function ----------------------------------------------------------------------------- procedure pixel_( object x1, sequence s ) pixel( x1, s ) end procedure ----------------------------------------------------------------------------- procedure poke_( atom a, object x ) poke( a, x ) end procedure ----------------------------------------------------------------------------- procedure poke4_( atom a, object x ) poke4( a, x ) end procedure ----------------------------------------------------------------------------- procedure position_( integer i1, integer i2 ) -- position( i1, i2 ) -- move below debugging position( TRACE_LINES+i1, i2 ) end procedure ----------------------------------------------------------------------------- function power_( object x1, object x2 ) return power( x1, x2 ) end function ----------------------------------------------------------------------------- function prepend_( sequence s1, object x2 ) return prepend( s1, x2 ) end function ----------------------------------------------------------------------------- procedure print_( integer fn, object o ) print( fn, o ) end procedure ----------------------------------------------------------------------------- procedure printf_( integer fn, sequence st, object x ) printf( fn, st, x ) end procedure ----------------------------------------------------------------------------- procedure profile_( integer i ) profile( i ) end procedure ----------------------------------------------------------------------------- procedure puts_( integer fn, object x ) puts( fn, x ) end procedure ----------------------------------------------------------------------------- function rand_( object x1 ) return rand( x1 ) end function ----------------------------------------------------------------------------- function remainder_( object x1, object x2 ) return remainder( x1, x2 ) end function ----------------------------------------------------------------------------- function repeat_( object x, atom a ) return repeat( x, a ) end function ----------------------------------------------------------------------------- function routine_id_( sequence st ) object index atom current_fileindex -- is it a user defined routine? -- this routine, like the rest of the programs -- allows the 'builtins' to be redefined! -- search for solely the routines in the file where the 'routine_id' call -- is located i.e. in scope -- this will NOT be affected by the fact that the parser may have closed -- this file, because its 'fileindex' is recorded with the routine index = False current_fileindex = source[CURRENT_LINE_INDEX][2] -- LIFO ... from the most previous to the earliest ... -- please note: 'routines' are STACKED in the order that the -- PARSER FINDS THEM - DG for i = length(pUser) to 1 by -1 do if equal(pUser[i][P_NAME],st) and pUser[i][P_FILEINDEX] = current_fileindex then -- same file! index = i exit end if end for -- try GLOBAL -- note GLOBAL ROUTINES can be defined in any MODULE -- so 'fileIndex' is N/A here! if not index then -- is it a GLOBAL routine? index = findIndex(st, pVisible[GLOBAL]) if index then index = pVisible[GLOBAL][index][2] -- get the index end if end if if index then -- got the index -- user defined function/procedure return index -- return its ID that is 'theProc' index end if -- else routine does not exist -- its either 'builtin' or 'undefined' ... either way return -1 return -1 end function ----------------------------------------------------------------------------- function sequence_( object x ) return sequence( x ) end function ----------------------------------------------------------------------------- function sin_( object x1 ) return sin(x1) end function ----------------------------------------------------------------------------- function sprintf_( sequence st, object x ) return sprintf( st, x ) end function ----------------------------------------------------------------------------- function sqrt_( object x1 ) return sqrt(x1) end function ----------------------------------------------------------------------------- procedure system_( sequence st, integer i ) system(st,i) end procedure ----------------------------------------------------------------------------- function system_exec_( sequence st, integer i ) return system_exec(st,i) end function ----------------------------------------------------------------------------- function tan_( object x1 ) return tan(x1) end function ----------------------------------------------------------------------------- function time_() return time() end function ----------------------------------------------------------------------------- procedure trace_( integer i ) -- my trace routine traceFlag = i traceDepth = 9999 end procedure ----------------------------------------------------------------------------- function xor_bits_( object x1, object x2 ) return xor_bits( x1, x2 ) end function ----------------------------------------------------------------------------- -- assign builtins -- Non scriptible routines commented out...mwl 12/12/00 builtin = { { "?", PROC, 1, routine_id("qprint_") }, -- { "abort", PROC, 1, routine_id("abort_") }, -- { "and_bits", EUFUNC, 2, routine_id("and_bits_") }, -- { "append", EUFUNC, 2, routine_id("append_") }, -- { "arctan", EUFUNC, 1, routine_id("arctan_") }, -- { "atom", EUFUNC, 1, routine_id("atom_") }, -- { "call", PROC, 1, routine_id("call_") }, -- { "c_func", EUFUNC, 2, routine_id("c_func_") }, -- { "c_proc", PROC, 2, routine_id("c_proc_") }, -- { "call_func", EUFUNC, 2, routine_id("call_func_") }, -- { "call_proc", PROC, 2, routine_id("call_proc_") }, -- { "clear_screen", PROC, 0, routine_id("clear_screen_") }, -- { "close", PROC, 1, routine_id("close_") }, -- { "command_line", EUFUNC, 0, routine_id("command_line_") }, -- { "compare", EUFUNC, 2, routine_id("compare_") }, -- { "cos", EUFUNC, 1, routine_id("cos_") }, -- { "date", EUFUNC, 0, routine_id("date_") }, -- { "equal", EUFUNC, 2, routine_id("equal_") }, -- { "find", EUFUNC, 2, routine_id("find_") }, -- { "floor", EUFUNC, 1, routine_id("floor_") }, -- { "get_key", EUFUNC, 0, routine_id("get_key_") }, -- { "get_pixel", EUFUNC, 1, routine_id("get_pixel_") }, -- { "getc", EUFUNC, 1, routine_id("getc_") }, -- { "getenv", EUFUNC, 1, routine_id("getenv_") }, -- { "gets", EUFUNC, 1, routine_id("gets_") }, -- { "integer", EUFUNC, 1, routine_id("integer_") }, -- { "length", EUFUNC, 1, routine_id("length_") }, -- { "log", EUFUNC, 1, routine_id("log_") }, -- { "machine_func", EUFUNC, 2, routine_id("machine_func_") }, -- { "machine_proc", PROC, 2, routine_id("machine_proc_") }, -- { "match", EUFUNC, 2, routine_id("match_") }, -- { "mem_copy", PROC, 3, routine_id("mem_copy_") }, -- { "mem_set", PROC, 3, routine_id("mem_set_") }, -- { "not_bits", EUFUNC, 1, routine_id("not_bits_") }, -- { "object", EUFUNC, 1, routine_id("object_") }, -- { "open", EUFUNC, 2, routine_id("open_") }, -- { "or_bits", EUFUNC, 2, routine_id("or_bits_") }, -- { "peek", EUFUNC, 1, routine_id("peek_") }, -- { "peek4s", EUFUNC, 1, routine_id("peek4s_") }, -- { "peek4u", EUFUNC, 1, routine_id("peek4u_") }, -- -- NEW! dc { "platform", EUFUNC, 0, routine_id("platform_") }, { "pixel", PROC, 2, routine_id("pixel_") }, { "poke", PROC, 2, routine_id("poke_") }, -- { "poke4", PROC, 2, routine_id("poke4_") }, -- { "position", PROC, 2, routine_id("position_") }, -- { "power", EUFUNC, 2, routine_id("power_") }, -- { "prepend", EUFUNC, 2, routine_id("prepend_") }, -- { "print", PROC, 2, routine_id("print_") }, -- { "printf", PROC, 3, routine_id("printf_") }, -- { "profile", PROC, 1, routine_id("profile_") }, -- { "puts", PROC, 2, routine_id("puts_") }, -- { "rand", EUFUNC, 1, routine_id("rand_") }, -- { "remainder", EUFUNC, 2, routine_id("remainder_") }, -- { "repeat", EUFUNC, 2, routine_id("repeat_") }, -- { "routine_id", EUFUNC, 1, routine_id("routine_id_") }, -- { "sequence", EUFUNC, 1, routine_id("sequence_") }, -- { "sin", EUFUNC, 1, routine_id("sin_") }, -- { "sprintf", EUFUNC, 2, routine_id("sprintf_") }, -- { "sqrt", EUFUNC, 1, routine_id("sqrt_") }, -- { "system", PROC, 2, routine_id("system_") }, -- { "system_exec", EUFUNC, 2, routine_id("system_exec_") }, -- { "tan", EUFUNC, 1, routine_id("tan_") }, -- { "time", EUFUNC, 0, routine_id("time_") }, -- { "trace", PROC, 1, routine_id("trace_") }, -- { "xor_bits", EUFUNC, 2, routine_id("xor_bits_") }, -- { "sprint", EUFUNC, 1, routine_id("sprint") }, { "sprintf", EUFUNC, 2, routine_id("sprintf") }, { "pretty_sprint", EUFUNC, 1, routine_id("pretty_sprint")} } integer fresh_init ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- --function run_script_( sequence source ) -- sequence code -- code = {} -- while length( source ) do -- thisLine = source[1] -- parseLine( thisLine ) -- -- -- parse one instruction -- code = parse() -- -- -- did it result in executable code? -- if length( code ) then -- -- -- run the code -- opProc( code ) -- -- end if -- -- end while -- -- if returnInit then -- return euReturnValue -- else -- return 0 -- end if --end function global procedure resetLine() lineNumber = 0 end procedure sequence scripts scripts = {} integer current_script --/topic Reference --/proc run_script( sequence source_text ) -- --Parses and executes a script contained in /b source_text. --/b source_text should be a sequence of sequences. Each line --of script should be its own sequence. The parsed script is --added to the script buffer. global procedure run_script( sequence source_text ) object code fresh_init = 0 script = source_text -- code accumulator code = {} words = {} while not equal( thisWord(), EOF ) do -- parse one instruction code = parse() if atom( code ) then return end if -- did it result in executable code? if length( code ) then -- run the code opProc( code ) end if end while end procedure --euproc = routine_id( "runFile") --/topic Reference --/proc init_eu() -- --Initializes euscript. This is automatically called when --euscript is included and when builtin routines are added or --removed. -- put initialization into routine to enable reset of scripts -- mwl 12/12/00 procedure init_script() fileIndex = 1 lineNumber = 0 pVisible = repeat( {}, 3 ) pUser = {} vList = repeat( {}, 3 ) vName = {} vValue = {} vType = {} vInit = {} uValue = {} uInit = {} stack = {} included = {} source = {} traceStack = {} globalFlag = 0 theProc = 0 runProc = 0 returnFlag = 0 returnInit = 0 exitFlag = 0 typeCheckFlag = 1 traceFlag = 0 shortCircuitFlag = 0 sourceHandle = 0 lineNumber = 0 topTraceLine = 0 traceDepth = 0 euReturnValue = "" script = {} end procedure procedure save_script( integer id ) if not id then return end if scripts[id] = { fileIndex, lineNumber, pVisible, pUser, vList, vName, vValue, vType, vInit, uValue, uInit, stack, included, source, traceStack, globalFlag, theProc, runProc, returnFlag, returnInit, exitFlag, typeCheckFlag, traceFlag, shortCircuitFlag, sourceHandle, lineNumber, topTraceLine, traceDepth, euReturnValue, script } end procedure sequence the_sequence integer the_index function get_element() the_index += 1 return the_sequence[the_index] end function --/topic Reference --/func get_current_script() -- --Returns the id of the current script. global function get_current_script() return current_script end function --/topic Reference --/proc activate_script( integer id ) -- --Saves the current script and makes script /b id the --current script. global procedure activate_script( integer id ) sequence s save_script( current_script ) the_sequence = scripts[id] the_index = 0 fileIndex = get_element() lineNumber = get_element() pVisible = get_element() pUser = get_element() vList = get_element() vName = get_element() vValue = get_element() vType = get_element() vInit = get_element() uValue = get_element() uInit = get_element() stack = get_element() included = get_element() source = get_element() traceStack = get_element() globalFlag = get_element() theProc = get_element() runProc = get_element() returnFlag = get_element() returnInit = get_element() exitFlag = get_element() typeCheckFlag = get_element() traceFlag = get_element() shortCircuitFlag = get_element() sourceHandle = get_element() lineNumber = get_element() topTraceLine = get_element() traceDepth = get_element() euReturnValue = get_element() script = get_element() current_script = id end procedure --/topic Reference --/func new_script() -- --Creates a new script instance and returns the id of the script. --This new script will be completely separate from all other scripts. global function new_script() integer id save_script( current_script ) id = find(-1, scripts) if not id then id = length(scripts) + 1 scripts &= { {} } end if current_script = id init_script() init_script() save_script( id ) return id end function --/topic Reference --/proc delete_script( integer id ) -- --Deletes the script from memory. global procedure delete_script( integer id ) scripts[id] = -1 for i = 1 to length(scripts) do if compare(scripts[i], -1) then current_script = i return end if end for id = new_script() end procedure --/topic Reference --/proc init_eu() -- --Initializes euscript. Erases all scripts from memory, and initializes --a new script with id = 1. global procedure init_eu() integer id scripts = {} current_script = 0 id = new_script() fresh_init = 1 init_script() save_script(1) end procedure --/topic Reference --/proc add_routine( sequence name, integer rtype, integer args, integer rid ) -- --Add a builtin routine that can be called by scripts. /b name should be --the name of the routine as it will be called from within a script. --/b rtype should be either \b EUFUNC or \b PROC, depending on the type of --the routine. /b args is the number of arguments that must be passed when --the routine is called. /b rid is the routine id of the actual routine in --your code that is called from the script. -- --Calling add_routine() clears the script buffer. ----------------------------------------------------------------------------- global procedure add_routine( sequence name, integer rtype, integer args, integer rid ) builtin = append( builtin, { name, rtype, args, rid } ) if not fresh_init then init_eu() end if end procedure ----------------------------------------------------------------------------- --/topic Reference --/proc remove_routine( sequence name ) -- --Removes a builtin script routine. A builtin routine is either --a predefined routine, or a user defined routine added by --/add_routine(). You can also pass a sequence of names to have --multiple routines removed with one call. -- --Calling remove_routine() clears the script buffer. global procedure remove_routine( sequence name ) integer ix if not length(name) then return end if if atom(name[1]) then name = {name} end if for j = 1 to length(name) do for i = 1 to length(builtin) do if equal( name[j], builtin[i][1] ) then builtin = builtin[1..i-1] & builtin[i+1..length(builtin)] exit end if end for end for if not fresh_init then init_eu() end if end procedure --/topic Reference --/proc set_err_routine( integer rid ) -- --This allows you to set a routine to be called when an --error is encountered. Your routine must take 4 arguments: --/code --ex: -- procedure my_error( sequence s1, sequence s2, sequence text, atom line_number ) -- printf(1, "%s\nLine: %d\n", { text, line_number } ) -- printf(1, s1 & "\n", s2 ) -- end procedure --/endcode --/b s1 and /b s2 are a format string and arguments for the description of the error, --/b text is the line of code with the error and /b line_number is the line within the --script buffer where the error occured. -- --This routine will be called multiple times for the same error, due to the internals --of euscript, so you should set and check a flag to determine whether your error --routine has been called whenever you execute a script. global procedure set_err_routine( integer rid ) err_routine = rid end procedure init_eu() --/topic Reference --/info --Global functions and procedures -- -- --/topic Using euscript --/info --What can I do with this? -- --Euscript is meant to allow you to add euphoria scripting to your applications. This --means that users can create their own scripts (like Visual Basic for Applications), --or that you can dynamically generate and execute code within an application. Although --extensive testing hasn't been done to prove this, euscript should be compatible with --all Euphoria 2.2 code. -- --There is a little work involved in allowing euscript code to interact with the rest --of your application. You must provide wrappers for each routine and variable within --your code that you want visible to scripts (see /add_routine). Adding visibility --for a routine is fairly straightforward. -- --Variables are a little more tricky, --since you can't refer to variables by reference in the official Euphoria interpreter. --Instead, you need to write a wrapper routine for reading and writing each variable, --and then making the routine visible through /add_routine. Then, in order to change --or read a program variable from a script, the script will call the wrapper routine. --/code --ex: -- atom x -- sequence s -- -- procedure set_var( sequence var, object val ) -- if equal(var,"s") then -- s = val -- elsif equal(var,"x") then -- x = val -- end if -- end procedure -- add_routine( "set_var", PROC, 2, routine_id("set_var")) -- -- function get_var( sequence var ) -- if equal( var, "s" ) then -- return s -- elsif equal( var, "x" ) then -- return x -- end if -- return 0 -- end function -- add_routine( "get_var", EUFUNC, 1, routine_id("get_var")) -- -- -- now, scripts can read and write x or s by calling -- -- x = get_var( "x" ) or set_var( "x", x ) -- -- s = get_var( "s" ) or set_var( "s", s ) --/endcode -- --You can also remove certain builtin routines if you don't want to allow scripts --to have access to such builtins as peek/poke/puts/etc. See /remove_routine. -- --It is possible to have multiple scripts in memory. Each script will not be --able to interact with the others. This can be useful to prevent namespace --clashes among scripts, or simply to ensure that one script cannot interferre --with another. It also allows you to remove scripts from memory when they --are no longer needed.
