Re: EDB.EXW Database Browser

new topic     » goto parent     » topic index » view thread      » older message » newer message
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. 
new topic     » goto parent     » topic index » view thread      » older message » newer message

Search



Quick Links

User menu

Not signed in.

Misc Menu