

'FreeBasic App Hosting Embedded OxygenBasic
'==========================================

'Charles Pegge
'22:06 18/06/2014


'FB compiling:
'fbc -s gui FBHost.bas


  
  '------------
  'SELECTED API
  '============
  '
    '#include once "windows.bi"
    '#include once "win/ole2.bi"
    '
    #define DLL_PROCESS_ATTACH   1
    #define DLL_THREAD_ATTACH    2
    #define DLL_THREAD_DETACH    3
    #define DLL_PROCESS_DETACH   0
    #define DLL_PROCESS_VERIFIER 4
    #define sys Long
    Type HWND As sys
    Type HMODULE As sys
    Type HINSTANCE As sys
    Type BOOL As sys
    Type UINT As sys
    Type DWORD As sys
    Type BSTR As Any Ptr
    Type FARPROC As Any Ptr
    Type PVOID As Any Ptr
    Type PCVOID As Any Ptr
    Type PLONG As Long Ptr
    Type PDWORD As dword Ptr
    Type LPCSTR As Zstring Ptr
    Type LPSECURITY_ATTRIBUTES As Any Ptr
    Type LPOVERLAPPED As Any Ptr
    Type HANDLE As sys
    #define iostring bstr
    '
  Extern "windows" lib "kernel32"
    Declare Function ReadFile ( _
      As HANDLE, _
      As PVOID,  _
      As DWORD,  _
      As PDWORD,  _
      As LPOVERLAPPED) As BOOL
    Declare Function WriteFile ( _
      Byval As HANDLE, _
      As PCVOID,  _
      As DWORD,  _
      As PDWORD, _
      As LPOVERLAPPED) As BOOL
    Declare Function LoadLibrary Alias "LoadLibraryA" ( _
      As LPCSTR) As HINSTANCE
    Declare Function CreateFile Alias "CreateFileA" ( _
      As LPCSTR, _
      As DWORD, _
      As DWORD, _
      As LPSECURITY_ATTRIBUTES, _
      As DWORD, _
      As DWORD, _
      As HANDLE) As HANDLE
    Declare Function FreeLibrary(Byval As HMODULE) As BOOL
    Declare Function GetProcAddress( _
      As HINSTANCE, _
      As LPCSTR) As FARPROC
    Declare Function GetFileSize ( _
      As HANDLE, _
      As PDWORD) As DWORD
    Declare Function SetFilePointer( _
      As HANDLE, _
      As Long, _
      As PLONG, _
      As DWORD) As DWORD
    Declare Function CloseHandle( _
      As HANDLE) As BOOL
  End Extern

  Extern "windows" lib "oleaut32"
    Declare Function SysAllocStringByteLen ( _
      As Zstring Ptr, _
      As Uinteger) As BSTR
    Declare Sub SysFreeString (Byval As BSTR)
  End Extern

  Extern "windows" lib "user32"
    Declare Function MessageBox Alias "MessageBoxA" ( _
      As HWND, _
      As LPCSTR, _
      As LPCSTR, _
      As UINT) As Integer
  End Extern
    #define AllocString(p,le) SysAllocStringByteLen(p,le)
    #define FreeString(p) SysFreeString(p)
    #define Library(s) LoadLibrary(s)
    #define FreeLibr(a) FreeLibrary(a)
    #define ProcAddr(a,b) GetProcAddress(a,b)


  extern "windows-MS" lib "oxygen"

  declare sub      o2_mode  (byval m as long)
  declare function o2_abst  (byval p as zstring ptr) as zstring ptr
  declare function o2_basic (byval p as zstring ptr) as long
  declare function o2_exec  (byval addr as long) as long
  declare function o2_buf   (byval n as long) as long
  declare function o2_errno () as long
  declare function o2_error () as zstring ptr
  declare function o2_len   () as long
  declare function o2_prep  (byval p as zstring ptr) as zstring ptr
  declare function o2_view  (byval p as zstring ptr) as zstring ptr

  end extern

  extern "windows" lib "kernel32"

  declare FUNCTION GetCommandLine ALIAS "GetCommandLineA" () AS zstring ptr

  end extern

  const as string qu=chr(34)
  const as string tb=chr(9)
  const as string cr=chr(13)+chr(10)

  dim shared as string prs

  '--------------------------
  sub pri(byval s as string)
  '==========================
  prs+=s+cr
  print s+cr
  end sub


  '-------------------------------------------------------------------
  sub ExtensName(s as string, mnm as string, xnm as string, i as long)
  '===================================================================
    'including dot
    dim as sys le
    le=len(s)
    i=le+1
    do
      i-=1
      if i<0 then exit do
      if asc(s,i)=46 then exit do
    loop
    '
    if i then
      mnm=left(s,i-1)
      xnm=mid(s,i)
    else
      mnm=s
    end if
    '
  end sub




  '====
  'main
  '====


  dim z as zstring ptr 
  z=GetCommandLine

  'pri "Commandline: "+ *z

  
  dim as sys a,b,e,i,le,swa,swb,swc,swm
  dim as string n,s,t,u,mnm,xnm
  dim as zstring ptr er
  dim as any ptr p
  '
  n=ltrim(lcase(*z))

  '
  'SKIP COMMAND
  '
  a=asc(n)
  b=1
  if a=34 then
    b=instr(2,n,qu)
    b+=1
  end if
  '
  '
  'CHECK FOR PARAMETER FOLLOWING
  '=============================
  '
  a=instr(b,n," ")
  '
  if a=0 then
    n="" : goto nofile
  end if
  '
  n=mid(n,a+1)
  n=ltrim(n)
  '
  'STRIP QUOTES ON FILENAME
  '========================
  '
  if asc(n)=34 then
    b=instr(2,n,qu)
    if b then n=mid(n,2,b-2)
  end if

  '
  n=ltrim(n)
  '
  '
  'SWITCHES
  '========
  do
    if asc(n)=45 then
      a=asc(n,2)
      n=ltrim(mid(n,3))
      if a=&h69 then swa=a '-i intermediate output
      if a=&h61 then swa=a '-a o2 output
      if a=&h62 then swa=a '-b o2 output
      if a=&h63 then swc=a '-c compile
      if a=&h6d then swm=a '-m show messagebox
    else
      exit do
    end if
  loop
  '
  '-------------
  nofile: 'check
  '=============
  '
  n=rtrim(n)
  '
  if len(n)=0 then
    prs="compiler options:"+cr+_
        "<filename>       compile and execute directly in memory"+cr+_
        "-a <filename>    list assembly code"+cr+_
        "-b <filename>    list o2 machine script"+cr+_
        "-c <filename>    compile to an executable file"+cr+_
        "-i <filename>    list intermediate code"+cr+_
        "-m               suppress message box"+cr+_
        ""
    goto finish
  end if

  '
  'CHECK FOR .BAS EXTENSION NAME
  '=============================
  '
  s=n 'accept any
  '
  ExtensName(s,mnm,xnm,i)
  '
  'ATTEMPT TO GET FILE
  '===================
  '
  open s for binary access read as 2
  le=lof(2)
  t=string(le,chr(0))
  get #2,,t
  close 2
  '
  u="#basic"+cr
  '
  if swc then
    u+="#file "+qu+mnm+".exe"+qu+cr
  end if
  '
  
  '
  if t="" then
    pri "error 3: file empty or not found: "+s
    goto finish
  end if
  '
  t=u+chr(12)+t : p=strptr(t)
  '
  '
  'NORMAL COMPILE
  '==============


  o2_mode(0) 'read/return null terminated ascii strings
  '
  select case swa
  case &h61   : prs = *o2_prep(p)
  case &h69   : prs = *o2_abst(p)
  case &h62   : prs = *o2_view(p)
  case else   :        o2_basic(p) 'compile string
  end select
  '
  er=o2_error()
  '
  if len(*er) then
    pri cr+ *er
    goto finish
  else
    if swc=0 then o2_exec(0) else pri cr+"Okay"
    goto xfinish
  end if

  finish:
  '------


  xfinish:
  '-------

  if len(prs) then
    if swm=0 then messagebox 0,prs,"o2",0
  end if

