
'LEXI
'03:50 23/09/2018
'10:05 18/07/2022

int swd               'position of word
int nwd               'position of next word
int lenw              'length of word
int ascw              'first ascii character of word
int ascn              'first character of next word / end of line
int dtf               'position of first dot in word
int qot               'quote flag
int icas              'inhibit case conversion
int ilc               'inhibit line continue '_'
int nmb               'number flag
int casf              'case mode flag

string htb=chr(9)     'HORIZONTAL TAB
string cr=chr(13,10)  'CarriageReturn+LineFeed
string qu=chr(34)     'DOUBLE QUOTE MARK
string cm=chr(44)     'COMMA

int elct              'element counter
int nobr              'flag preventing array interpration (bracket)


int lbr=40 '(
int rbr=41 ')
int iq1=34 '"
int iq2=96 '`
int ct1=39 ''
int ct2=59 ';
int sr1=58 ':
int sr2=58 ':


=========
'IS WHAT?
=========



==============
jmp fwd _over_
==============

'QUOTEMARK

macro isq int (r,a)
===================
/**
 identifies a quote code

  @param a is the ascii code
  @return boolean -1 if identified

  quote marks are 34" or 96` or the
  internal quote code
**/
  mov eax,a
  call isq_asm
  #snip
  mov r,eax
end macro
'
isq_asm:
(
cmp eax,iq1 : jz exit
cmp eax,iq2 : jz exit
mov eax,0 : ret
)
mov eax,-1  : ret
'
macro isn int (r,a)
===================
/**
 identifies a number code or minus
 sign or dot

  @param a is the ascii code
  @return boolean -1 if a number or
  1 if a minus sign or dot
**/
   mov eax,a
   call isn_asm
   #snip
   mov r,eax
end macro
'
macro isa int (r,a)
====================
/**
 identifies an alphabetic code,
 uppercase or  lowercase or upper ascii

  @param a is the ascii code
  @return 0 if unidentified, otherwise
  return:
  -3  uppercase
  -5  lowercase
  -7  upper ascii
  -9  underscore
  -11 # hash
**/
   mov eax,a
   call isa_asm
   #snip
   mov r,eax
end macro
'
macro isw int (r,a)
===================
/**
 identifies an alphanumeric code,
 uppercase or lowercase or upper ascii

  @param a is the ascii code
  @return 0 if unidentified, otherwise
  return:
   1  dot
  -1  number
  same as isa(a):
  -3  uppercase
  -5  lowercase
  -7  upper ascii
  -9  underscore
  -11 # hash
**/
   mov eax,a
   call isw_asm
   #snip
   mov r,eax
end macro
'
isn_asm:
========
(
 cmp eax,0x30 : jl exit
 cmp eax,0x39 : jg exit
 mov eax,-1 : ret
)
(
 cmp eax,45 : jnz exit
 mov eax,1 : ret
)
(
 cmp eax,46 : jnz exit
 mov eax,1 : ret
)
mov eax,0 : ret

isw_asm:
========
'number
(
 cmp eax,0x30 : jl exit
 cmp eax,0x39 : jg exit
 mov eax,-1 : ret
)
'dot
(
 cmp eax,46 : jnz exit
 mov eax,1 : ret
)
isa_asm:
========
'uppercase
(
 cmp eax,0x41 : jl exit
 cmp eax,0x5a : jg exit
 mov eax,-3 : ret
)
'lowercase
(
 cmp eax,0x61 : jl exit
 cmp eax,0x7a : jg exit
 mov eax,-5 : ret
)
'upper ascii including 127
(
 cmp eax,0x7f : jl exit
 cmp eax,0xfc : jge exit '252-255 EXCLUDE SYSTEM SYMBOLS
 mov eax,-7 : ret        '127 and upper ascii
)
'underscore
(
 cmp eax,95 : jnz exit
 mov eax,-9 : ret
)
'hash
(
 cmp eax,35 : jnz exit
 mov eax,-11 : ret
)
mov eax,0
ret

macro isxn int (r)
==================
/**
 identifies the end of an expression
 from the state variable ascn

  @return boolean -1 if identified

  end of expression ascii codes include 
  44, 41) 93] 125}. Codes identified by iss()
  are also included as end of expression
  identifiers
**/
  call isxn_asm
  #snip
  mov r,eax
end macro
'
macro nisxn int (r)
===================
/**
 identifies that an expression continues,
 using the state variable ascn

  @return boolean -1 if identified

  this function is the opposite of isxn
**/
  call isxn_asm
  not eax
  #snip
  mov r,eax
end macro
'
macro isx int (r,a)
===================
/**
 identifies the end of an expression

  @parem a is the ascii code
  @return boolean -1 if identified

  end of expression ascii codes include 
  44, 41) 93] 125}. Codes identified by iss()
  are also included as end of expression
  identifiers
**/
  mov eax,a
  call isx_asm
  #snip
  mov r,eax
end macro
'
macro iss int (r,a)
===================
/**
 identifies the end of a statement

  @parem a is the ascii code
  @return boolean -1 if identified

  end of statement ascii codes can be 58: or 59;
  codes identified by ise() are also
  included as end of statement identifiers
**/
  mov eax,a
  call iss_asm
  #snip
  mov r,eax
end macro
'
macro ise int (r,a)
===================
/**
 identifies end of line

  @parem a is the ascii code
  @return boolean -1 if identified

  end of line ascii codes can be 13, 10 or 0
  comments identified by isc() are also
  included as end of line markers
**/
  mov eax,a
  call ise_asm
  #snip
  mov r,eax
end macro
'
macro isc int (r,a)
===================
/**
 identifies comments

  @parem a is the ascii code
  @return boolean -1 if identified

  normally comments are ascii 39' or ascii 59;
**/
  mov eax,a
  call isc_asm
  #snip
  mov r,eax
end macro
'
isxn_asm:
========
mov eax,ascn
'
isx_asm:
========
(
 cmp eax,44 : jnz exit
 mov eax,-1 : ret
)
(
 cmp eax,41 : jnz exit
 mov eax,-1 : ret
)
(
 cmp eax,93 : jnz exit
 mov eax,-1 : ret
)
(
 cmp eax,125 : jnz exit
 mov eax,-1 : ret
)
iss_asm:
========
(
 cmp eax,sr1 : jnz exit
 mov eax,-1 : ret
)
(
 cmp eax,sr2 : jnz exit
 mov eax,-1 : ret
)
ise_asm:
========
(
 cmp eax,13 : jnz exit
 mov eax,-1 : ret
)
(
 cmp eax,10 : jnz exit
 mov eax,-1 : ret
)
(
 cmp eax,0 : jnz exit
 mov eax,-1 : ret
)
isc_asm:
========
(
 cmp eax,ct1 : jnz exit
 mov eax,-1 : ret
)
(
 cmp eax,ct2 : jnz exit
 mov eax,-1 : ret
)
mov eax,0 : ret


macro isb int (r,a)
===================
/**
 identifies left side brackets

  @parem a is the ascii code
  @return the ascii code for the
  matching right side bracket, or 0
**/
  mov eax,a
  call isb_asm
  #snip
  mov r,eax
end macro
'
isb_asm:
(
 cmp eax,40 : jnz exit
 mov eax,41 : ret
)
(
 cmp eax,91 : jnz exit
 mov eax,93 : ret
)
(
 cmp eax,123 : jnz exit
 mov eax,125 : ret
)
mov eax,0 : ret


macro iscpu int (r,a)
=====================
/**
  identifies numeric types that are processed
  in the Central Processor Unit

  @parem a is the type code
  @return boolean -1 if this is the type
**/
  mov eax,a
  call iscpu_asm
  #snip
  mov r,eax
end macro
'
iscpu_asm:
(
 cmp eax,0x00 : jl exit
 cmp eax,0x39 : jg exit
 mov eax,-1 : ret
)
mov eax,0 : ret


macro isfpu int (r,a)
=====================
/**
  identifies types that can be processed
  in the Floating Point Unit

  @parem a is the type code
  @return boolean -1 if this is the type
**/
  mov eax,a
  call isfpu_asm
  #snip
  mov r,eax
end macro
'
isfpu_asm:
(
 cmp eax,0x40 : jl exit
 cmp eax,0x7f : jg exit
 mov eax,-1 : ret
)
mov eax,0 : ret


macro isfloat int (r,a)
=======================
/**
  identifies single and double precision types

  @parem a is the type code
  @return boolean -1 if this is the type
**/
  mov eax,a
  call isfloat_asm
  #snip
  mov r,eax
end macro
'
isfloat_asm:
(
 cmp eax,0x60 : jl exit
 cmp eax,0x7f : jg exit
 mov eax,-1 : ret
)
mov eax,0 : ret

macro isstr int (r,a)
=====================
/**
  identifies all string types
  @parem a is the type code
  @return boolean -1 if this is the type
**/
  mov eax,a
  call isstr_asm
  #snip
  mov r,eax
end macro
'
isstr_asm:
(
 cmp eax,0xa0 : jl exit
 cmp eax,0xff : jg exit
 mov eax,-1 : ret
)
mov eax,0 : ret


macro isdstr int (r,a)
======================
/**
  identifies dynamic (bstr and oxygen ) strings
  @parem a is the type code
  @return boolean -1 if this is the type
**/
  mov eax,a
  call isdstr_asm
  #snip
  mov r,eax
end macro
'
isdstr_asm:
(
 cmp eax,0xc0 : jl exit
 cmp eax,0xff : jg exit
 mov eax,-1 : ret
)
mov eax,0 : ret


macro isbstr int (r,a)
======================
/**
  identifies bstring type strings
  @parem a is the type code
  @return boolean -1 if this is the type
**/
  mov eax,a
  call isbstr_asm
  #snip
  mov r,eax
end macro
'
isbstr_asm:
(
 cmp eax,0xc0 : jl exit
 cmp eax,0xdf : jg exit
 mov eax,-1 : ret
)
mov eax,0 : ret


macro isostr int (r,a)
======================
/**
  identifies OxygenBasic type strings
  @parem a is the type code
  @return boolean -1 if this is the type
**/
  mov eax,a
  call isostr_asm
  #snip
  mov r,eax
end macro
'
isostr_asm:
(
 cmp eax,0xe0 : jl exit
 cmp eax,0xff : jg exit
 mov eax,-1 : ret
)
mov eax,0 : ret


macro iszstra int (r,a)
=======================
/**
  identifies char* type strings
  @parem a is the type code
  @return boolean -1 if this is the type
**/
  mov eax,a
  call iszstr_asm
  #snip
  mov r,eax
end macro
'
iszstr_asm:
(
 cmp eax,0xa0 : jl exit
 cmp eax,0xbf : jg exit
 mov eax,-1 : ret
)
mov eax,0 : ret


=======
._over_
=======

function instrevn(int i, char*s,*wr) as int
===========================================
/**
  searches backwards for a keyword in a string

  @param i is the start index
  @param s is the text string to be searched
  @param wr is keyword/chars to look for
  @return the index position where the key is located

  if the search failes then 0 is returned
**/
  int k,le
  byte*bt,*bs,*bw
  '
  @bt=strptr(s)
  if not @bt
    exit function
  endif
  '
  @bw=strptr(wr)
  if not @bw
    exit function
  endif
  '
  le=len(wr)
  if le=0
    exit function
  endif
  '
  if i<=0
    i=len(s)-i '-1 indicates start from right
  endif
  @bt+=i-1
  k=bw
  '
  do
    i-- : @bt--
    if i<1
      exit do
    endif
    if bt=k
      'compare rest of bytes
      @bs=@bt+1
      @bw=strptr(wr)+1
      int j
      for j=2 to le
        if bs<>bw
          continue do
        endif
        @bs++ : @bw++
      next
      exit do
    endif
  loop
  '
  return i
  '
end function



function ascl(string s, int*i) as int
=====================================
/**
  returns the lowercase value of an ascii char

  @param a is the text string
  @param i is the index to the char
  @return the converted lowercase value
**/
  int a
  a=asc(s,i)
  select a
  case  0x41 to 0x5a : a+=32
  end select
  return a
end function

/*
procedure LineCont(sys *p)
==========================
'_' underscore
byte bt at p
int sk 'in-comment flag
if bt[1]>32
  exit procedure
endif
do
  @bt++
  ascn=bt 'next byte
  select ascn
  case 0         : exit do
  case sk>0      : 'skip comment
  case 65 to 90  : ascn+=32 : exit do 'to lower case
  case 33 to 255 : exit do
  case 10,13     : sk=0
  case ct1,ct2   : sk=1 'start comment
  end select
end do
end procedure
*/

procedure endline(char*s, int*i)
================================
/**
  moves across the string until a line
  ending, or string ending is encountered

  @param s is the text string
  @param i is the char index being moved
**/
  byte*bt
  @bt=strptr(s)
  if not @bt
    exit procedure
  endif
  @bt+=i-1
  do
    ascn=bt
    select ascn
    case  0 : exit do
    case 10 : exit do
    case 13 : exit do
    end select
    i++ : @bt++
  loop
  nwd=i
end procedure


procedure nextspace(char*s, int*i)
==================================
/**
  moves across visible chars until a white
  space char is encountered

  @param s is the text string
  @param i is the char index being moved
**/
  byte*bt
  @bt=strptr(s)
  if not @bt
    exit procedure
  endif
  @bt+=i-1
  int q
  do
    select bt
    case 0 to 32 : exit procedure
    end select
    i++ : @bt++
  loop
end procedure


procedure skipspace(char*s, int*i)
==================================
/**
  moves over white space until a visible char is
  encountered. Line endings are passed over, like
  the other white space chars.

  @param s is the text string
  @param i is the char index being moved
**/
  byte*bt,*bb
  @bt=strptr(s)
  if not @bt
    exit procedure
  endif
  @bt+=i-1
  @bb=@bt
  do
    ascn=bt
    select ascn
    case 0 : exit do
    case 65 to 90 : ascn+=32 : exit do 'force lowercase
    'case 95      : LineCont(@bt) : exit do
    case 33 to 255 : exit do
    end select
    @bt++
  loop
  @bt-=@bb
  i+=@bt
  nwd=i
end procedure


procedure skiplspace(char*s, int*i)
===================================
/**
  moves over white space until a visible char is
  encountered, or the end of a line is reached

  @param s is the text string
  @param i is the char index being moved
**/
  byte*bt,*bb
  @bt=strptr(s)
  if not @bt
    exit procedure
  endif
  @bt+=i-1
  @bb=@bt
  do
    ascn=bt
    select ascn
    case  0 : exit do
    case 13 : exit do
    case 10 : exit do
    case 65 to 90 : ascn+=32 : exit do 'force lowercase
    'case 95      : LineCont(@bt) : exit do
    case 33 to 255 : exit do
    end select
    @bt++
  loop
  @bt-=@bb
  i+=@bt
  nwd=i
end procedure


procedure skipquote(char*s, int*i)
==================================
/**
   moves the index past the end of the quote

   @param s is the text string
   @param i is the moving char index
**/
  int b
  byte*bt
  @bt=strptr(s)
  if not @bt
    exit procedure
  endif
  @bt+=i-1
  'skip quoted expression
  b=bt
  do
    i++ : @bt++
    select bt
      case 0  : exit procedure
      case b  : exit do
    end select
  loop
  i++
end procedure


function uword(string*s, int*i) as string
=========================================
  byte bb at strptr(s)-1
  skipspace(s,i)
  swd=i
  do
    ascn=bb[i]
    select ascn
    case 0 to 32
      exit do 'white space
    case 44 ',
      exit do
    end select
    i++
  loop
  lenw=i-swd
  if ascn=44
    i++
  endif
  if lenw>0
    return mid(s,swd,lenw)
  endif
end function


function yword(string*s, int*i) as string
=========================================
/**
   reads words separated by spaces

   quotedexpressions are treated as one word

   @param s is the source text
   @param i is the string index
   @return the word identified

   the index is updated when this function
   is called.

   left spaces are skipped, and right spaces
   are skipped until an non-space or end of line
   is encountered.
**/
  byte bb at strptr(s)-1
  skipspace(s,i)
  swd=i
  do
    ascn=bb[i]
    select ascn
    case 0 to 32
      exit do
    case 34
      i=instr(i+1,s,chr(ascn))
      if i=0
        i=len(s)
      endif
    end select
    i++
  loop
  lenw=i-swd
  skiplspace(s,i)
  if lenw>0
    return mid(s,swd,lenw)
  endif
end function


procedure clcase(char*wr)
=========================
/**
  conditional case conversion with
  casf

  '0 CASE INSENSITIVE
  '1 CASE INSENSITIVE
  '2 CASE SENSITIVE
  '3 CAPITALISED WORD SENSITIVE
**/
  int b,c,i
  byte *bt
  @bt=strptr wr
  if not @bt
    exit procedure
  endif
  select casf
  case 0 to 1 : c=1
  case 3
    do
      select bt
        case 0  : exit do
        case 0x61 to 0x7a : c=1 : exit do 'a to z :
      end select
      @bt++
    loop
  end select
  if c
    @bt=strptr wr
    do
      select bt
        case 0 : exit do
        case 0x41 to 0x5a : bt+=32
      end select
      @bt++
    loop
  endif
end procedure


procedure vword(char*s, int*i)
==============================
'FOR O2ASSM ETC / NO SUFFIX STRIPPING
qot=0
byte bb at strptr(s)-1
ascw=bb[i]
swd=i
do
  select bb[i]
    case 0  to 32
      exit do
    case 46
      'continue
    case iq1,iq2
      qot=1
      skipquote s,i
      exit do
    case 33 to 38,63 '!#$%&? endings
      'continue
    case 39 to 47
      exit do
    case 91,93
      exit do
    case 123,125
      exit do
  end select
  i++
loop
if swd=i
  if ascw<>0
    i++
  endif
endif
lenw=i-swd
end procedure


function aword(string*s, int*i) as string
=========================================
string wr
skipspace(s,i)
vword(s,i)
skiplspace(s,i)
if lenw
  wr=mid s,swd,lenw
  if qot=0
    clcase(wr)
    ascw=asc(wr)
  endif
endif
return wr
end function


procedure roundupc(int*v,n)
===========================
  int c
  if (v=0)or(n<=1)
    exit procedure
  endif
  c=mod v,n
  if c
    v+=n-c
  endif
end procedure

procedure roundup(int*v,n)
==========================
  int c
  '
  'IF LARGER THAN 4 BYTES (OR 8 BYTES) THEN ROUND UP TO NEXT
  '
  if n=3
    n=4 '1 2 4 alignment
  endif
  if n>cpuw
    c=-cpuw
    c and= n
    if c<n
      n=c+cpuw
    endif
  endif
  '
  'ROUND UP TO NEXT ALIGNMENT
  '
  c=-n
  c and= v
  if c<v
    v=c+n
  endif
end procedure


function readint(string*s, int*i)  as int
=========================================
  '
  int a,sg
  byte bb at strptr(s)-1
  skipspace(s,i)
  swd=i
  sg=1
  if bb[i]=45
    sg=-1
    i++
  endif
  do
    ascn=bb[i]
    select ascn
    case  0 to 32 : exit do
    case 48 to 57 : a=a*10+(ascn-48)
    end select
    i++
  loop
  lenw=i-swd
  skiplspace(s,i)
  return a*sg
end function



procedure mk2(char*s, int i, short v)
=====================================
/**
  takes a  short (2bytes) integer
  and patches its binary into a string

  @param s is the string
  @param i is the char index in the string
  @param v is the short
**/
short pv at strptr(s)+i-1
pv=v
end procedure


procedure mk4(char*s, int i,long v)
===================================
/**
  takes a  long (4bytes) integer
  and patches its binary into a string

  @param s is the string
  @param i is the char index in the string
  @param v is the integer
**/
long pv at strptr(s)+i-1
pv=v
end procedure


procedure mk8(char*s, int i, quad v)
====================================
/**
  takes a  quad (8bytes) integer
  and patches its binary into a string

  @param s is the string
  @param i is the char index in the string
  @param v is the quad
**/
quad pv at strptr(s)+i-1
pv=v
end procedure


function cv4(char*s, int i) as int
==================================
/**
  reads a binary integer inside a string and
  returns its value in an integer

  @param s is the string
  @param i is the char index in the string
**/
int a at strptr(s)+i-1
return a
end function


procedure midnuls(char*s, int i,e)
==================================
/**
  blanks out part of a string with null chars

  @param s is the string
  @param i is the start position in the string
  @param e is the end boundary position (not blanked)
**/
byte*bt 
@bt=strptr s
if not @bt
  exit procedure
endif
@bt+=i-1
while i<e
  bt=0 : @bt++ : i++
wend
end procedure


procedure midspace(char*s, int i,e)
===================================
/**
  blanks out part of a string with spaces

  @param s is the string
  @param i is the start position in the string
  @param e is the end boundary position (not blanked)
**/
byte*bt 
@bt=strptr s
if not @bt
  exit procedure
endif
@bt+=i-1
while i<e
  bt=32 : @bt++ : i++
wend
end procedure


procedure appe(string*s, int*k, string*wt)
==========================================
/**
  appends a string into a buffer

  @param s is the string buffer
  @param k is the next available position (base 0)
  @param wt is the string to be added
**/
  'base 0 index
  int le=len wt
  int ls=len s
  if ls<k+le
    s+=nuls(le+4096) 'stretch buffer
  endif
  copy strptr(s)+k,strptr(wt),le
  'mid(s,k+1)=wt
  k+=le
end procedure

============================
'LENGTH DATA LENGTH DATA ...

procedure AppendLen(string*s, int*k, string*wt)
===============================================
/**
  appends a bstring into a buffer

  @param s is the string buffer
  @param k is the next available position (base 0)
  @param wt is the string to be added

  the length and the null terminators will be
  included in the structure of wt
**/
'base 0 index
sys p=strptr(wt)
int lw at p-4 'length field
int ls=len s
int le=lw+6 'include length field  and 2 null bytes
if ls<k+le
  s+=nuls(le+4096) 'stretch buffer
endif
copy strptr(s)+k,p-4,le
k+=le
end procedure


int iqq =31        'INDIRECT QUOTE MARKER
string cqq=chr(iqq)'INDIRECT QUOTE MARKER
'
function RefString(string wr) as string
=======================================
function=qu+cqq+str(utfi+1)+" "+qu
appendlen(utfs,utfi,wr)
end function



int gi1,gi2 'insert counters
int sttl 'start of line
int sttw 'word position on line

procedure inserts(string*s, ws, int*i) ' reinsert
=================================================
  '
  'DESTRUCTIVE INSERTION
  '
  int leni=len(ws)
  ascn=ascl(ws,1)
  if i>len(s)
    i=len(s)+1
  endif
  '
  'PATCH STRING INTO USED BUFFER SPACE
  '
  if i>leni
    gi1++
    i-=leni
    'sttl-=leni
    'sttw-=leni
    mid(s,i)=ws
    exit procedure
  endif
  '
  'OR CHOP BUFFER AND APPEND STRING
  '
  gi2++
  'sttw=sttw-sttl+1
  'sttl=1
  s=ws+mid(s,i) : i=1
  '
end procedure


function midval(string*s, int i) as int
=======================================
int a at strptr(s)+i-1
return a
end function


function valchahex(string*s, int i) as int
==========================================
  int a
  a=asc(s,i)
  if a>96
    a-=32
  endif
  if a>57
    a-=7
  endif
  if a>47
    function=a-48
  endif
end function


function hexb(int v) as string
==============================
/**
  returns a 2 digit hexadecimal
  string with one leading space (3bytes)
**/
int a,b
string s=space(3)
a=v and 15
select a
case 0 to 9   : a+=48
case 10 to 15 : a+=55
end select
b=(v >> 4) and 15
select b
case 0 to 9   : b+=48
case 10 to 15 : b+=55
end select
mid(s,2)=chr(b)+chr(a)
return s
end function


function hexval(string*s, int*i) as int
=======================================
'hex value word primitive
int a,v
do
  a=asc(s,i)
  i++
  select a
  case 0  to 47  : exit do
  case 48 to 57  : v=v*16+a-48
  case 65 to 70  : v=v*16+a-55
  case 97 to 102 : v=v*16+a-87
  end select
loop
return v
end function


' CONVERT TO TEXT HEX WORD


function hexw(int v) as string
==============================
int a,b,c,d
string s=space(6)
a=v and 15
select a
case 0 to 9   : a+=48
case 10 to 15 : a+=55
end select
b=(v >> 4) and 15
select b
case 0 to 9   : b+=48
case 10 to 15 : b+=55
end select
c=(v >> 8) and 15
select c
case 0 to 9   : c+=48
case 10 to 15 : c+=55
end select
d=(v >> 12) and 15
select d
case 0 to 9   : d+=48
case 10 to 15 : d+=55
end select
mid(s,2)=chr(b)+chr(a)+" "+chr(d)+chr(c)
return s
end function


'CONVERT TO TEXT HEX DWORD

function hexl(uint v) as string
===============================
return hexw(v)+hexw(v >> 16)
end function

'macro octer(md,rm,rg)
'=====================
''bb[i]=octer(3,1,0) : i++
'(mod<<6)+(rm<<3)+rg
'end macro


procedure byter(char*s,int*i,byte b)
====================================
byte b1,b2
b1=b and 15
b2=b>>4
if b1>9
  b1+=55
else
  b1+=48
endif
if b2>9
  b2+=55
else
  b2+=48
endif
byte bb at strptr(s)+i-1
bb[0]=b2 : bb[1]=b1 : i+=2
end procedure


procedure nocrs(char*s)
=======================
/**
  replaces all cr and lf chars
  with space chars

  @param s is the string where chars are replaced
**/
int i=1
do
  i=instr(i,s,cr)
  if not i
    exit do
  endif
  mid(s,i,"  ")
  i+=2
loop
end procedure


procedure encrlf(string*s)
==========================
/**
  append crlf to a string
  when it is not present
**/
int a=asc(s,len(s))
if (a<>13)and(a<>10)
  s+=cr
endif
end procedure


procedure nofinalcr(string*s)
=============================
int a, i=len(s)
byte bb at strptr(s)-1
do
  a=bb[i]
  if a=13
    s=left(s,i-1)
    exit do
  elseif a<=32
    i--
    if i<=0
      exit do
    endif
  else '>32
    exit do
  endif
loop
end procedure


function countcr(string*s, int b, int e) as int
===============================================
int k,a,c
byte bb at strptr(s)-1
a=b
do
  if a>=e
    exit do
  endif
  k=bb[a]
  select k
  case 13 : c++
    if bb[a+1]=10
      a++
    endif
  case 10 : c++
  end select
  a++
loop
return c
end function


function tline(string*s, int*i) as string
=========================================
  '
  int b=i
  endline(s,i)
  '
  function=mid(s,b,i-b)
  '
end function


procedure lineblank(string*s, int*i)
====================================
  '
  'BLANK OUT REST OF LINE WITH SPACES
  '
  int b
  b=i
  while asc(s,i)>13
    i++
  wend
  midspace(s,b,i)
end procedure


function repeats(string*w, int n) as string
===========================================
  '
  string s
  int i,e,lw
  lw=len(w) : e=lw*n
  s=string(e,chr(0))
  i=1
  do
    if i>e
      exit do
    endif
    mid(s,i)=w : i+=lw
  loop
  '
  function=s
  '
end function


function noquotes(string wr) as string
======================================
  '
  int a,b,c
  a=asc(wr) : b=1 : c=len(wr)
  if isq(a)
    if asc(wr,c)=a
      c-- 'otherwise unclosed quote
    endif      
    b++ : c--
    return mid(wr,b,c)
  endif
  '
  return wr
  '
end function


function instrchars(string*s,*u) as int
=======================================
int lu=len(u),a,i
for i=1 to lu
  a=instr(s,mid(u,i,1))
  if a
    return a
  endif
next
end function


procedure replacecolons(string*s)
=================================
  'no checking for quotes!
  int i
  i=1
  do
    i=instr(i,s," : ")
    if i=0
      exit do
    endif
    mid(s,i)=" "+cr
    i+=3
  loop
end procedure


procedure replace(string*s,*w,*r)
=================================
  '
  int a,lw,lr
  '
  lw=len(w)
  if lw=0 
    exit procedure
  endif
  lr=len(r)
  do
    a=instr(a+1,s,w)
    if a=0
      exit do
    else
      s=left(s,a-1)+r+mid(s,a+lw)
    endif
    a=lr+a-1
  loop
end procedure



procedure replacewd(string*s,*w,*r, int mo)
===========================================
  '
  ' see himac etc
  ' mode 00  replace words, skip quoted content
  ' mode 01  also use c-macro ## word fusion
  ' mode 02  also use dot as a word boundary
  ' mode 04  replace all matching words including inside quotes
  ' mode 08  hash boundary
  ' mode 10  dot boundary
  ' 
  int a,b,bb,c,d,e,lw,lr,ls,sb,pp,pq,qf,mq
  string w1,bu
  bu=""
  '
  lw=len(w)
  if lw=0
    exit procedure
  endif
  lr=len(r)
  ls=len(s)
  sb=1
  '
  int  a1,a2
  byte *bt
  byte *bk
  sys pt=strptr(s)
  sys qt=strptr(w)
  byte bc=asc(w)
  mq=mo and 0x1c '
  mo and=3 'exclude mode 4 bit
  '
  'MAIN SEARCH LOOP  
  do
    pp=0 : pq=0 : qf=0
    if mq and 4
      a=instr(a+1,s,w) 'insensitive to quotes
    else
      a++
      @bt=pt+a-1
      '
      'INSTRNQ LOOP
      '
      do
        if bt=0
          a=0
          exit do 'end of string
        elseif bt=bc 'match first byte
          'match rest
          a1=a+1
          a2=a1
          @bt++
          @bk=qt+1
          do
            if bt=bc
              a2=a1
            endif
            if bk=0 'match complete
              jmp fwd amatch
            elseif bt<>bk
              a=a2-1 'continue search (predecr)
              @bt=pt+a-1
              exit do
            endif  
            @bk++
            @bt++
            a1++
          loop ''matching
        elseif bt=34 or bt=96
          skipquote(s,a)
          a--
          @bt=pt+a-1
        endif
        a++
        @bt++
      loop 'instrnq
    endif 'mq and 4
    '
    =======================
    amatch: 'END INSTR LOOP
    =======================
    if a=0
      a=ls+1
      exit do 'NO MORE FINDS
    endif
    '
    b=0
    '
    'CHECK LEFT BOUNDARY
    if a>1
      b=asc(s,a-1)
      if mo=2
        if b=46 'dot
          jmp fwd checkright
        endif
      endif
      if mo>=1
        if b=35
          c=0
          if a>2
            c=asc(s,a-2)
            if c=35 '#
              'LEFT PASTE OPERATOR ##w
              pp=2
              jmp fwd checkright
            endif
          endif 'a>1
          'single '#'
          if mo=1 'using #define only
            'QUOTEIFY
            pp=1
            qf=1
            jmp fwd checkright
          endif
        endif 'b=35
      endif 'mo>=1
      if mq and 0x18
        if b=35 then jmp fwd checkright
        if mq and 0x10
          if b=46 then jmp fwd checkright
        endif
      endif 
      if isw(b) 'includes '#' '.' and '_'
        continue do 'PART OF WORD SO IGNORE
      endif
    endif 'a>1
    '
    ===========
    checkright: 'CHECK RIGHT BOUNDARY
    ===========
    '
    b=asc(s,a+lw)
    if mo>=1
      if b=35 '#
        c=asc(s,a+lw+1)
        if c=35 '##
          pq=2
        endif
        jmp fwd replacement 'TREAT AS BOUNDARY
      endif
    endif
    if mo=2
      if b=46 'dot
        jmp fwd replacement 'TREAT AS BOUNDARY
      endif
    endif
    if mq and 0x18
      if b=35 then jmp fwd replacement
      if mq and 0x10
        if b=46 then jmp fwd replacement
      endif
    endif 
    if isw(b)
      continue do 'PART OF WORD SO IGNORE
    endif
    '
    ============
    replacement:
    ============
    '
    if qf 'quotify
      w1=qu+r+qu 'SUBSTITUTION
      qf=0
    else
      w1=r
    endif
    'APPEND LAST BLOCK + REPLACEMENT
    'EXCLUDING LEFT # AND ##
    appe(bu,bb,mid(s,sb,a-sb-pp)+w1)
    sb=a+lw+pq 'SKIP RIGHT ##
    a=sb-1 'ready for next search
  loop
  '
  'REMAINDER
  w1=mid(s,sb,a-sb)
  appe(bu,bb,w1)
  s=left(bu,bb)
  '
end procedure 'replacewd


procedure capture(string*s, int *m,*i,*c)
=========================================
  '
  ' s source string
  ' m beginning of capture (o)
  ' i source index (io)
  ' c beginning ascci char code
  ' v nesting depth counter
  ' k nesting flag
  ' a ascii code
  ' b another ascii code
  ' d temp
  '
  int v,k,a,b,d,e,br,rb
  string wr
  byte bb at strptr(s)-1
  skipspace(s,i)
  e=len(s)
  m=i
  c=asc(s,m)
  v=0
  do
    if i>e
      if v>0
        ers="e000 brackets not closed "
      else
        ers="e000 Unexpected end of source code"
      endif
      ert=1 : exit do 'past end of string
    endif
    '
    a=bb[i]
    '
    if (v=1)and(a=44)
      elct++ : i++ : continue do 'ELEMENT COUNT
    endif
    '
    if isq(a)
      skipquote(s,i) : continue do
    endif
    '
    'END OF SINGLE LINE
    'END OF NESTED SEQUENCE
    '
    if k=0
      if (ise(a)<>0)or(a=41)or(a=93)or(a=125)
        exit do 'EXCLUDES FINAL CHAR
      endif
      if a=nobr
        exit do
      endif
    endif
    '
    b=isb(a) '( [ {
    if b
      if br=0
        br=a : rb=b ' ) ] } 'OUTERMOST BRACKETS
      endif
    endif
    if a=br
      k=1
    endif
    '
    if k=1
      if isc(a)
        endline(s,i) : continue do 'BYPASS COMMENT
      endif
      if a=br
        '
        'INCR NESTING LEVEL
        '
        v++
      elseif a=rb
        '
        'DECR NESTING LEVEL
        '
        v--
        '
        'END OF NESTING
        '
        if v<=0
          '
          'TERMINATING BRACKET?
          '
          if c=br
            i++ : exit do ' include end bracket
          endif
          '
          'OTHERWISE REVERT TO SINGLE LINE MODE
          '
          k=0
          '
        endif
      endif
      '
      'REACHED END OF STRING
      '
    endif
    i++
  loop
end procedure



procedure capturi(string*s, int *m, *b, *i)
===========================================
  int a
  capture(s,m,i,a)
  b=i-m
  if isb(a)
    m++ : b-=2 'EXCLUDE OUTER BRACKETS
  endif
end procedure


function fixsqbr(string*s, int i) as int
========================================
  int m,b,e,k
  k=40
  byte bb at strptr(s)-1
  do
    capture(s,m,i,0)
    b=m
    e=i-1
    bb[b]=k '(' or space
    k=40
    skiplspace(s,i)
    if ascn<>91
      bb[e]=41 ')'
      exit do
    endif
    bb[e]=44 ','
    k=32 'space
  loop
  ascn=lbr
  function=i
end function


function idword(string s,*wr) as int
====================================
  int e,f,i
  byte bb at strptr(s)-1
  e=len(wr)
  if e=0
    return 0
  endif
  i=1
  do
    i=instr(i,s,wr)
    if i=0
      return 0 'NOT FOUND  
    elseif i=1
      'MATCHING BOUNDARY LEFT
    elseif bb[i-1]<33
      'MATCHING BOUNDARY LEFT
    else
      i+=e 'NEXT INSTR
      continue do
    endif
    'MATCHING BOUNDARY RIGHT:
    i+=e
    select bb[i]
    case 0 to 32 : exit do 'white space
    case 40      : exit do '(
   'case 91      : exit do '[
   'case 123     : exit do '{
    end select
  loop 'NEXT INSTR
  return i+1
end function


function dic(string*s,*wr) as int
=================================
  '
  'LOOKUP KEYWORD AND RETURN NUMBER (ASSUMED HEXADECIMAL)
  '
  int a,e
  e=len(wr)
  a=idword(s,wr)
  if a
    return hexval(s,a)
  endif
  '
end function


function revdic(string*s, int v) as string
==========================================
  '
  'REVERSE DIC
  '
  'hexadecimal is assumed to be trimmed of leading zeros, and capitalised
  string w1
  int a,b
  double dv=v
  byte bb at strptr(s)-1
  w1=hex(dv)
  b=instr(s," "+w1+",")
  if b
    a=b
    do
      a--
      if a<=1
        exit do
      endif
      if bb[a]<=32
        a++ : exit do
      endif
    loop
    function=mid(s,a,b-a)
  endif
end function



function dicsn(string*s, int a ) as string
==========================================
  '
  'LOOKUP LIST OF DECIMAL NUMBERS AND RETURN PHRASE
  '
  int v,k
  v=instr(s," "+str(a)+" ")
  if v 
    v=instr(v+1,s," ") : skiplspace(s,v)
    k=instr(v,s,",") 'PHRASE DELIMITED BY COMMA
    if k
      function=mid(s,v,k-v)
    endif
  endif
end function





=============================================
=============================================

int noco 'flag to include commas in capts()
int prl  'operator precedence level
int ert  'compiler error number

string ers="" 'compiler error description

string endex=" as then else elseif end to step when while until "


procedure skipquotec(char*s, int*i,*c)
======================================
/**
  skip over a quoted section of a 
  string but count the line endings
  (crlf)
**/
  int b
  byte*bt
  @bt=strptr(s)
  if not @bt
    exit procedure
  endif
  @bt+=i-1
  'skip quoted expression and count cr
  b=bt
  do
    @bt++
    i++
    select bt
      case 0  : exit do
      case b  : exit do
      case 13 : c++
    end select
  loop
  i++
end procedure


procedure nextinstruct(string*s, int*i)
=======================================
  '
  'SKIP COMMENTS AND BLANK LINES
  'ITR NOTE LAST LINE NUMBER
  '
  int a,b,c,d
  do
    skipspace(s,i)
    b=asc(s,i+1)
    select ascn
    case 0 : exit do
    case 95
      if b<33
        i++ : continue do 'LINE CONTINUATION
      endif
    case 13,10 : continue do
    case ct1,ct2 : endline(s,i) : continue do
    case 45,61
    '---' ===='
      if (b=ascn)and(asc(s,i+2)=ascn)
        endline(s,i) : c=i
        continue do
      endif
    end select
    exit do 'higher ascii is ignored
  loop
end procedure


'CAPTURE BRACKETED SOURCE CODE OR GENERAL TEXT

procedure captb(string*s,int*i)
===============================
int a,v,sb,eb
byte bb at strptr(s)-1
sb=ascn
eb=isb(sb)
do
  a=bb[i]
  if a=0
    exit do
  endif
  if a=sb
    v++
  elseif a=eb
    v--
    if v<=0
      i++ : exit do
    endif
  endif
  i++ 
loop
end procedure


function xword(string*s, int*i) as string
=========================================
  byte bb at strptr(s)-1
  skipspace(s,i)
  swd=i
  if ascn=91
    i=instr(i+1,s,"]")
    if i=0
      i=len(s)
    endif
    i++
  elseif isq(ascn)
    i=instr(i+1,s,chr(ascn))
    'if i=0
    '   i=len(s)
    'endif
    i++
  else
    select bb[i]
    case 33 to 255 : nextspace(s,i)
    end select
  endif
  lenw=i-swd
  if lenw>0
    return mid(s,swd,lenw)
  endif
end function


procedure FixCrLF(string*s)
===========================
string d
int b,i,l,e,le
d=space(len(s)*2+2)
i=1
e=1
le=len(s)
while i<=le
  b=i
  endline(s,i)
  l=i-b
  select ascn
  case 0  :
    'REPLACE EMBEDDED NULL CHARS 
    if i<=le
      mid(s,i)=" " : i=b
      continue while
    endif
  case 10 : i++
  case 13 : i++
    if asc(s,i)=10
      i++
    endif
  end select
  mid(d,e)=mid(s,b,l)+cr : e=e+l+2
wend
s=left(d,e-1) 'ALWAYS ENDS WITH CR (EXCEPT FOR EMPTY S)
end procedure


procedure striplineno(string*wr)
================================
  int a=1,b
  string ke="'_" 'lnm
  '
  'STRIP LINE NUMBERS FROM WITHIN BLOCKS, STRINGS ETC
  '
  do
    a=instr(a,wr,ke)
    if a
      b=instr(a,wr,cr)
      if b=0
        b=len(wr)
      endif
      wr=left(wr,a-1)+mid(wr,b+2)
    else
      exit do
    endif
  loop
end procedure



'   #######################
'  #########################
'  ###                   ###
'  ###                   ###
'  ###                   ###
'  ###                   ###
'  ###                   ### 
'  #########################
'   #######################
'
int gwc 'bword usage count
'
function bword(string*s, int*i) as string
=========================================
  string wr
  int a,b,c,d,ls
  '
  rbword:
  =======
  '
  dtf=0
  qot=0
  nmb=0
  ascw=0
  ls=len(s)
  if ls=0
    swd=i : lenw=0 : ascn=0
    exit function
  endif
  skipspace(s,i)
  swd=i
  if i>ls
    goto exitw
  endif
  byte bb at strptr(s)-1
  ascw=bb[i]
  i++
  a=isw(ascw)
  if a>=0 'NOT A WORD, COULD BE DOT
    select ascw
    case 46 '.'
      dtf=1
      a=bb[i]
      if (a>=48)and(a<=57) 'NUMBERS
        nmb=3 : i++
        goto morechars
      else
        i--
        goto morechars
      endif
    case 45 '-'
      a=bb[i]
      if a=62 '->' cpointer
        i--
        goto morechars
      elseif (a>=48)and(a<=57) 'NUMBERS FOLLOW
        nmb=5
        'goto morechars
      elseif a=46 '-.'
        a=bb[i+1]
        if (a>=48)and(a<=57) '.NUMBERS FOLLOW
          nmb=7
          'goto morechars
        endif
      endif
    case 38 '&
      a=bb[i]
      b=isa(a)
      if b
        if b=-3
          a+=32 'convert capitals to lower case
        endif
        select a
        case 0x68 : b=16 : c=0x78 'hexadecimal setl
        case 0x6f : b=8  : c=0x6f 'octal set
        case 0x62 : b=2  : c=0x62 'binary set
        case else : goto exitw
        end select
        do 'FIND BOUNDARY
          i++ : d=ascl(s,i)
          a=instr("0123456789abcdef",chr(d))
          if (a=0)or(a>b)
            if (i>swd+2)and((d<48)or(isx(d)<>0))
              mid(s,swd)="0"+chr(c) : ascw=48
              nmb=9
            else
              i=swd+1 '&' address symbol
            endif
            goto exitw
          endif
        loop
      else
        goto exitw
      endif
    case iq1,iq2 : a=-1
    end select
    '
    if a=-1 'QUOTED TEXT
      a=instr(i,s,chr(ascw))
      if a
        i=a : qot=1
      else
        ers="Unclosed quote in text" : ert=502
      endif
      i++
    endif
    goto exitw 'NOT ALPHANUMERIC
  elseif a=-1
    nmb=1 'IS A NUMBER
  endif
  '
  morechars:
  ==========
  '
  do
    a=bb[i]
    select a
    case 46 '.'
      a=bb[i+1]
      if dtf=0
        dtf=i-swd+1
      endif
      if (a>=48)and(a<=57)
        if dtf=1
          nmb=1
        endif
      endif
      i++ : continue do
    case 45 '-'
      if bb[i+1]=62 '->' ARROW cpointer
        if dtf=0
          dtf=i-swd+1
        endif
        i+=2 : continue do
      endif
      if nmb=9 'E notation E- ...
        i++
        continue do 
      endif
    case 43 '+'
      if nmb=9 'E notation E+ ...
        i++
        continue do
      endif
    case 58
      if bb[i+1]=58 'skip embedded "::"
        i+=2 : continue do
      else
        exit do
      endif
    case 95
      if bb[i+1]=34 'SUPPORT QUOTED _"+"
        a=instr(i+2,s,qu)
        if a
          i=a+1
        else
          ers="Unclosed quote in symbol name" : ert=502
        endif
        goto exitw
      endif
    case 0 to 32
      exit do
    end select
    '
    if isw(a)
      if nmb
        if a=&h65
          nmb=9 'scientific E notation follows
        endif
      endif
      i++
    else
      select a
      case 34
      case 33 to 38,63 '!#$%&? endings
        i++
        continue do
      end select
      exit do
    endif
    '
  loop
  '
  exitw:
  ======
  '
  lenw=i-swd
  skiplspace(s,i)
  if lenw>0
    if not ilc
      if ascw=95
        if lenw=1
          nextinstruct(s,i)
          goto rbword 'line contination
        endif
      endif
      '
      rnextn:
      '
      if ascn=95
        if asc(s,i+1)<33
          i++
          nextinstruct(s,i)
          goto rnextn
        endif
      endif
    endif 'ilc       
    returnvar=mid(s,swd,lenw)
    if not icas
      if qot=0
        clcase(returnvar)
        ascw=asc(returnvar)
      endif
    endif 'icas
  endif 'lenw
  icas=0
  ilc=0
end function

def gword bword
def tword bword


'excise
'
procedure nocomments(string*s)
==============================
  '
  'strip out comments 'but not and //.. and / *..* /
  '
  int f,i
  string wr
  i=1
  do
    icas=1 : wr=bword(s,i)
    if ascw=0
      exit do
    elseif isc(ascw)
      f=1 : endline(s,i)
    endif
    if f
      s=left(s,swd-1)+mid(s,i)
      i=swd-1
      f=0
    endif
  loop
end procedure


function quotex(string*s, int*i) as string
==========================================
  int b,c,m
  string wr
  nextinstruct(s,i)
  b=i
  '
  'SUPPORT BRACKET NESTING
  if isb(ascn)
    m=i+1 'omit left bracket
    captb(s,i)
    c=i-1 'LOCATE RIGHT BRACKET
    lenw=1
    goto qfillin
  endif
  '
  'OTHERWISE MARKER WR
  nextspace(s,i)
  lenw=i-b
  wr=mid(s,b,lenw) 'MARKER WORD
  '
  m=i 'START OF STRING
  c=instr(m,s,wr) 'CASE SENSITIVE
  if c 
    i=c+lenw 'SUPERQUOTE MARKER END BOUNDARY
  endif
  '
  qfillin:
  ========
  '
  if c
    'SUPPORTS NESTABLE QUOTE
    wr=mid(s,m,c-m)  'content
    function=wr
    wr=RefString(wr) 'reference
    s=left(s,b-1)+wr+mid(s,i) 'replace
    ascw=34
    i=b+len(wr)
'print mid(s,i,100)
    skiplspace(s,i)
  endif
end function



function wordahead(string*s, int i) as string
=============================================
  '
  int a,b,c
  a=swd : b=ascw : c=ascn
  function=tword(s,i)
  swd=a : ascw=b : ascn=c
end function


procedure endcatline(string*s, int *i, *c)
==========================================
  int b,d,de,e,f
  string wr
  byte bb at strptr(s)-1
  skiplspace(s,i)
  if ascn=35
    if yword(s,i)="#define"
      de=1 'treat C macro with possible '\' line continuation marker
    endif
  endif
  do
    ascn=bb[i]
    b=i
    select ascn
    case  0      : 'TOLERATE NULL CHAR
      if i>len(s)
        exit do
      endif
    case 13      : 
      if d=2
        d=1 : c++ : i+=2
      else
        exit do
      endif
    case 1 to 32 :
      if d<>2
        d=1
      endif
    case ct1,ct2
      endline(s,i)
      continue do
    case sr1,sr2     :
      '
    case 44
      d=2
    case 47      : 
      e=bb[i+1]
      f=0
      if e=47
        endline(s,i) : f=i
      elseif e=42
        f=instr(i+2,s,"*/")
        if f
          i=f+2
        endif
      endif
      if f
        c+=countcr(s,b,i)
        midspace(s,b,i)
        continue do
      endif
    case 92      : '\ macro line continuation
      if de
        d=2
      else
        d=0
      endif
    case 95      : ' _ LINE CONTINUATION
      if d>=1
        d=2
      else
        d=0
      endif
    case iq1,iq2
      skipquotec(s,i,c) : d=1 : continue do
    case 0x71
      if asc(s,i-1)<=64
        if yword(s,i)="quote"
          mid (s,swd)="     " 'blank out
          wr=quotex(s,i)
          @bb=strptr(s)-1
          c+=countcr(wr,1,len(wr)+1)+1
          continue do
        endif
      endif
      i=b : d=0
    case 33 to 255
      d=0
    end select
    i++
  loop
  ascn=bb[i]
  nwd=i
end procedure



procedure nextinstructla(string*s, int*i)
=========================================
'SKIP HIGHER ASCII CHARS
do
  nextinstruct(s,i)
  if ascn<127
    if ascn=35
      if wordahead(s,i)="#show"
        i+=6 :continue do 'SKIP OVER #show
      endif
    endif
    exit do
  endif
  i++
loop
end procedure





function splitsi(string*s,*r) as string
=======================================
  int d
  d=instr(s,"@")
  r=""
  if d<3
    '#@ #
  elseif d
    function=left(s,d-1)
    r=mid(s,d+1)
  else
    function=s
  endif
end function


function splitsig(string*s) as string
=====================================
  int d
  d=instr(s,"@")
  if d<3
    '#@ @
  elseif d
    return left(s,d-1)
  else
    return s
  endif
end function







function encodenum(string*s, int*i) as string
=============================================
string wr,w1
int a
wr=lcase(mid(s,swd,i-swd))
w1=left(wr,2)
if (w1="&h")or(w1="0x")
  return " hq"+mid(wr,3)
else
  return " nq"+wr
endif
end function



'GET VALUE OF WORD (INCLUDING FLOATING POINT AND E NOTATION)





function isendofexpr(string*s, int*i) as int
============================================
string w1
skiplspace(s,i)
if iss(ascn)
  if asc(s,i+1)=61
    return 0 ':='
  endif
  return -1 ' COMMENT, SEPARATOR END-OF-LINE ETC
elseif ascn=123 '{'
  return -1
elseif ascn=125 '}'
  return -1
elseif (ascn=0x65)or(ascn>=0x73) 'or(ascn=0x61)
  w1=wordahead(s,i)
  if idword(endex,w1)
    return -1 'DO NOT SWALLOW WORD
  endif
endif
end function


function wordfrag(string*s, int*i) as string
============================================
  '
  ' a boundary character
  ' r last char of fragment
  '
  int b,j
  '
  'SKIP SPACE AND MARKERS
  '
  do
    b=asc(s,i)
    if b=0
      exit do
    endif
    if (b>35)and(b<>64)
      exit do
    endif
    i++
  loop
  j=i
  '
  'LOCATE NEXT SPACE OR MARKER
  '
  do
    b=asc(s,i)
    if (b<36)or(b=64)
      exit do
    endif
    i++
  loop
  function=mid(s,j,i-j)
end function


int nocapt
'
procedure capturend(string*s, int *m, *b, *i, string*we)
========================================================
  int a,k
  string wr
  skipspace(s,i)
  m=i
  do
    ilc=1 : wr=gword(s,i)
    if wr=""
      b=0 : i=m : exit do ' no terminator found so null capture
    elseif isb(ascw)
      if nocapt=0
        i=swd : capture(s,0,i,0) ' ( [ { nestings bypass
      endif
    elseif isc(ascw)
      endline(s,i)
    elseif wr=we
      'capth
      if isa(ascn)
        if idword(" and or xor ",we)=0 'eg: function or=x
          a++ 'nesting
        endif
      endif
    elseif wr="end"
      k=i
      b=swd-m
      ilc=1
      if gword(s,k)=we
        i=k
        if a<=0
          exit do
        endif
        a-- 'un-nesting
      else
        skiplspace(s,i)
      endif
    endif
  loop
end procedure


procedure captureb(string*s, int*i,*m,*b, string*wr)
====================================================
  int a,c
  string w1
  skiplspace(s,i)
  if ascn=44
    i++ : nextinstruct(s,i)
  endif
  '
  if ascn=91
    '[..] def x [ebx+4096] 'not treated a block marker
    m=i : endline(s,i) : b=i-m
    exit procedure
  endif
  '
  'end of line
  if ise(ascn)
    nextinstruct(s,i)
    if (ascn<>lbr)and(ascn<>123)
      capturend(s,m,b,i,wr)
      exit procedure
    endif
  endif
  '
  '
  'OTHERWISE LOOK FOR END BRACKET
  '
  capturi(s,m,b,i)
  '
  'BUT ALSO LOOKAHEAD TO SEE IF `END X` EXISTS
  '
  a=i
  nextinstruct(s,a)
  if wordahead(s,a)="end"
    a=nwd
    if wordahead(s,a)=wr
      '
      'INCLUDE OUTER BRACKETS IN BLOCK
      '
      m--
      b=i-m+1
      i=nwd
    endif
  endif
  '
end procedure


function captureblock(string*s, int*i, string*wr) as string
===========================================================
  int m,b
  captureb(s,i,m,b,wr)
  if b
    function=mid(s,m,b)
  endif
end function


procedure capturedefs(string*s, int*i, string*wr)
=================================================
  string w1
  int m,b
  '
  'SKIP BLOCK
  endline(s,i)
  captureb(s,i,m,b,wr)
  skiplspace(s,i)
  '
  do
    if ascn=44
      i++ : nextinstruct(s,i)
    endif
    if isxn
      endline(s,i) : i+=2 
      exit do
    endif
    w1=tword(s,i) '
  loop
end procedure


procedure endcontline(string*s, int*i)
======================================
  '
  'SKIP TO THE NEXT LINE END THAT HAS NO CONTINUATION MARKERS
  '
  string wr
  int m,b
  skiplspace(s,i) : if iss(ascn)
    exit procedure 'END OF STATEMENT
  endif
  do
    wr=tword(s,i)
    if isb(ascw)
      i=swd : capturi(s,m,b,i) : skiplspace(s,i)
    endif
    if iss(ascn)
      if lenw=1
        if (ascw<>44)and(ascw<>95)and(ascw<>92)
          exit do 'CONTINUATION SYMBOLS , _ \
        endif
      else
        exit do
      endif
      endline(s,i)
    endif
  loop
end procedure      '


function booli(int n) as int
============================
  if n
    return 1
  endif
end function


function yes(string*s) as int
=============================
  return booli(idword(" 1 yes true on enable enabled active start ",s))
end function


function no(string*s) as int
============================
  return booli(idword(" 0 no false off disable disabled inactive idle stop ",s))
end function


function isnt(string*s, int*i) as int
=====================================
  string wr
  int a,b,v
  do
    if isxn
      exit do
    endif
    wr=wordahead(s,i)
    b=asc(s,nwd)
    a=isx(b)
    if a=0
      if idword(" not isnt ",wr)
        i=nwd : v=1-v : continue do
      elseif idword(" is be mode switched turned ",wr)
        i=nwd : continue do
      endif
    endif
    exit do
  loop
  skiplspace(s,i)
  function=v
end function


procedure yesno(string*s, int*i,*r)
===================================
  '
  'R DEFAULTS TO 1 WHEN THE AFFIRMING EXPRESSION IS ABSENT
  '
  string wr
  int t,f,v
  if nisxn
    v=isnt(s,i)
    if nisxn
      wr=wordahead(s,i)
      t=yes(wr)
      f=no(wr)
      if t
        r=1 xor v : i=nwd
      elseif f
        r=0 xor v : i=nwd
      endif
      'OTHERWISE R IS UNALTERED
    endif
    skiplspace(s,i)
  else
    r=1
  endif
end procedure


function findlinek(int*b, string*s,*k, int p) as string
=======================================================
int a,c
a=instrevn(b,s,k)
if a
  c=instr(a,s,cr)
  if c
    a+=p
    return mid(s,a,c-a+2) 'include cr
  endif
endif
end function


procedure removemarked(string*s,*u, int m)
==========================================
int tb,bb,eb,en,el,le,ls
ls=len(s)
string t=nuls ls 'BUFFER
bb=1
tb=1
do
  eb=instr(bb,s,u)
  if eb=0
    eb=ls+1 
    en=1 'EXIT FLAG
  endif
  if m
    el=instr(eb,s,cr)+2 'OMIT MARKER & LINE
  else 'm=0
    el=eb+1 'OMIT MARKER ONLY
  endif
  le=eb-bb
  mid(t,tb)=mid(s,bb,le)
  tb+=le
  if en
    exit do
  endif
  bb=el
loop
s=left(t,tb-1)
end procedure

int gpc 'global procedure counter
int glc 'global line counter

procedure LineMark(string*s)
============================
  int a,b,c,e,g,i,J,k,m,bq
  string d,w,u
  FixCrLf(s)
  k=len(s)*2
  d=space(k)
  u="'_" 'lnm
  bq=0x8000
  '
  i=1
  e=i
  do
    c++ 'LINE COUNTER
    b=i
    skiplspace(s,i)
    select ascn
    case 0
      exit do 'END OF STRING
    case 13
      'blank lines
      i+=2 'assume crlf
      m=i-b 'LENGTH OF LINE
      if m+e>=k
        d+=space(bq) : k+=bq 'STRETCH BUFFER
      endif
      mid(d,e)=mid(s,b,m)
      e=e+m
      continue do 'no line tag
    end select
    w=str(c) 'LINE NUMBER
    g=len(w)+4
    '
    endcatline(s,i,c) 'SUPPORTING MULTI LINE STATEMENTS
    '
    'support line endings: cr lf crlf
    if ascn<>0
      i++
      ascn=asc(s,i)
    endif
    if ascn=10
      i++
    endif
    m=i-b 'LENGTH OF LINE
    if m+g+e>=k
      d+=space(bq) : k+=bq 'STRETCH BUFFER
    endif
    '
    mid(d,e)=u+w+cr+mid(s,b,m)
    glc++
    e+=g+m
  loop
  s=left(d,e-1) 'TRIM OFF REMAINING BUFFER SPACE, ALWAYS APPEND CR
end procedure



' divi     division operator flag (detect in precedence)
int divi
' nprec    no precedence flag
int nprec

' cnd     conditional flag
int cnd

procedure wordval(string*s, int*st, *i)
=======================================
  '
  string wd
  int sg
  'int a,b
  dv=0
  nan=0
  skipspace(s,st)
  i=st
  '
  if ascn=45 'CHECK FOR NEGATIVE SIGN
    sg=1 : i++
  endif
  '
  wd=tword(s,i)
  '
  if nmb=0
    dv=0 : nan=1
    exit procedure
  endif
  '
  call ascii_to_float strptr wd
  fstp qword dv
  swd=st
  if sg
    dv=-dv
  endif
end procedure


function wdval(string*s, int *st, *i) as extended
=================================================
  '
  string wd
  int sg
  nan=0
  skipspace(s,st)
  i=st
  '
  if ascn=45 'CHECK FOR NEGATIVE SIGN
    sg=1 : i++
  endif
  '
  wd=tword(s,i)
  swd=st
  '
  if nmb=0
    nan=1
    exit function
  endif
  '
  call ascii_to_float strptr wd
  if sg
    fchs 'change sign
  endif
  return 'value returned on fpu stack
end function





procedure wordeval(string*s, int*st,*i)
=======================================
  '
  ' COMBINE SUMS OF POSITIVE & NEGATIVE LITERAL NUMBERS
  '
  int b,c,d,e
  string w1
  double vv
  b=st
  '
  e=i
  i=st
  do
    wordval(s,b,i)
    if d
      dv+=vv
    endif
    if (ascn=43)or(ascn=45)
      c=ascn
      w1=wordahead(s,i)
      int ta=asc(s,nwd)
      if isn(ta)
        b=nwd : vv=dv
        if c=45
          b=i 'include neg sign
        endif
        d=1 : continue do
      endif
    endif
    exit do
  loop
  ascw=asc(s,st)
  if i<e
    i=e
  endif
end procedure


