'RECO.INC


  'GLOBAL DATA TYPES
  '=================

  type records  'used by drc
    '
    int   i  ' 8   hash code
    int   j  ' 9   hash storage back-link
    int   m0 ' m0  base offset in spc memory pool
    int   c  ' 2   cpu reg offset [rbx+...]
    int   a  ' 0   metatype /type
    int   b  ' 1   type length
    int   f  ' 5   resolved type
    int   l  ' 11  namespace index
    '
    short m1 ' m1  field offset m0+m1
    short m2 ' m2  field offset m0+m2
    short m3 ' m3  field offset m0+m3
    short d  ' 3   indirection
    short e  ' 4   typedef metatype
    short g  ' 6   source file index
    short h  ' 7   flags 1=cnstr 2=array 4=array ptr 8 mapping
    short k  ' 10  nesting depth
  end type
  '
  

  type xstack
    int a    ' operator
    int b    ' accumulator type
    int c    ' entity code
    int d    ' comparator
    int e    ' compare type
    int f    ' indirection level
    int g    ' temp var record
    int h    ' last object
    int i    ' not flag
    int j    ' var or element size
    int k    ' operand type
  end type

  type nester
    int me     ' data record boundary
    int spj    ' string pool boundary
    int ixb    ' array indexbase
  end type


  'UPPER CHAR SYMBOLS
  ===================
  '255  FF  unused
  '254  FE  unused
  '253  FD  she
  '252  FC  unused
  '251  FB  unused
  '249  F9  utfb
  '248  F8  utfc

  '31   1F  iqq
  '30   1E  iqq-1


  'GENERAL CONSTANTS
  '=================

  int    typh=512       'HIGHER TYPES BASE
  int    hasa=124       ' | HIGH ASSEMBLER INSTRUCTION CODE
  int    she=253        '#show DELIMITER
  '
  string chz=chr(0)     'NULL CHARACTER
  string dfd=chr(7)     'DATA FIELD DELIMITER
  string rmk=chr(8)     'SUB-RECORD MARKER
  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
  string sp=cr+"("+cr   'START OF BLOCK
  string ep=cr+")"+cr   'END OF BLOCK
  string stp=" : "      'NORMAL STATEMENT SEPARATOR
  string c127=chr(127)  'GENERAL ENCODING CHARACTER


  'GENERAL MACROS
  '==============

  def rtl   "|go 0 "+memreg(qebx,%1)+cr

  def deref "mov "+%1+",["+%1+"]"+cr

  def free freememory

  int i
  'def strini
  '  dim string %1(%2)
  '  for i=0 to <%2
  '     %1(i)=""
  '  next
  'end def 

  def dyn
    dim %1 %2 at getmemory( (%3)*sizeof %2 )
  end def

  def stretch
    scope
    int _e_=(%2)*sizeof(%1)
    int _l_=*(@%1-4) 'len
    sys _p_=getmemory _e_
    if _e_<_l_ then _l_=_e_
    copy _p_,@%1,_l_
    freememory @%1
    @%1=_p_
    end scope
  end def


  'def strinr
  '  dyn string %1(%2)
  '  for i=0 to <%2
  '     %1(i)=""
  '  next
  'end def

  'META TYPES
  '==========

  '========
  'CAPACITY
  '========

  '
  int maxit=0x4000 'initial size of entity array
  int szrec=sizeof records 'elements in drc()

  def show "%1"


  'STRING ARRAYS
  ==============
  '
  string epgs[99] 'global expressions for #ENDING
  int epgi[99]    'global epilog index for #ENDING

  'for reco.inc
  'static string wa1,wa2

  'for pars.inc
  'static string rco

  'for expr.inc
  string wc[8]

  '======
  'ARRAYS
  '======

  'COMPILER BUFFERS
  '
  ========================================================
  '
  sys     pvm[255]  'POINTERS TO VIRTUALALLOC MEMORY
  sys     pvd[255]  'POINTERS TO VIRTUALALLOC MEMORY BSSDATA
  sys     lbuf[255] 'LENGTH OF SELECTED PVM
  string  dbuf      'BUFFER FOR COMPILE CODE
  int     ibuf      'INDEX FOR SELECTED BUFFER
  sys     pbuf      'POINTER TO SELECTED BUFFER
  '
  '
  'ENTITY STORAGE
  '
  ========================================================
  % opdw 10
  int ope
  dim int opd(999*opdw) ' Assembly code numeric data
  string  opn[999]      ' Assembly code name
  string  ops[999]      ' Assembly code string data
  '-------------------------------------------------------
  'maxit
  'dim records drc(0x8000)  ' direct record access
  dyn records drc(maxit)  ' direct record access
  dim word    mrcb(0xffff)' hash base links 
  ========================================================
  '
  'RECORD SPACE BUFFER
  string  sps 'buffer
  sys     spp 'base pointer
  int     spj 'string pool in use
  int spm     'string pool max used
  int     spl 'length
  '
  '
  'GENERAL

  ========================================================
  dim xstack nstk(100)      ' general nesting stack
  xstack nstu          ' general nesting stack
  int    jn            ' string join flag
  int    sta[99]       ' precedence stack
  string nes[99]       ' nested names
  string nxs[99]       ' nested next step
  string cln[99]       ' conditional line
  --------------------------------------------------------
  string por[99]       ' param original word (ow)
  string paw[99]       ' param wg word
  string pas[99]       ' parameter expression
  int    paj[99]       ' param type of callee
  int    pao[99]       ' param last operator
  int    pat[99]       ' param type
  int    pet[99]       ' param effective type
  int    pst[99]       ' param stack size allocated
  string pav[99]       ' param conversion code
  string pax[99]       ' param indirect addr code
  string  pex[99]       ' param expresion source code
  --------------------------------------------------------
  int    libu[511]     ' library use flag
  int    libo[511]     ' library offset list
  string libs[511]     ' library name list
  string libl[511]     ' library used proc list
  --------------------------------------------------------
  string wva[15]       ' var / dim statements
  nester scop[99]      ' nesting scope index
  ========================================================
  string wp[63]        ' macro params
  ========================================================
  int    sti[53]       ' index to file name log ssn
  string ssf[63]       ' include file path name
  string sst[63]       ' include (preserve parent text)
  string ssn[999]      ' include file name log
  int    ssh[999]      ' include content hash log
  string rgp[15]       ' register param macros (for 64 bit fast calls)
  string regn[15]      ' register param names (for 64 bit fast calls)
  int    typl[15]      ' local param type
  int    typq[15]      ' local param size (when typl>=typh
  ========================================================

  'SOURCE SECTION BUFFERS
  ' definbuf buffer for embedded #defines
  ' defbuf buffer for extracting nested items
  ' undefbuf buffer for undef names
  ' defpro   buffer for inner procedures
  ' undefbuf buffer for undef inner proc names
  '
  string definbuf,defbuf, undefbuf
  string defpro, undefpro
  '


  'PROCEDURE STATE
  'funi   in function flag
  'atf    external flag
  'lcl    local variables used flag
  'lcls   local strings used flag
  'blcl   patch position for stack (ebp) instruction
  'plcl   patch position for stack allocation
  'mlcl   stack space requirement
  'reto   function param boundary
  'retb   function param base
  'retr   function return param base (returnvar*)
  'ccp    calling convention
  'mqf    function record index
  'typp   return type code
  'noin   no initialise var flag
  'funn   function type 11 12 13
  'dts    temp strings used flag
  'dcs    concatenation buffer used
  'clsi   current class record index
  'funl   patch position for offset of proclist record (link)
  'flbl   prevent deletion during compaction flag
  'dct    macro insertion counter
  'funm   original or alias name (no case conversion)
  'fnam   function name
  'fsig   function signature
  '
  int    funi,atf,lcl,lcls,blcl,plcl,mlcl
  int    reto,retb,retr,ccp,mqf
  int    typp,noin,funn,dts,dcs,clsi
  int    funl,flbl,dct
  string funm,fnam,fsig
  ========================================================
  'TYPE/UNION FLAGS
  int    unif[7],unio[7],unim[7]
  string unin[7]
  ========================================================
  sys    sysfuns[1023]    ' runtime fun table
  string mdl_path=""      '
  ========================================================
  string expwn[999]    ' export labels
  string expal[999]    ' export dll symbols
  int    expi[999]     ' export index for sorting
  ========================================================
  int    dima[16],dimi ' array const offset
  ========================================================
  string wtn[32]       ' temp expressions
  int    tmpi          ' serialiser for temp vars
  ========================================================
  int    posbin[63]    ' positions in binary code (base 0)    
  ========================================================


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

  int arcm
  int arcn


  sys pvarcall,ppathcall


  function GetvarPtr(string*VarName) as sys
  =========================================
  sys p=strptr(VarName)+1
  if pvarcall

    return call pvarcall p
  endif
  return 0
  end function



  function InclPath(string*VarName) as string
  ===========================================
  bstring path
  sys p=strptr(VarName)
  if pPathCall
    ?path=call pPathCall(p)
    return path
  endif
  end function


procedure init4(sys p, int le, c)
=================================
int q at (p)
do
  if le<=0
    exit do
  endif
  q=c
  @q+=4
  le--
loop
end procedure


procedure InitDefTables()
'========================
'  
spj=8                 'pool base
'                     '
aoff=0x2000           'ALLOW 8192 AREA FOR RTL TABLES
aoffs=aoff            'STATIC / GLOBAL BASE
'                     '
init4 @mrcb,0x8000,0  'clear hash table base
init4 @drc,(me*szrec)>>2,0 'clear previous records
me=1                  'reset records boundary
mp=0                  'clear locator index
end procedure



procedure appendt(string wt)
============================
  static as int le,lt
  le=len(wt)
  lt=len t
  if lt<j+le
    if j>1e8
      ert=102
      exit procedure
    endif
    t+=space(le+0x10000) 'min 64k increment
  endif
  mid(t,j)=wt : j+=le
end procedure


procedure apdat(string wr)
==========================
  static int ld
  int le=len(wr)
  int lx=dati+le
  if ld<lx
    if dati>1e8
      ert=102
      exit procedure
    endif
    dats+=nuls 0x10000 '64k increment
    ld=len dats
  endif
  mid(dats,dati+1)=wr : dati=lx
end procedure


procedure tbuf(string*wr, int f)
================================
static int wi1,wl1,le1
static int wi2,wl2,le2
static string wa1,wa2
select f
case 0
  le1=len(wr)
  if le1+wi1>wl1
    wa1+=space(16000+le1) 'stretch buffer
    wl1+=16000+le1
  endif
  mid(wa1,wi1+1)=wr
  wi1+=le1
case 1
  le2=len(wr)
  if le2+wi2>wl2
    wa2+=space(16000+le2) 'stretch buffer
    wl2+=16000+le2
  endif
  mid(wa2,wi2+1)=wr
  wi2+=le2
case -1
  wr=left(wa1,wi1)
  wa1=""
  wl1=0
  wi1=0
case -2
  wr=left(wa2,wi2)
  wa2=""
  wl2=0
  wi2=0
end select
end procedure



'========
'DATABASE
'========


function NewTmpName() as string
'==============================
tmpi++
return c127+str(tmpi)
end function

macro hashmac(pt,hc)
'===================
 mov rcx,pt
 mov edx,0x35db53bd
 (
  cmp rcx,0
  jz exit
  (
   mov al,[rcx]
   cmp al,0
   jz exit
   rol edx,1
   xor dl,al
   inc rcx
   repeat
  )
 )
 mov hc,edx
end macro


macro hashmacl(pt,le,hc)
'=======================
 mov rcx,pt
 mov esi,le
 mov edx,0x35db53bd
 (
  cmp rcx,0
  jz exit
  (
   mov al,[rcx]
   cmp esi,0
   jz exit
   rol edx,1
   xor dl,al
   inc rcx
   dec esi
   repeat
  )
 )
 mov hc,edx
end macro


function hashid(string*s) as int
================================
  int le=len(s)
  sys p=strptr(s)
  xor eax,eax
  mov edi,le
  mov rsi,p
  (
    dec edi
    jl exit
    rol eax,7
    xor al,[rsi]
    inc rsi 
    repeat
  )
  mov [function],eax
end function



'=====================
'STRING POOL FUNCTIONS
'=====================


procedure mrcin(int m)
======================
init4 @drc(m).m0,szrec>>2,0
end procedure


% lle=2 'size of length field
word* qle

procedure mrcsi(string*w, int m,n)
==================================
  '
  'STORE STRING IN BUFFER
  'INDEX IT IN MACO (WITH OFFSET OF N)
  '
  int a,b,le
  le=len(w)
  if le=0
    exit procedure
  endif
  b=spj+le+lle 'length field
  if b>spl
    sps=sps+nuls spl 'DOUBLE SIZE
    'sps=sps+nuls 0x200000 'ADD 2 MEG
    spl=len(sps) '
    spp=strptr(sps)
  endif
  if n=0
    drc(m).m0=spj
  else
    a=spj-drc(m).m0
  endif
  select n
    case 1  : drc(m).m1=a
    case 2  : drc(m).m2=a
    case 3  : drc(m).m3=a
  end select
  a=spj-1
  @qle=spp+a
  qle=le
  mid(sps,spj+lle)=w
  spj=b
  if spj>spm
    spm=spj
  endif
end procedure


function mrcsp(int m,n,i) as int
================================
  int a,b,p
  'boundary check
  if m>maxit
    return 0
  endif
  
  a=drc(m).m0
  select n
  case 1 : b=drc(m).m1
  case 2 : b=drc(m).m2
  case 3 : b=drc(m).m3
  end select
  if a=0
    return 0
  elseif n
    if b=0
      return 0
    endif
  endif
  return a+b+i+lle-1 'sps char index
end function


function mrcso(int m, n) as string
==================================
  int le
  sys a,b,p
  if m>maxit
    return ""
  endif
  if m<0
'mbox "mrcso "+n+"  "
'+hex(a+lle)+"  "+hex(qle)
    return ""
  endif
  a=drc(m).m0
  select n
  case 1 : b=drc(m).m1
  case 2 : b=drc(m).m2
  case 3 : b=drc(m).m3
  end select
  if a=0
    return ""
  elseif n
    if b=0
      return ""
    endif
  endif
  a+=b-1
  p=spp+a
  @qle=p 'length
  return mid(sps,a+lle+1,qle)
end function


def cmpsp
=========
p=spp+j
p--
mov rsi,p
mov cx,le
cmp cx,[rsi]   'compare lengths (must be<32k)
jnz nmstr      'length mismatch
mov dword a,-1 'presume match
add rsi,lle    'string pointer of name record
mov rdi,wk     'string pointer of name to check
dec rsi        'preadjust for looping
dec rdi        'ditto
inc cx         'ditto
rmstr:
  inc rsi
  inc rdi
  dec cx    ' byte count
  jle nmstr ' ok matched
  mov al,[rsi]
  cmp al,[rdi]
jz rmstr 'match bytes so continue
mov dword a,0 'mismatch
nmstr:
end def


int dcf     'double dot flag for .. namespace words
int nsp     'namespace query index
int nsi     'current namespace index
int nss[99] 'namespace nesting stack
int nsk     'namespace stack index
'int nsr     'root namespace flag
'
function lookupj(sys wk, int le,v,i) as int
===========================================
'SEARCH HASH LIST
int a,j,n
sys p
do
  if v<=0
    exit do 'NO MORE IN LIST
  endif
  if drc(v).i=i 'MATCHING HASH CODE
    a=0
    j=drc(v).m0
    cmpsp 'uses a,spp,wk,j,le
    if a
      return v 'MATCH
    endif
  endif
  v=drc(v).j 'NEXT BACKWARDS LINK
loop
end function


function lookupi(sys wk, int le,v,i) as int
===========================================
'SEARCH HASH LIST
int a,j,n
sys p
do
  if v<=0
    exit do 'NO MORE IN LIST
  endif
  if drc(v).i=i 'MATCHING HASH CODE
    a=0
    'look in nested namespaces
    n=drc(v).l 'NAMESPACE
    if nsp
      if n=nsp
        'MATCHING SPECIFIED NAMESPACE NSP
        a=1
      endif
    else 'nsp=0
      if n
        if n=nsi
          a=1 'MATCHING CURRENT NAMESPACE NSI
        endif
      else 'n=0
        a=1 'NULL NAMESPACE, ALWAYS MATCHING
      endif
    endif
  endif
  if n
    if a=0
      if nsk
        'look through parental namespaces
        int nk=nsk
        while nk>0
          nk--
          if n=nss(nk)
            a=1
            exit while
          endif
        wend
      endif
    endif
  endif
  if a
    a=0
    j=drc(v).m0
    cmpsp 'uses spp,wk,j,le
    if a
      return v 'MATCH
    endif
  endif
  v=drc(v).j 'NEXT BACKWARDS LINK
loop
'RETURNING INDEX OF MATCHING NAME OR NULL
'
end function


function colom(sys wp,dcf) as int
=================================
'instrev "::" 'return index of right colon
int dcc=0
byte *bt
@bt=wp+dcf-1
do
select bt
case 58 
  dcc++
  if dcc=2
    dcf++
    exit do
  endif
case else
  dcc=0
end select
dcf--
@bt--
if dcf=0
  exit do
endif
loop
return dcf
end function


function lookupm(string wd) as int
'=================================
'
'TO FORM A BASE INDEX TO SELECT A CHAIN
'FIND THE FIRST MATCHING NAME GOING BACKWARDS
'
int a,b,i,k,v,w,le,lw,mw
int ke,ki,kv
sys wp,wq
wp=strptr(wd)
lw=len(wd)
nsp=0
dcf=colom(wp,lw)
if dcf=0
  hashmac(wp,i)
  w=i and 0xffff
  v=mrcb(w)
  return lookupi(wp,lw,v,i)
else 'dcf
  'ABSOLUTE NAMESPACE ONLY
  mw=dcf
  wq=wp+mw
  ke=lw-mw
  if ke>0
    hashmac(wq,ki)
    w=ki and 0xffff
    kv=mrcb(w)
    kv=lookupj(wq,ke,kv,ki)
    if kv=0
      return 0 'primary symbol not found
    endif
  endif
  '
  do 'nesting search
  ==================
    hashmacl(wp,dcf,i)
    w=i and 0xffff
    v=mrcb(w)
    nsp=lookupj(wp,dcf,v,i) 'name::' only
    if nsp
      if dcf=lw
        return nsp 'lookup namespace only
      endif
      k=lookupi(wq,ke,kv,ki)
      if k
        return k 'otherwise try again
      endif
    endif
    'nsp=0
    'to find parent namespace
    if dcf>4 'x::y::
      dcf=colom(wp,dcf-3)
    else
      dcf=0
    endif
    if dcf=0
      return 0 'namespace not found
    endif
  loop
endif 'dcf
'
end function


function lookupr(int v) as int
'=============================
'LOOK FOR PREVIOUS
int i,le
sys wk
i=drc(v).i   '4 byte hashcode
nsp=drc(v).l 'namespace
wk=drc(v).m0+spp
wk--
@qle=wk
le=qle 'length field
wk+=lle  'string pointer
v=drc(v).j 'PRIOR RECORD IN CHAIN
return lookupi(wk,le,v,i)
'itr namespaces
end function


procedure newrecord(string*wd)
==============================
if not wd
  exit procedure
endif
mrcin(me)
mrcsi(wd,me,0)
int a
if uniq
  a=lookupm(wd)
  if a
    'mbox "brc " brc " drc.k " drc(a).k " nsi " nsi "drc.l " drc(a).l
    if (nsi=0)or(nsi=drc(a).l) 'BASE NAMESPACE OR MATCHING NAMESPACE
      if drc(a).k=brc 'WITHIN SAME SCOPE / NESTING
        if drc(a).a<>-5
          ers="'"+wd+"' is already defined"
          ert=13
          exit procedure
        endif
      endif
    endif
  endif
endif

int i,v,w,nsq,lw
sys wp
wp=strptr(wd)
lw=len(wd)
dcf=colom(wp,lw)
nsp=0
nsq=0
if dcf
  if dcf=len(wd) 'STORING THE NAMESPACE ITSELF
    dcf=0
  else
    'get nsp namespace code
    dcf++
    hashmacl(wp,dcf,i)
    w=i and 0xffff
    v=mrcb(w)
    nsp=0
    nsq=lookupi(wp,dcf,v,i)
    if nsq=0
      ers="namespace not found " left(wd,dcf)
      ert=12
      exit procedure
    endif
  endif
endif

sys p=strptr(wd)+dcf
hashmac(p,i)
w=i and 0xffff
v=me
if nsq
  a=nsq
else
   a=nsi
endif
'
drc(v).i=i            'HASH CODE
drc(v).j=mrcb(w)      'LINK TO PREVIOUS
drc(v).k=brc          'NESTING LEVEL
drc(v).l=a            'NAMESPACE
if fq
  drc(v).g=sti(fq-1) 'FQL: SOURCE FILENAME INDEX SSN(FQL)
endif
'
mrcb(w)=v 'SET BASE LINK
'
end procedure


int qme
'
procedure addme()
'================
  qme=me
  me++
  if me>=maxit
    maxit+=maxit 'double record capacity
    stretch drc(maxit)
  endif
end procedure

def subme me-- : qme--


procedure SetNameSpace(string*s, int *i)
========================================
  string wr,w1
  int a
  if nisxn 'open namespace x..
    nss(nsk)=nsi
    nsk++
    wr=tword(s,i)
    if nsi
      w1=mrcso(nsi,0)
    else
      w1=""
    endif
    w1+=wr+"::"
    nsi=0
    a=lookupm(w1)
    if a
      nsi=a
    else 'new namespace
      newrecord w1
      drc(me).a=-12 'METATYPE NAMESPACE
      nsi=me
      addme
    endif
  else 'end namespace etc
    if nsk
      nsk--
      nsi=nss(nsk)
    else
      nsi=0
    endif
  endif
  appendt ("o2 k"+hex(nsi)+cr) 'PASS ON
end procedure


function capm(int i) as string
==============================
  return str(i)+dfd+cr
end function


function writestates(int b, e) as string
========================================
  string s,w1,c
  int i,k,le
  c=dfd+cr
  for i=b to e
    w1=
    mrcso(i,0)+c+
    mrcso(i,1)+c+
    mrcso(i,2)+c+
    mrcso(i,3)+c+
    capm(drc(i).a)+
    capm(drc(i).b)+
    capm(drc(i).c)+
    capm(drc(i).d)+
    capm(drc(i).e)+
    capm(drc(i).f)+
    capm(drc(i).g)+
    capm(drc(i).h)
    le=len(w1)
    if len(s)<k+le
      s+=space(8000+le)
    endif
    mid(s,k+1)=w1
    k+=le
  next
  return left(s,k)
end function



procedure nest()
================
  nester*sc
  if brc>99
    ers="Depth limit exceeded ((()))" : ert=10 : exit procedure
  endif
  brc++
  @sc=@scop(brc)
  sc.me    = me    '0  DATA RECORD BOUNDARY
  sc.spj   = spj   '6  STRING POOL END
  sc.ixb   = ixb   '7  ARRAY INDEX BASE
end procedure

procedure unnest()
'=================
  nester*sc
  int a,b,c,e
  @sc=@scop(brc)
  e=qme
  '
  me    = sc.me    '0  DATA RECORD BOUNDARY
  spj   = sc.spj   '6  STRING POOL END
  ixb   = sc.ixb   '7  ARRAY INDEX BASE
  '
  brc--
  if brc<0
    brc=0
    ers="Too many right brackets (..))" : ert=10
  endif
  'HASH TABLES BACKWARD DISALLOCATION
  for a=e to me step -1
    b=drc(a).j 'PREVIOUS RECORD
    c=drc(a).i and 0xffff 'HASH BASE
    mrcb(c)=b
  next
end procedure


procedure localvars()
=====================
 if lclv
   aoffl=aoff
 else
   aoffs=aoff : regs=regsl
 endif
 lclv=1 : aoff=aoffl : asce=-1
end procedure


procedure staticvars()
======================
 if lclv
   aoffl=aoff : regs=regss
 else
   aoffs=aoff
 endif
 lclv=0 : aoff=aoffs : asce=1
end procedure


function signedstr(int d) as string
===================================
  if d>0
    return "+"+str(d)
  elseif d<0
    return str(d)
  endif
end function


function signedhex(int d) as string
===================================
  if d>0
    return "+0x"+hex(d)
  elseif d<0
    return "-0x"+hex(-d)
  endif
end function


function memreg(string*rg, int d) as string
===========================================
  return "["+rg+signedstr(d)+"]"
end function


function memregadj(string*mr, int d) as string
==============================================
  int a,b,c,e
  string en="]"
  if asc(mr,len(mr))<=13
    en+=cr
  endif
  a=instrevn(-1,mr,"[")
  int ta=asc(mr,a+1)
  'itr no negative abs address
  if (ta>=0x30)and(ta<=0x39)
    'adjust absolute addr
    c=a
    e=val(mid(mr,c+1))
    'return left(mr,c)+"0x"+hex(d+e)+en
    return left(mr,c)+str(d+e)+en
  else
    c=instr(a,mr,"*") 'index multiplier: *1 *2 *4 *8
    if c
      c+=2
    else
      c=5
    endif
  endif
  a=asc(mr,c)
  e=val(mid(mr,c+1))
  if a=45
    e=-e
  endif
  'return left(mr,c-1)+signedhex(d+e)+en
  return left(mr,c-1)+signedstr(d+e)+en
end function


function newstatvar() as int
============================
  if lclv
    function=aoffs : aoffs+=cpuw
  else
    function=aoff : aoff+=cpuw : aoffs=aoff
  endif
end function


function newstatvarStr(int*p) as string
=======================================
  p=NewStatVar()
  return memreg(regss,p)
end function

int dlb ' dlb  dll list base
'
function addlib(string*wr) as int
=================================
  int a
  if not wr
    return 0
  endif
  wr=lcase(wr) ' MS case insens
  '
  'SEARCH BACKWARDS
  '----------------
  '
  a=libe
  do
    a--
    if a<dlb
      exit do 'DLB INIT = 1
    endif
    if wr=libs(a)
      exit do
    endif
  loop
  '
  'ASSIGN NEW
  '----------
  '
  if a<1
    a=libe 'LIBE INIT = 1
    libu(a)=0
    '
    'ALWAYS STORE IN STATIC VARIABLE
    '
    libo(a)=newstatvar()
    libs(a)=wr
    libe++
    '
    'CHECK LIMIT
    '-----------
    '
    if libe>510
      libe=510 : ert=300 : ers="Too many libraries"
    endif
  endif
  '
  return a
  '
end function




function addlproc(int pd, string*wa) as string
==============================================
  '
  'FORMAT : o2 ( ...02 h?xxxxxxxx `name` 00 ...
  '
  '
  int a,b,c,d,e,lw
  string wr,w1
  '
  'SELECT LIB BUFFER
  '-----------------
  '
  c=libu(pd)    'LIB BUFF USED
  w1="`"+wa+"` 00" 'LOCATE ALIAS
  '
  '
  'CHECK IF ALREADY PRESENT
  '------------------------
  '
  if libl[pd]
    d=instr(libl[pd],w1)
  else
    libl[pd]="" 'INIT BUFFER
  endif
  '
  if (d>0)and(d<c)
  'EXTRACT PREVIOUS VECTOR
    a=instrevn(d-2,libl(pd),"h")+2
    return "["+qebx+"+0x"+yword(libl(pd),a)+"]"
  endif
  '
  'OTHERWISE CREATE NEW STATIC VAR
  '-------------------------------
  '
  a=newstatvar()
  '
  'CREATE A NEW VECTOR
  '-------------------
  '
  if cpuw=4
    wr="02 hl"+hex(a)+" "+w1+cr 'LINK DATA
  else 'cpuw=8
    wr="02 hq"+hex(a)+" "+w1+cr 'LINK DATA
  endif
  '
  lw=len(wr)
  '
  '
  'EXTEND BUFFER IF NEEDED
  '-----------------------
  '
  e=len(libl(pd))
  if e<c+lw+1
    libl(pd)+=space(2048)
  endif
  '
  'APPEND PROC NAME AND REGSS OFFSET TO LIST
  '-----------------------------------------
  '
  mid(libl(pd),c+1)=wr
  libu(pd)=c+lw
  '
  impo=1
  return memreg(qebx,a) 'RETURN STATIC OFFSET
  '
end function



function StoreCode(string*s) as string
======================================
string wr
int d
if not s
  exit function
endif
tmpi++ : wr="_code"+str(tmpi)
'dct=0 'each storecode
newrecord wr
if ert
  exit function
endif
mrcsi(s,me,1)
drc(me).a=-22
addme
s=""
return wr+cr
end function



function readdata(string*s, int *i) as string
=============================================
int a,b
string w1,w2
do
  select asc(s,i)
  case 0 : exit do
  case 13,39 : endline(s,i) : i+=2 : continue do 'SKIP LINE
  end select
  b=i : endline(s,i)
  w1=mid(s,b, i-b)
  i+=2
  a=instr(w1,chr(39)) 'SIMPLISTIC DETECT COMMENT
  if a
    w1=rtrim left(w1,a-1) 'TRIM OFF COMMENT AND PADDING
  endif
  w2+=ltrim w1 'APPEND LINES
  if asc(s,i)<>32
    exit do 'OTHERWISE ADD INDENTED LINE (NO TABS)
  endif
  w2+=chr(13,10)
loop
lenw=len(w2)
return w2
end function


function readin(string*s) as string
===================================
int b,i
string w1,w2
  '
  w2=nuls 0x2000 : b=1 : i=1
  do
    w1=readdata s,i 
    if w1="!end!"
      exit do
    endif
    if w1=""
      exit do
    endif
    mid(w2,b)=w1+cr : b+=len(w1)+2 'len cr
  loop
  return left(w2,b-1)
end function



  'OPERATORS
  '=========
  '
  'these op-numbers are all hardcoded
  'only used for converting op numbers back into op names
  '
  string opname="
  0 load
  1 load
  2 =
  3 cmp
  4 push
  5 dump
  6 pop
  7 neg
  8 +=
  9 -=
  10 swap
  11 not
  11 !
  12 ++
  12 inc
  13 --
  13 dec
  14 *=
  15 /=
  20 ==
  21 <>
  21 !=
  28 <
  29 >=
  30 <=
  31 >
  32 boolean
  33 and
  33 &
  34 or
  34 |
  35 xor
  65 and=
  65 &=
  66 or=
  66 |=
  67 xor=
  42 *
  43 +
  45 -
  47 /
  92 \
  71 &&
  72 ||
  73 ^^
  74 <<
  75 >>
  76 <<<
  77 >>>
  94 ^
  "
'
string opnameu 'custom operators
'
function identops(int n) as string
==================================
int a,b
string w1
  '
  w1=" "+str(n)+" "
  b=a+len(w1)
  a=instr(opname,w1)
  if a
    return yword(opname,b)
  endif
  a=instr(opnameu,w1)
  if a
    return uword(opnameu,b)
  endif
end function
'
int uop  'customised operators flag and tally
'
function identop(string *s, int k, *i) as int
=============================================
  '
  ' n   operator code
  ' prl precedence level
  int n,a,b,c,d,e
  string wr
  '
  '
  '
  'higher prl means higher precedence
  '----------------------------------
  'power        8 ^
  'mult div     7 * / \
  'add subtract 6 + -
  'shifts       5 << >>
  'comparators  4 == <> > < >= <=
  'logicals     3 and
  '             2 xor
  '             1 or
  '----------------------------------
  '
  'CUSTOM OPERATORS
  if uop
    e=i
    i=k
    wr=uword(s,i)
    c=i
    d=ascn
    a=idword(opnameu,wr)
    if a
      n=0X400 'operator number >=typh
      prl=val uword(opnameu,a)
      ascn=d 'restore
      i=c    'restore
      jmp fwd idop
    endif
    i=e 'fallback
  endif
  '
  a=ascl(s,k)
  b=asc(s,k+1)
  prl=0
  select a
  case 0x30 to 0x39 'numbers
    jmp fwd idop
  case 0x61 to 0x7a 'lowercase
    jmp fwd wordop
  case 34,39,96,40,41,91,93,123,125,35,95
    goto idop
  case 92,47,42
    n=a : prl=7 : goto idop '\ / *
  case 43,45
    n=a
    prl=6                  '+ -
    if a=b
      i++ : n+=128 : prl=9 '++ -- unary
    endif
    goto idop '+
    '
    'AND && &
    '
  case 38
    if b<>a
      if isa(b)=0 'exclude addresses
        n=33 : prl=3 : goto idop '&
      endif
      goto idop ' &h &o ignore
    endif
    i++ : n=71 : prl=1 : goto idop '&&
    '
    'OR || |
    '
  case 124
    prl=1
    if b<>a
      n=34 : goto idop    '|
    endif
    i++ : prl=1 : n=72 : goto idop  '||
    '
  case 33
    if b=61
      i++ : prl=4 : n=0x15 '!=
      goto idop
    endif
    n=104 : prl=4
    goto idop 'NOT !
    '
    '<< < <= <>
    '
  case 60
    if b=60
      i++
      if asc(s,k+2)=b
        i++
        n=76 '<<< ROTATE LEFT
      else
        n=74 '<<  SHIFT LEFT 
      endif
      prl=5 : goto idop
    endif
    '
    prl=4  'COMPARATORS
    n=28  '0x1c <
    if b=61
      i++ : n=30 '0x1e <=
    endif
    if b=62
      i++ : n=21 '0x15 <>
    endif
    goto idop
    '
    '= ==
    '
  case 61
    prl=4 : n=20 ' = 0x14
    if b=61
      i++ '0x14 == 0x14
    endif
    goto idop
    '
    '>> > >=
    '
  case 62
    if b=62
      i++
      if asc(s,k+2)=b
        n=77
        i++  '>>> ROTATE RIGHT
      else
        n=75  '>>  SHIFT RIGHT 
      endif
      prl=5 : goto idop
    endif
    n=31 : prl=4  '0x1f >
    if b=61
      i++ : n=29  '0x1d >=
    endif
    goto idop 'COMPARE
    '
  case 94
    if a<>b
      prl=8 : n=a : goto idop '^ power (not C Xor ??)
    else
      i++ : n=73 : prl=1 : goto idop 'boolean xor
    endif
  end select
  jmp fwd idop
  '
  wordop:
  =======
  '
  'WORDY OPERATORS
  '
  i=k
  wr=tword(s,i)
  i=swd+lenw
  select lenw
  case 2
    if wr="or"
      n=34 : prl=1
    endif
  case 3
    if wr="and"
      n=33 : prl=3
    elseif wr="xor"
      n=35 : prl=2
    elseif wr="shl"
      n=74 : prl=5
    elseif wr="shr"
      n=75 : prl=5
    elseif wr="rol"
      n=76 : prl=5
    elseif wr="ror"
      n=77 : prl=5
    elseif wr="pow"
      n=94 : prl=8
    elseif wr="mod"
      n=93 : prl=7
    endif
  end select
  '
  idop:
  =====
  '
  return n
  '
end function


function precedence(string*s, int*i,bsn) as string
==================================================
  '
  static as int ppl(31),pk(31)
  string uu,u,wr,wk,w1
  int a,b,c,d,e,f,k,nl,pp,twd,alb,ma,ido,le,ngs,qp
  '
  skiplspace(s,i)
  if isxn
    exit function
  endif
  nl=bsn
  '
  do
    c=i : skipspace(s,i)
    '
    '
    wr=tword(s,i)
    '
    if ngs
      ngs=0
      if isn(ascw)
        u+="-"
      else
        a=swd
        if (isb(ascw)<>0)or(isb(ascn)<>0)
          if ascw=40
            i=swd 'NESTED EXPRESSION
          endif
          '========= 
          'captarray
          '=========
          ' capture array with element
          skiplspace(s,i)
          do
            if isb(ascn)
              capture(s,0,i,0)
              if asc(s,i)=46
                icas=1 : wr=bword(s,i)
                continue do
              endif
            endif
            exit do
          loop
          '
          wr=mid(s,a,i-a) 'NESTED EXPRESSION / ARRAY / FUNCTION
          skiplspace(s,i)
        endif
        if ido 'operator
          inserts(s,"("+wr+" _neg ) ",i)
        else
          inserts(s,wr+" _neg ",i)
        endif
        continue do
      endif
    endif 'ngs
    '
    '
    'PRE ++ --
    '
    if ascw=ascn
      if (ascw=43)or(ascw=45)
        u+=string(2,chr(ascn)) : i++ : continue do
      endif
    endif
    '
    '
    'TERMINATOR WORDS AND SYMBOLS
    'ASSEMBLER OPERANDS
    '
    if lenw>1
      if idword(" then else to ",wr)
        i=c : exit do
      endif
    else
      a=(k==0)or(ido<>0)
      select ascw
      case 0 to 31 : i=c : exit do
      case 38  :
        if qp<>1
          u+="& " : continue do '&' address
        endif
      case 42  :
        if a
          u+="*" : continue do '*' pointer
        endif
      case 43  :
        if a
          continue do '+' positive (ignore)
        endif
      case 45  :
        if a
          ngs=1  : continue do '-' negative num/var/function
        endif
      case 39,58,59,123,125 ' ;:;{}
        i=c : exit do
      case 91
        '
        'ASSEMBLER OPERANDS/ARRAY INDEX SKIP
        '
        a=instr(i,s,"]")
        if a
          i=a+1 : skiplspace(s,i)
        endif
        '
      end select
    endif
    '
    ido=0
    '
    '
    qp=1
    twd=len(u)+1        'NEXT BUFFER POSITION
    a=i-c               'NUMBER OF SPACES
    u+=mid(s,c,a)       'APPEND SPACE BEFORE NEXT WORD
    k=twd+a             'INCLUDE SPACING IN BUFFER POSITION
    '
    select ascw

    case 44 
      a=nl-bsn 'number of closing brackets
      uu+=string(alb,"(")+left(u,twd-1)+string(a,")")+"," 'CLOSE ALL BRACKETS BEFORE COMMA AND RESET PP & DD
      k=0 : u="" : nl=bsn : pp=0 : alb=0
      continue do
    case 40 '(
      if ascn<>rbr
        u+=precedence(s,i,nl+1) 'RECURSE INSIDE BRACKETS
      else
        u+=tword(s,i) 'EMPTY BRACKET PAIR
      endif
      '
      if iss(ascn)
        exit do
      else
        continue do
      endif
    case 41 ')
      exit do  'TERMINATE INCLUDING BRACKET
    end select
    '
    'IDENTIFY OPERATOR
    '
    b=i : a=0
    '
    if ascw<>91
      a=identop(s,swd,i)
      skiplspace(s,i)
      if a
        if asc(s,i)=61
          exit  do ' assignments combo operator += -= *= /= and=
        endif
        qp=a
      endif
    endif
    '
    if ascw=61
      if a<=2
        exit do '= is an assignment
      endif
    endif
    '
    'IS AN OPERATOR (prl=precedence level)
    '
    if a>2
      '
      ido=a 'hold operator code
      '
      le=i-b
      if le>0
        u+=mid(s,b,le)
        k+=le'extra char operators
      endif
      '
      'AUTO LINE CONTINUATION
      '
      if ise(ascn)
        nextinstruct(s,i) : u+=" "
      endif
      do
      '
      if nprec
        b=prl     'no precedence evaluation
      else
        b=ppl(nl) 'precedence level
      endif
      '
      if prl>b
        '
        'HIGHER PRECEDENCE: INSERT '(' AFTER PREVIOUS OPERATOR
        '-----------------------------------------------------
        '
        if pp
          u=left(u,pk(nl)-1)+"("+mid(u,pk(nl))
          k++  'char buffer position
          nl++ 'next stack position
        endif
        '
      elseif prl<b
        '
        'LOWER PRECEDENCE: INSERT ')' BRACKET BEFORE OPERATOR
        '----------------------------------------------------
        '
        if (nl>bsn)or(pp<>0)
          u=left(u,twd-1)+")"+mid(u,twd)
          k++   'CHAR BUFFER POSITION
          twd++ 'eg: if (a=b)or..
        endif
        '
        if nl>bsn
          nl--              'previous stack position (release current)
          continue do        'for possible multiple ')' closures
        else
          if pp
            alb++  'add to starting left bracket count
          endif
        endif
        '
      endif 'precedence bracket inserts
      '
      'itr imperfect solution for mixed bool exprs and exprs containing div
      if (nl=0)or(cnd=0) 'implied prl=b 'no nesting
        if ido=47
          divi=1
        endif
      endif
      '
      exit do
      loop
      '
      ppl(nl)=prl  'stack record precedence level
      pk(nl)=k     'stack record position following operator
      pp=a         'flag 1 or more operators processed
      '
    else 'NOT AN OPERATOR
      '
      if iss(ascn) 
        exit do 'END OF STATEMENT
      elseif ascn=asc(s,i+1)
        if (ascn=43)or(ascn=45)
          u+=string(2,chr(ascn))+" " : i+=2  'POST ++ --
        endif
      endif
      ' 
    endif
  loop
  '
  'CLOSE REMAINING BRACKETS AND RETURN TO PREVIOUS LEVEL
  '
  '
  'itr check for unbalance brackets?
  '
  function=uu+string(alb,"(")+u+string(nl-bsn,")")
  '
end function


procedure capts(string*s, int*i)
================================
  'CAPTURE EXPRESSION
  '
  int a,b,c,m,n,bg
  string wr
  byte bb at strptr(s)-1
  skiplspace(s,i)
  bg=i
  do
    if isb(ascn)
      if ascn=nobr
        exit do 'USED IN 'FOR' EXPRESSION; TERMINATING ON '{'
      endif
      capture(s,m,i,a) 'elct tally
      skiplspace(s,i)
      continue do
    elseif ascn=44
      if noco
        i++ : nextinstruct(s,i)
        continue do
      else
        exit do
      endif
    elseif isxn
      if ascn=58
        if bb[i+1]=61
          ascn=61 : i++ : continue do ':='
        endif
      endif
      exit do ' ,:;)]}'
    endif
    '
    ilc=1 : wr=gword(s,i)
    '
    if isq(ascw)
      'continue do
    elseif idword(endex,wr)
      i=swd : skiplspace(s,i) : exit do
    elseif isw(ascw)
      if idword(" and or xor _neg _not ",wr) 
        nextinstruct(s,i) 'IGNORE END OF LINE 
      endif
      'continue do
    else 
      'itr operators ++ -- << >> && ||
      n=identop(s,swd,i)
      if n
        if n>=171 'not ++ -- 128+43
          n=0
        endif
      endif
      if n
        nextinstruct(s,i) 'IGNORE END OF LINE
      else
        skiplspace(s,i)
      endif
    endif
  loop
  swd=bg
end procedure
'
function captsx(string*s, int*i) as string
==========================================
capts(s,i)
function=rtrim(mid(s,swd,i-swd))
end function
'
function captsr(string*s, int*i) as string
==========================================
noco=1
capts(s,i)
function=rtrim(mid(s,swd,i-swd))
noco=0
end function


