  indexbase 0


uses oxykeywords

'LEXING OPERATIONS

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

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

int    iqi=252        'INTERNAL QUOTE CODE
wstring iq=wchr(iqi)    'INTERNAL QUOTE MARK

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

int qot  'qoute flag
int nmb  'number flag

wstring ers 'error
int    ert 'error number



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



function asclc(int a ) as int
=============================
select a
case  0x41 to 0x5a : a+=32
end select
function=a
end function


function ascl(wstring*s, int*i) as int
======================================
  '
  function=asclc(asc(s,i))
  '
end function


sub endline(wstring s, int*i)
=============================
  word bb at strptr(s)-2
  do
    ascn=bb[i]
    select ascn
    case  0 : exit do
    case 10 : exit do
    case 13 : exit do
    end select
    i++
  loop
  nwd=i
end sub


sub nextspace(wstring*s, int*i)
===============================
  word bb at strptr(s)-2
  int q
  do
    select bb[i]
    case 0 to 32 : exit sub
    end select
    i++
  loop
end sub






'QUOTEMARK

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


macro isq int (r,a)
===================
  mov eax,a
  call isq_asm
  #snip
  mov r,eax
end macro
'
isq_asm:
(
cmp eax,iq1 : jz exit
cmp eax,iq2 : jz exit
cmp eax,iqi : jz exit
mov eax,0 : ret
)
mov eax,-1  : ret
'
macro isn int (r,a)
====================
   mov eax,a
   call isn_asm
   #snip
   mov r,eax
end macro
'
macro isa int (r,a)
====================
   mov eax,a
   call isa_asm
   #snip
   mov r,eax
end macro
'
macro isw int (r,a)
===================
   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:
========
(
 cmp eax,0x30 : jl exit
 cmp eax,0x39 : jg exit
 mov eax,-1 : ret
)
(
 cmp eax,46 : jnz exit
 mov eax,1 : ret
)
isa_asm:
========
(
 cmp eax,0x41 : jl exit
 cmp eax,0x5a : jg exit
 mov eax,-3 : ret
)
(
 cmp eax,0x61 : jl exit
 cmp eax,0x7a : jg exit
 mov eax,-5 : ret
)
(
 cmp eax,0x7f : jl exit
 cmp eax,0xfc : jge exit '252-255 EXCLUDE SYSTEM SYMBOLS
 mov eax,-7 : ret        '127 and upper ascii
)
(
 cmp eax,95 : jnz exit
 mov eax,-9 : ret
)
(
 cmp eax,35 : jnz exit
 mov eax,-11 : ret
)
mov eax,0
ret

macro isxn int (r)
==================
  call isxn_asm
  #snip
  mov r,eax
end macro
'
macro nisxn int (r)
===================
  call isxn_asm
  not eax
  #snip
  mov r,eax
end macro
'
macro isx int (r,a)
===================
  mov eax,a
  call isx_asm
  #snip
  mov r,eax
end macro
'
macro iss int (r,a)
===================
  mov eax,a
  call iss_asm
  #snip
  mov r,eax
end macro
'
macro ise int (r,a)
====================
  mov eax,a
  call ise_asm
  #snip
  mov r,eax
end macro
'
macro isc int (r,a)
====================
  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)
===================
  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)
=====================
  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)
=====================
  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)
=======================
  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)
=====================
  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)
======================
  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)
======================
  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)
======================
  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)
======================
  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_
=======



sub skipspace(wstring*s, int*i)
===============================
  word bb at strptr(s)-2
  do
    ascn=bb[i]
    select ascn
    case 0 : exit do
    case 65 to 90 : ascn+=32 : exit do 'force lowercase
    case 33 to 0xffff : exit do
    end select
    i++
  loop
  nwd=i
end sub


sub skiplspace(wstring*s, int*i)
================================
  word bb at strptr(s)-2
  do
    ascn=bb[i]
    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 33 to 0xffff : exit do
    end select
    i++
  loop
  nwd=i
end sub


sub skipquote(wstring*s, int*i)
===============================
  word bb at strptr(s)-2
  int a,b
  'skip quoted expression
  b=bb[i]
  do
    i++
    a=bb[i]
    select a
    case 0  : exit sub
    case b  : exit do
    end select
  loop
  i++
end sub


function yword(wstring*s, int*i) as wstring
===========================================
  word bb at strptr(s)-2
  skipspace(s,i)
  swd=i
  do
    ascn=bb[i]
    select ascn
    case 0 to 32 : exit do
    case 34 : i=instr(i+1,s,wchr(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


function wrd(wstring*s, int*i) as wstring
=========================================
  wstring wr
  int a,b,c,d,ls
  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
  word bb at strptr(s)-2
  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(l"0123456789abcdef",wchr(d))
          if (a=0)or(a>b)
            if (i>swd+2)and((d<48)or(isx(d)<>0))
              mid(s,swd)=l"0"+wchr(c) : ascw=48
              nmb=9
            else
              i=swd+1 '&' address symbol
            endif
            goto exitw
          endif
        loop
      else
        goto exitw
      endif
    case iq1,iq2,iqi : a=-1
    end select
    '
    if a=-1 'QUOTED TEXT
      wstring wk=wchr(ascw)
      a=instr(i,s,wk)
      if a
        i=a : qot=1
      else
        ers="Unclosed quote" : 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 '.'
      if dtf=0
        dtf=i-swd+1
      endif
      a=bb[i+1]
      if (a>=48)and(a<=57)
        if dtf=1
          nmb=1
        endif
      elseif a=34 'SUPPORT QUOTED DOT NAME ."+"
        a=instr(i+2,s,wchr(34))
        if a
          i=a+1
        else
          ers="Unclosed quote" : ert=502
        endif
        goto exitw
      endif
      i++ : continue do
    case 45 '-'
      if bb[i+1]=62 '->' ARROW cpointer
        if dtf=0
          dtf=i-swd+1
        endif
        'mid(s,i)=l"."
        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 ':: NAMESPACE CONNECTOR
        i+=2 : continue do
      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
      'ascy
      select a
      case 34
      case 33 to 38,63
        i++
        continue do
      end select
      exit do
    endif
    '
  loop
  '
  exitw:
  ======
  '
  lenw=i-swd
  skiplspace(s,i)
  if lenw>0
    function=mid(s,swd,lenw)
    'if ert=463
    '  ers=l"$%? endings "+mid(s,swd,lenw)
    '  ert=464
    'endif
  endif
end function


function LowerCase(wchar *s)
============================
  'conversion of roman chars: uppercase to lowercase
  'LowerCase(gs)
  word c at strptr(s)
  do
    exit if c=0
    select c
      case 0x41 to 0x5a : c or= 0x20
    end select
    @c+=2
  loop
end function

 


#define CFE_BOLD	1
#define CFE_ITALIC	2
#define CFE_UNDERLINE	4
#define CFE_STRIKEOUT	8
#define CFE_PROTECTED	16
#define CFE_AUTOCOLOR	0x40000000
#define CFE_SUBSCRIPT	0x00010000
#define CFE_SUPERSCRIPT	0x00020000

#define SCF_DEFAULT	0
#define SCF_SELECTION	1
#define SCF_WORD	2
#define SCF_ALL	4
#define SCF_USEUIRULES	8

#define SF_TEXT	1
#define SF_RTF	2
#define SF_RTFNOOBJS	3
#define SF_TEXTIZED	4
#define SF_UNICODE	16
#define SF_USECODEPAGE	32
#define SF_NCRFORNONASCII	64
#define SF_RTFVAL	0x0700
#define SFF_PWD	0x0800
#define SFF_KEEPDOCINFO	0x1000
#define SFF_PERSISTVIEWSCALE	0x2000
#define SFF_PLAINRTF	0x4000
#define SFF_SELECTION	0x8000


#define WM_USER     0x0400
#define LF_FACESIZE 32

#define EM_GETCHARFORMAT	(WM_USER+58)
#define EM_SETCHARFORMAT	(WM_USER+68)
#define EM_EXGETSEL	(WM_USER+52)
#define EM_EXSETSEL	(WM_USER+55)
#define EM_GETSELTEXT	(WM_USER+62)
#define EM_HIDESELECTION	(WM_USER+63)

#define EM_STREAMIN	(WM_USER+73)
#define EM_STREAMOUT	(WM_USER+74)
#define EM_GETTEXTRANGE	(WM_USER+75)


typedef dword COLORREF ' R G B bytes
typedef dword LCID
typedef sys   LPWSTR

'92 bytes
typedef struct _charformatw {
	UINT cbSize;
	DWORD dwMask;
	DWORD dwEffects;
	LONG yHeight;
	LONG yOffset;
	COLORREF crTextColor;
	BYTE bCharSet;
	BYTE bPitchAndFamily;
	WCHAR szFaceName[LF_FACESIZE];
} CHARFORMATW;

typedef struct _charformat2w {
	UINT cbSize;
	DWORD dwMask;
	DWORD dwEffects;
	LONG yHeight;
	LONG yOffset;
	COLORREF crTextColor;
	BYTE bCharSet;
	BYTE bPitchAndFamily;
	WCHAR szFaceName[LF_FACESIZE];
	WORD wWeight;
	SHORT sSpacing;
	COLORREF crBackColor;
	LCID lcidv;
	DWORD dwReserved;
	SHORT sStyle;
	WORD wKerning;
	BYTE bUnderlineType;
	BYTE bAnimation;
	BYTE bRevAuthor;
} CHARFORMAT2W;

typedef struct _charrange {
  LONG cpMin;
  LONG cpMax;
} CHARRANGE;

typedef struct _textrangew {
  CHARRANGE chrg;
  LPWSTR    lpstrText;
} TEXTRANGEW;

typedef struct _editstream {
  sys                dwCookie;
  DWORD              dwError;
  sys                pfnCallback;
} EDITSTREAM;

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


  string ubuf
  sys ubufp, ubufe, ubufl



  % ID_FIRSTCHILD  100 

   function Editstreamocallback(sys *dwCookie, pbBuff, cb, *pcb) as dword callback
  ================================================================================
  '  DWORD_PTR dwCookie,
  '  LPBYTE pbBuff,
  '  LONG cb,
  '  LONG *pcb
  '
  'ACCUMULATE OUTPUT
  if ubufl+cb>ubufe 'stretch buffer
    sys obufp
    obufp=ubufp
    ubufe=ubufe*2+cb+0x1000
    ubufp=getmemory ubufe
    if obufp
      copy ubufp,obufp,ubufl
      freememory obufp
    endif
  endif
  copy ubufp+ubufl,pbBuff,cb
  ubufl+=cb
  pcb=cb
  '
  return 0 'no errors
  end function


  function Editstreamicallback(sys *dwCookie, pbBuff, cb, *pcb) as dword callback
  ===============================================================================
  '  DWORD_PTR dwCookie,
  '  LPBYTE pbBuff,
  '  LONG cb,
  '  LONG *pcb
  '
  'PASS INPUT
  if ubufl<ubufe
    if cb>ubufe-ubufl
      cb=ubufe-ubufl
    endif
    copy pbBuff,ubufp+ubufl,cb
    ubufl+=cb
    pcb=cb
  else
    pcb=0
  endif
  return 0 'no errors
  end function


  function EdProc(sys hwnd, uMsg, wParam, lParam,uIdSubclass,dwRefData) as int callback
  =====================================================================================
  indexbase 0
  select uMsg
 
  case WM_HSCROLL

    DefSubClassProc(hwnd, uMsg, wParam, lParam)
    RECT r
    r.right = 40 'margin lie number area
    GetClientRect(hwnd,r)
    InvalidateRect(hwnd,r,0)

  case WM_PAINT
    point pt
    static wchar sz[32]
    DWORD lc
    RECT crect
    sys rgn
    int dret
    sys hDC
    int line
    int charidx
    'int nc

    function = DefSubClassProc(hwnd, uMsg, wParam, lParam)
    'exit function
    lc = SendMessageW(hWnd,EM_GETLINECOUNT,0,0)
    if lc
      hDC = GetDC(hWnd)
      SaveDC(hDC)
      GetClientRect(hWnd,&crect)
      rgn = CreateRectRgn(crect.left,crect.top,40,crect.bottom)
      SelectClipRgn(hDC,rgn)
      'SendMessageW(hWnd,WM_SETFONT,hfont,0)
      % PATCOPY 0x00F00021
      BitBlt(hDC,0,0,40,crect.bottom, hDC,0,0,PATCOPY)
      line = SendMessageW(hWnd,EM_GETFIRSTVISIBLELINE,0,0)
      while line <= lc
        charidx = SendMessageW(hWnd,EM_LINEINDEX,line,0)
        exit if charidx == -1
        SendMessageW(hWnd,EM_POSFROMCHAR,@pt,charidx)
        exit if pt.y >= crect.bottom
        'set line number
        'wsprintf(&sz,"%lu",line+1)
        SetTextColor(hDC,0xff0000) 'blue
        sz = str(line+1)
        TextOutW(hDC,4,pt.y+4,sz,len(sz))
        line++
      wend
      RestoreDC(hDC,-1)           
      DeleteObject(rgn)
      ReleaseDC(hWnd,hDC)
    endif
    return 1
  case else      
     return DefSubClassProc(hwnd, uMsg, wParam, lParam)
  end select
  end function
  
 
  function ColorText(sys h, int ofs, le, wchar*gs) as int
  =======================================================
  '
  'read each word
  int i=1
  'int c 
  int cw   
  int se[2]
  wstring wr
  'wstring ss
  wstring ds=gs
  word bb at strptr(ds)-2 'base 1
  wstring kk=OxyKeyWords
  word bk at strptr(kk)-2 'base 1
  '
  sys bw,ew
  int a,b,f,m,st,en,tc,w
  wstring k
  CHARFORMATW cf
  cf.cbsize = sizeof(cf)
  '
  do
    wr=wrd(ds,i)
    exit when lenw=0 or swd>le
    'c++
    if ascw=34 '"
      swd+=1
      lenw-=2
      cw=1
      tc=0xff00ff
    elseif ascw=96 '`
      swd+=1
      lenw-=2
      cw=1
      tc=0xff00ff
    elseif lenw=1
      select ascw
      case 39 'basic comment
        endline(ds,i)
        swd++
        lenw=i-swd
        cw=1
        tc=0x00ff00
      case 47 '/
        if bb[swd+1]=47 'c comment //
          swd+=2
          endline(ds,i)
          lenw=i-swd
          cw=1
          tc=0x00ff00
        elseif bb[swd+1]=42 '/ *
          swd+=2
          i=instr(i,ds,L"*/")
          if i=0
            i=len(ds)+1 'unclosed c comment
          endif
          lenw=i-swd
          cw=1
          tc=0x00ff00
        endif
      case 0x30 to 0x39 'exclude numbers
      case 0x41 to 0x5a 'exclude uppercase
      case 0x61 to 0x7a 'exclude lowercase
      case else '35,36,37,38,63,64
        cw=1
        tc= 0xf05020
      end select
    elseif lenw>1
      a=1
      do
        b=instr(a,kk,wr)
        if b=0
          exit do
        endif
        if b
          if bk[b-1]<33 and bk[b+lenw]<33 
            exit do
          endif
          a=b+1
          'continue do
        endif
      loop
      if b
        ss+=wr+cr
        cw=1
        tc= 0xf00040
      endif
    endif
    '
    if cw
      'set word color
      st=ofs+swd-1
      en=st+lenw
      se = {st,en}
      SendMessageW(h,EM_EXSETSEL,0,@se)
      SendMessageW(h,EM_GETCHARFORMAT,SCF_SELECTION,@cf)
      cf.dweffects and= not(CFE_AUTOCOLOR)
      cf.crTextColor = tc
      SendMessageW(h,EM_SETCHARFORMAT,SCF_SELECTION,@cf)
      cw=0
    endif
  loop
  '
  end function
 

/*

    SendMessageW(h,EM_HIDESELECTION,1,0)
    '
    'to extract visible text
    int lc
    int line
    int chx
    point pt
    GetClientRect(h,&crect)
    lc = SendMessageW(h,EM_GETLINECOUNT,0,0)
    line = SendMessageW(h,EM_GETFIRSTVISIBLELINE,0,0)
    se[0] = SendMessageW(h,EM_LINEINDEX,line,0)
    while line <= lc
      chx = SendMessageW(h,EM_LINEINDEX,line,0)
      exit if chx == -1
      SendMessageW(h,EM_POSFROMCHAR,@pt,chx)
      exit if pt.y >= crect.bottom
      se[1]=chx
      line++
    wend
    SendMessageW(h,EM_EXSETSEL,0,@se) 'select visible text
    int n=SendMessageW(h,EM_GETSELTEXT,0x20000,strptr(gs))
    'get visible text
    'ds = gs 'test
*/


/*
      'save richedit content to file
      ==============================
      int ecookie=0
      sys h=hchw[0]
      EDITSTREAM Streamout 
      StreamOut={@ecookie,0,@Editstreamocallback}
      SendMessageW(h,EM_STREAMOUT,SF_RTF,@StreamOut)
      dim bstring fdo
      (sys) fdo = ubufp
      fdo=left(fdo,ubufl)
      putfile("test.rtf",fdo)
*/




