'=======
'BUFFERS
'=======

'----------------------------------------------
sub insertt(byval wt as string, byval p as sys) 'INSERT INTO ASSEMBLY BUFFER
'==============================================
  dim as sys le=len(wt)
  if len(t)<j+le then t+=space(le+4000)
  mid(t,p)=wt+mid(t,p,j-p) : j+=le
end sub


'------------------------------------------------------------
sub ape(byref s as string,byref k as sys, byval wt as string)
'============================================================
  dim as sys le=len(wt)
  if len(s)<k+le then s+=string(le+4096,chr(0))
  mid(s,k+1)=wt : k+=le
end sub


'-----------------------------------------------------------------
sub appendm(byref s as string, byref k as sys, byref wt as string)
'=================================================================
  dim as sys le=len(wt)
  if len(s)<k+le then s+=space(le+4096)
  mid(s,k)=wt : k+=le
end sub


'------------------------------
sub appendt(byval wt as string)
'==============================
  static as sys le
  le=len(wt)
  if len(t)<j+le then t+=space(le+&h10000)
  mid(t,j)=wt : j+=le
end sub




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

'------------------------------
function NewTmpName() as string
'==============================
tmpi+=1 : return chr(127)+str(tmpi)
end function

'---------------------------------------------------------------
sub init4(byval p as any ptr, byval le as sys, byval c as long)
'===============================================================
dim as long ptr q
q=cast(long ptr,p)
while le>0
  *q=c
  q+=1
  le-=1
wend
end sub


'------------------
#macro hashcodem(s)
'==================
dim as byte ptr p=strptr(s)
asm
mov edx,&h35db53bd
mov ecx,[p]
rhashcode:
mov al,[ecx]
cmp al,0
jz nhashcode
rol edx,1
xor dl,al
inc ecx
jmp rhashcode
nhashcode:
mov [i],edx
end asm
#endmacro


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

'-------------------------
sub macoin(byval m as sys)
'=========================
 init4 @maco(m,0),smaco,0
end sub


'-----------------------------------------------------------
sub macsi(byref w as string, byval m as sys, byval n as sys)
'===========================================================
  '
  'STORE STRING IN BUFFER
  'INDEX IT IN MACO (WITH OFFSET OF N)
  '
  dim as sys b,le
  n+=omacs
  le=len(w) : if le=0 then maco(m,n)=0 : exit sub
  b=spe+le+4
  if b>spl then
    sps+=string(1000000,chr(0)) : spl=len(sps)
  end if
  maco(m,n)=spe
  mk4(sps,spe,le)
  mid(sps,spe+4)=w
  spe=b
end sub


'-------------------------------------------
sub macsp(byval w as string, byref b as sys)
'===========================================
  dim as sys le=len(w)
  mk4(sps,b,le)
  mid(sps,b+4)=w
  b+=le+4
end sub



'-------------------------------------------------------
function macso(byval m as sys, byval n as sys) as string
'========================================================
  dim as sys a,le
  dim as byte ptr p
  dim q as long ptr
  n+=omacs
  a=maco(m,n) : if a=0 then exit function
  p=strptr(sps)
  p+=a-1
  q=cast(long ptr,p)
  function=mid(sps,a+4,*q)
end function


'-------------------------------------------------------
function cmpsp(byref w as string, byval i as sys) as sys
'=======================================================
dim as sys le
dim as sys f
dim as any ptr p
dim as any ptr q
p=strptr(sps)
q=strptr(w)
le=len(w)
'q=p+i-1
'if le<>*q then return 0             'LENGTH MISMATCH
asm
mov esi,[p]
add esi,[i]
dec esi
mov ecx,[le]
cmp ecx,[esi]
jnz nmstr 'length mismatch
mov dword ptr [f],-1 'presume match
add esi,4
mov edi,[q]
dec esi
dec edi
inc ecx
rmstr:
  inc esi
  inc edi
  dec ecx  ' byte count
  jle nmstr ' ok matched
  mov al,[esi]
  cmp al,[edi]
  jz rmstr 'match bytes so continue
mov dword ptr [f],0 'mismatch
nmstr:
end asm
'if f then if w=mid(sps,i+4,le) then return -1 'WORD MATCH
return f
end function


'------------------
sub InitDefTables()
'==================
spl=1000000 : sps=string(spl,chr(0)) : spe=8 'clear string pool
init4 @macb(0),512,0        'clear hash table base
init4 @maco(0,0),me*smaco,0 'clear previous records
me=1                        'reset records boundary
mp=0                        'clear locator index
end sub


function lookupm(byval wd as string) as sys
'==========================================
'
dim as sys a,f,i,m,n,v,w
dim as string wk
nsp=0
dcf=instr(wd,"::")
if dcf then
  dcf+=1
  if dcf=len(wd) then 'LOOKING FOR  THE NAMESPACE ITSELF
    dcf=0
  else
    nsw=left(wd,dcf)
    i=dcf : dcf=0
    nsp=lookupm(nsw)
    nsq=nsp
    dcf=i
  end if
end if

wk=mid(wd,dcf+1)

'hashcodem
dim as byte ptr p=strptr(wk)
asm
mov edx,&h35db53bd
mov ecx,[p]
rhashcode1:
mov al,[ecx]
cmp al,0
jz nhashcode1
rol edx,1
xor dl,al
inc ecx
jmp rhashcode1
nhashcode1:
mov [i],edx
end asm
'
'TAKE THE BOTTOM 9 BITS OF THE HASH CODE
'TO FORM A BASE INDEX TO SELECT A CHAIN
w=i and 511
v=macb(w)
'
'FIND THE FIRST MATCHING NAME GOING BACKWARDS
f=0
do
  if v<=0 then exit do 'NO MORE IN LIST
  if (mach(v).h=i) then 'MATCHING HASH CODE
    a=0
    n=mach(v).n 'NAMESPACE
    if nsq then
      if n=nsq then a=1 'MATCHING SPECIFIED NAMESPACE NSQ
    else 'nsq=0
      if n then
        if n=nsi then a=1 'MATCHING CURRENT NAMESPACE NSI
      else
        a=1 'NULL NAMESPACE, ALWAYS MATCHING
      end if
    end if
  end if
  if a then
    a=0
    'm=mach(v).m
    m=v
    if m then
      if cmpsp(wk,maco(m,omacs)) then
        f=m 'MATCH
        exit do
      end if
    end if
  end if
  v=mach(v).l 'NEXT BACKWARDS LINK
loop
nsq=0
return f 'INDEX OF MATCHING NAME OR NULL
'
end function


'-----------
sub addmin()
'===========
dim as sys a,i,v,w
dim as string wd=macso(me,0)
dcf=instr(wd,"::")
if dcf then
  dcf+=1
  if dcf=len(wd) then 'STORING THE NAMESPACE ITSELF
    dcf=0
  else
    nsw=left(wd,dcf)
    i=dcf : dcf=0
    nsq=lookupm(nsw) 'RECURSE TO LOCATE NAMESPACE
    dcf=i
  end if
end if

'hashcodem
dim as byte ptr p=strptr(wd)+dcf
asm
mov edx,&h35db53bd
mov ecx,[p]
rhashcode3:
mov al,[ecx]
cmp al,0
jz nhashcode3
rol edx,1
xor dl,al
inc ecx
jmp rhashcode3
nhashcode3:
mov [i],edx
end asm
'
if i=0 then ers="zero hash failure: "+macso(me,0) : ert=13 : exit sub
w=i and 511
if me>=maxit then
  ers="Too many entities to include "+macso(me,0) : ert=13 : exit sub
end if
v=me
if nsq then a=nsq else a=nsi
nsq=0
mach(v).h=i       'FULL HASH CODE
mach(v).l=macb(w) 'LINK TO PREVIOUS
mach(v).b=brc     'NESTING LEVEL
mach(v).n=a       'NAMESPACE
macb(w)=v         'SET BASE LINK
if fq then
  maco(v,6)=sti(fq-1) 'FQL: SOURCE FILENAME INDEX SSN(FQL)
end if
maco(v,7)=a 'NAMESPACE INDEX
'
end sub


'------------------------------------------
function lookupc(byref wd as string) as sys
'==========================================
dim as sys v,i
'hashcodem
dim as byte ptr p=strptr(wd)
asm
mov edx,&h35db53bd
mov ecx,[p]
rhashcode2:
mov al,[ecx]
cmp al,0
jz nhashcode2
rol edx,1
xor dl,al
inc ecx
jmp rhashcode2
nhashcode2:
mov [i],edx
end asm
'
v=i and 511
do
  if opd(v,0)=i then ' match#
    if wd=opn(v) then exit do ' confirm perfect match
  end if
  v=opd(v,1) : if v=-1 then exit do
loop
return v
end function



'---------
sub addm()
'=========
  dim as sys a,b
  dim as string wr=macso(me,0)
  if wr="" then exit sub
  a=lookupm(wr)
  if a then
    if uniq then
      if (nsi=0)or(nsi=mach(a).n) then 'BASE NAMESPACE OR MATCHING NAMESPACE
        if mach(a).b=brc then 'WITHIN SAME SCOPE
          ers="'"+wr+"' is already defined"  : ert=13 : exit sub
        end if
      end if
    end if
    'b=maco(a,0)
    'if b=-9 then 'or b=-10 'register
    '  ers="'"+wr+"' is a reserved word"  : ert=13 : exit sub 'LIST OF COMMON RESERVED WORDS
    'elseif a<mesb then
    '  ers="'"+wr+"' is a reserved symbol"  : ert=13 : exit sub 'CORE DEFINITIONS
    'end if
  end if
  addmin()
end sub


'----------
sub addme()
'==========
  me+=1 : if me>=maxit then ers="Too many definitions" : ert=10 : me=maxit-1
end sub


'------------------------------------------------------
function capm(byval i as sys, byval k as sys) as string
'======================================================
  return str(maco(i,k))+dfd+cr
end function

'-------------------------------------------------------------
function writestates(byval b as sys, byval e as sys) as string
'=============================================================
  dim as string s,w1,c
  dim as sys i,k,le
  c=dfd+cr
  for i=b to e
    w1=capm(i,0)+capm(i,1)+capm(i,2)+capm(i,3)+capm(i,4)+capm(i,5)+capm(i,6)+capm(i,7)+_
    macso(i,0)+c+macso(i,1)+c+macso(i,2)+c+macso(i,3)+c
    le=len(w1)
    if len(s)<k+le then
      s+=space(8000+le)
    end if
    mid(s,k+1)=w1
    k+=le
  next
  return left(s,k)
end function


'---------------------------------------------------------
function nexm(byref s as string, byref i as sys) as string
'=========================================================
  dim as sys k
  k=instr(i,s,dfd)
  if k then
    function=mid(s,i,k-i)
    i=k+3 ' skip dfd followed by cr
  else
    i=len(s)+1
  end if
end function



'--------------------------------
sub readstates(byref s as string)
'================================
  dim as sys c,i
  dim as string w1
  i=2
  do
    if i>=len(s) then
      exit do
    end if
    for c=0 to 7 'omacs-1
      w1=nexm(s,i)
      maco(me,c)=wval(w1)
    next
    for c=0 to 3
      w1=nexm(s,i)
      macsi(w1,me,c)
    next
    addm() : addme()
    if ert then exit do
  loop
end sub


'--------------------------------
sub newrecord(byref wr as string)
'================================
  macoin(me)
  macsi(wr,me,0)
  addm()
end sub


'---------
sub nest()
'=========
  dim as nester ptr sc
  if brc>99 then ers="Depth limit exceeded ((()))" : ert=10 : exit sub
  brc+=1
  sc=@scop(brc)
  if lclv then
    aoffl=aoff
  else
    aoffs=aoff
  end if
  sc->me    = me    '0  DATA RECORD BOUNDARY
  sc->aoffl = aoffl '1  LOCAL OFFSET
  sc->aoffs = aoffs '2  STATIC OFFSET
  sc->asce  = asce  '3  ASCENDING / DESCENDING ALLOCATION
  sc->lclv  = lclv  '5  LOCAL
  sc->spe   = spe   '6  STRING POOL END
  sc->ixb   = ixb   '7  ARRAY INDEX BASE
  sc->sr2   = sr2   '8  STATEMENT SEPARATOR 2 (: OR ;)
  sc->ct2   = ct2   '9  COMMENT MARKER 2 (;)
  sc->tys   = tys   '10 SPECIFIED DEFAULT TYPE
  sregs(brc)=regs
end sub


'-----------
sub unnest()
'===========
  dim as nester ptr sc
  dim as sys a,b,c,e
  sc=@scop(brc)
  e=me-1
  '
  'LOCAL OR STATIC VARIABLES?
  '
  if lclv=0 then aoffs=aoff 'RETAIN STATIC VARSPACE EXPANSION
  '
  me    = sc->me    '0  DATA RECORD BOUNDARY
 'aoffl = sc->aoffl '1  LOCAL OFFSET
 'aoffs = sc->aoffs '2  STATIC OFFSET
  asce  = sc->asce  '3  ASCENDING / DESCENDING ALLOCATION 
  lclv  = sc->lclv  '5  LOCAL
  spe   = sc->spe   '6  STRING POOL END
  ixb   = sc->ixb   '7  ARRAY INDEX BASE
  sr2   = sc->sr2   '8  STATEMENT SEPARATOR 2 (: OR ;)
  ct2   = sc->ct2   '9  COMMENT MARKER 2 (;)
  tys   = sc->tys   '10 SPECIFIED DEFAULT TYPE
  '
  if lclv then aoff=aoffl else aoff=aoffs 'RESTORE PRIOR LOCAL ALLOCATION
  regs=sregs(brc)
  brc-=1
  if brc<0 then
    brc=0
    ers="Too many right brackets (..))" : ert=10
  end if
  'HASH TABLES BACKWARD DISALLOCATION
  for a=e to me step -1
    b=mach(a).l 'PREVIOUS RECORD
    c=mach(a).h and 511 'SHORT HASH
    macb(c)=b
  next
end sub


'--------------
sub localvars()
'==============
 if lclv then
   aoffl=aoff
 else
   aoffs=aoff : regs=regsl
 end if
 lclv=1 : aoff=aoffl : asce=-1
end sub


'--------------
sub staticvars()
'==============
 if lclv then
   aoffl=aoff : regs=regss
 else
   aoffs=aoff
 end if
 lclv=0 : aoff=aoffs : asce=1
end sub


'-------------------------------------------
function signedhex(byval d as sys) as string
'===========================================
  if d>0 then
    function="+0x"+hexci(d)
  elseif d<0 then
    function="-0x"+hexci(-d)
  end if
end function


'------------------------------------------------------------
function memreg(byref rg as string, byval d as sys) as string
'============================================================
  function="["+rg+signedhex(d)+"]"
end function


'---------------------------------------------------------------
function memregadj(byref mr as string, byval d as sys) as string
'===============================================================
  dim as sys a,b,c,e
  dim as string en="]"
  if asc(mr,len(mr))<=13 then en+=cr
  a=instrevn(-1,mr,"[")
  if isn(asc(mr,a+1)) then
    'adjust absolute addr
    c=a
    e=wval(mid(mr,c+1))
    return left(mr,c)+"0x"+hex(d+e)+en
  else
    c=instr(a,mr,"*") 'index multiplier: *1 *2 *4 *8
    if c then c+=2 else c=5
  end if
  a=asc(mr,c)
  e=wval(mid(mr,c+1))
  if a=45 then e=-e
  return left(mr,c-1)+signedhex(d+e)+en
end function



'---------------------------
function newstatvar() as sys
'===========================
  if lclv then
    function=aoffs : aoffs+=cpuw
  else
    function=aoff : aoff+=cpuw : aoffs=aoff
  end if
end function


'-----------------------------------------------
function newstatvarStr(byref p as sys) as string
'===============================================
  p=NewStatVar()
  return memreg(regss,p)
end function


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




'--------------------------------------------------
function addlproc(pd as sys,wa as string) as string
'==================================================
  '
  'FORMAT : o2 ( ...02 h?xxxxxxxx `name` 00 ...
  '
  '
  dim as sys a,b,c,d,e,lw
  dim as string wr,w1
  '
  'SELECT LIB BUFFER
  '-----------------
  '
  c=libu(pd)    'LIB BUFF USED
  w1="`"+wa+"` 00" 'LOCATE ALIAS
  '
  '
  'CHECK IF ALREADY PRESENT
  '------------------------
  '
  d=instr(libl(pd),w1)
  '
  if (d>0)and(d<c) then
  'EXTRACT PREVIOUS VECTOR
    a=instrevn(d-2,libl(pd),"h")+2
    return "["+qebx+"+0x"+yword(libl(pd),a)+"]"
  end if
  '
  'OTHERWISE CREATE NEW STATIC VAR
  '-------------------------------
  '
  a=newstatvar()
  '
  'CREATE A NEW VECTOR
  '-------------------
  '
  if cpuw=4 then
    wr="02 hl"+hexci(a)+" "+w1+cr 'LINK DATA
  else 'cpuw=8
    wr="02 hq"+hexci(a)+" "+w1+cr 'LINK DATA
  end if
  '
  lw=len(wr)
  '
  '
  'EXTEND BUFFER IF NEEDED
  '-----------------------
  '
  e=len(libl(pd))
  if e<c+lw+1 then libl(pd)+=space(2048)
  '
  '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(byref s as string) as string
'==============================================
dim as string wr
if len(s)=0 then exit function
tmpi+=1 : wr="_code"+str(tmpi)
newrecord(wr)
if ert then exit function
macsi(s,me,1)
maco(me,0)=-21
addme
s=""
return wr
end function

