 

  'COMPILILING WITH FREEBASIC 1.05 (32bit Windows)
  'fbc -dll Oxygen.bas
  '
  '
  #define datetimestamp "2018-09-01 T 13:43:10"
  #define version "B0 "+datetimestamp
  '
  '
  'INTERFACE GROUP
  '===============
  '
  #include "o2cmpl.bas" 'COMPATIBILITY & SYSTEM CALLS
  #include "o2runt.bas" 'RUN-TIME LIBRARY
  #include "o2glob.bas" 'GLOBAL STRUCTURES, CONSTANTS & VARIABLES
  '
  'PARSING GROUP
  '=============
  '
  #include "o2lexi.bas" 'LEXING
  #include "o2reco.bas" 'RECORDS
  #include "o2pars.bas" 'PARSING
  '
  'LANGUAGE GROUP
  '==============
  '
  #include "o2meta.bas" 'META-PROGRAMMING
  #include "o2decl.bas" 'DECLARATIVES
  #include "o2enco.bas" 'ENCODING FUNCTIONS
  #include "o2expl.bas" 'LOWER EXPRESSIONS
  #include "o2expr.bas" 'HIGHER EXPRESSIONS
  #include "o2keyw.bas" 'KEYWORDS
  #include "o2sema.bas" 'SEMANTIC LAYER
  #include "o2tran.bas" 'TOP TRANSLATION LAYER
  '
  'HEADERS ASSEMBLY AND LINKAGE GROUP
  '==================================
  '
  #include "o2hdrs.bas" 'HEADERS FOR EXECUTABLE CODE
  #include "o2assm.bas" 'ASSEMBLER (TO O2 MACHINE SCRIPT)
  #include "o2link.bas" 'O2 MACHINE SCRIPT LINKER
  '
  '
  '
  'DLL FUNCTIONS
  '=============
  '
  'for compiling and executing
  '
  '
  'EXTERNAL
  '--------
  '
  #ifdef OS_MS
    Extern "Windows-MS"
  #else
    extern "C"
  #endif

  declare Function o2_abst     alias "o2_abst"     (byval isrc as any ptr) as sys
  declare Function o2_asmo     alias "o2_asmo"     (byval isrc as any ptr) as sys
  declare Function o2_basic    alias "o2_basic"    (byval isrc as any ptr) as sys
  declare Function o2_buf      alias "o2_buf"      (byval p as sys) as sys
  declare Function o2_errno    alias "o2_errno"    () as sys
  declare Function o2_error    alias "o2_error"    () as sys
  declare Function o2_exec     alias "o2_exec"     (byval p as sys) as sys
  declare Function o2_len      alias "o2_len"      () as sys
  declare Function o2_lib      alias "o2_lib"      () as sys
  declare Function o2_link     alias "o2_link"     (byval isrc as any ptr) as sys
  declare Sub o2_mode          alias "o2_mode"     (byval m as sys)
  declare sub o2_pathcall      alias "o2_pathcall" (byval p as sys)
  declare Function o2_prep     alias "o2_prep"     (byval isrc as any ptr) as sys
  declare sub o2_varcall       alias "o2_varcall"  (byval p as sys)
  declare Function o2_version  alias "o2_version"   () as sys
  declare Function o2_view     alias "o2_view"     (byval isrc as any ptr) as sys


'set callback to obtain host variable location, by name
'--------------------------------------------------------
sub o2_varcall alias "o2_varcall" (byval p as sys) export
'========================================================
  pvarcall=p
End Sub


'set callback to obtain hosted oxygenBasic path string
'----------------------------------------------------------
sub o2_pathcall alias "o2_pathcall" (byval p as sys) export
'==========================================================
  pPathCall=p
End Sub


'specify string mode for various o2 API functions
'0 ascii char*
'1 ascii char*
'2 unicode wchar*
'8 ole bstring ascii
'9 ole bstring ascii
'10 ole bstring unicode
'--------------------------------------------------
sub o2_mode alias "o2_mode" (byval m as sys) export
'==================================================
  omo=m
End Sub

'return length of code in current binary code buffer
'----------------------------------------------
Function o2_len alias "o2_len" () as sys export
'==============================================
  Function = lbuf
End Function


'select current binary code buffer and return pointer
'------------------------------------------------------------
Function o2_buf alias "o2_buf" (byval p as sys) as sys export
'============================================================
'
  if (p>511)or(p<0) then
    p=0: ers=" Buffer number out of range (0..511): "+str(p): p=0
  end if
  ibuf=p
  lbuf=len(dbuf(ibuf)) : pbuf = strptr(dbuf(p))
  function=cast(long,pbuf)
End Function


'return base location of o2 runtime function table
'----------------------------------------------
Function o2_lib alias "o2_lib" () as sys export
'==============================================
  function=cast(long,psysfuns)
end function


'execute inary code in current buffer (or from location specified by pointer
'--------------------------------------------------------------
Function o2_exec alias "o2_exec" (byval p as sys) as sys export
'==============================================================
  '
  if pef then return 0 'EXCLUDE (AFTER MAKING A PE FILE)
  '
  'NUL PROGRAM GIVEN A SINGLE RET INSTRUCTION
  '------------------------------------------
  '
  if p=0 then
    if lbuf=0 then
      dbuf(ibuf)=chr(&hc3) 'RET
      lbuf=1
      pbuf=strptr(dbuf(ibuf))
    end if
    p=cast(long,pbuf)
  end if
  '
  asm
  mov ecx,[p]                        'ADDRESS OF CODE
  cmp dword ptr [ecx],&h00905A4D     'DOS  `MZ` SIGNATURE: `MZ` 90 00
  jnz npef                           'SKIP IF NOT PE
  add ecx,&hff0                      'MOVE o2 ENTRY POINT
  npef:                              '
  mov ebx,[psysfuns]                 'BASE ADDRESS OF RUNTIME FUNCTION TABLE
  call ecx                           'CALL CODE
  mov [function],eax                 'RETURN DATA
  end asm
  '
End Function


'compile o2 machine script to binary and return pointer
'---------------------------------------------------------------------
Function o2_link alias "o2_link" (byval isrc as any ptr) as sys export
'=====================================================================
  '
  dim as sys p,i
  gsco=istr_to_fstr(isrc)
  i=1
  dbuf(ibuf)=hexlink()
  lbuf=len(dbuf(ibuf)) : pbuf=strptr(dbuf(ibuf))
  p = fstr_to_ostr( pbuf, lbuf )
  pbuf=cast(any ptr,p)	
  Function = p
End Function


'---------------
sub o2_compile()
'===============
  dim as sys a,le
  dim as string s,w1,w2
  psysfuns=@sysfuns(0) 'RESTORE ORIGINAL RUNTIME FUN TABLE PTR 'itr multi progs
  gsco=""
  '
  linemark(gsrc)
  'tranpass=1
  'if dep=0 then
  '  preprocess(gsrc)
  '  if ert then goto nCompileErr
  'end if
  '
  declist="" : dlistend=1
  tranpass=2 'WITHOUT UNUSED DECLARE
  proclist="" : plistend=1 'LIST OF PROCEDURES WHICH MAY BE REMOVED IF UNUSED
 'calllist="" : clistend=1 'LIST OF FORWARD REFS TO THE PROCLIST
  translate()
  if compact then
    a=len(t)
    markused(t,a)
    compact=0
    if ert then goto nCompileErr
    tranpass=3 'EXCLUDING ANY UNUSED PROCEDURES
    translate()
  end if
 '
  nCompileErr:
  '
  tranpass=0
  '
  '
  if ert=0 then
    'PARTIAL VIEW
    if (vew=3)and(vwb<>0) then 'COMPILE TO INTERMEDIATE CODE OR ASSEMBLY CODE
      le=len(t)
      if vwe=0 then vwe=le+1 else vwe=instr(t,"#endv"+cr)+7
      vwb=instr(t,"#view"+cr)
      t=mid(t,vwb,vwe-vwb) 'CLIPPED VIEW
    end if
    '
    'CONSTANTS BINDING
    if vwb=0 then
      w1=enc("mk 1")+bindlprocs()+enc("mk 0")
      w2=left(dats,dati)
      w1+=enc("td "+hexci(dati)+" "+chr(34)+w2+chr(34))
      t=w1+t
    end if
    dati=0
    if abst=0 then t=itran(t) 'PRODUCE ASSEMBLY CODE
    if vew=3 then gsco=t : exit sub 'RETURN INTERMEDIATE OR ASM CODE
    t=prepexec()
    s=t
    nest()
    restore x86_registers
    Intrinsics()
    gsco=assemble(s) 'PRODUCE MACHINE SCRIPT
    unnest()
  else
    if vew=3 then
      gsco="Preprocessor error:"+cr+ers+cr+s+cr
    else
      gsco="c3"
    end if
  end if
end sub


'---------
sub o2_a()
'=========
  dim as sys le
  dim as string s
  '
  ert=0 : ers="" : vwb=0 : vwe=0
  '
  o2_compile()
  if vew then
    vew=0 : exit sub 'SCRIPT CODINGS
  end if
  '
  if ert=0 then
    dbuf(ibuf)=HexLink() 'PRODUCE EXECUTABLE BINARY
  else
    dbuf(ibuf)=chr(&hc3) 'DEFAULT RET INSTRUCTION
  end if
  '
  '
  'FILING AN EXE OR DLL
  '--------------------
  '
  if ert=0 then if pef then makePE(pexn,dbuf(ibuf)) 'PRODUCE PE FILE FROM BINARY
  '
  '
  lbuf=len(dbuf(ibuf)) : pbuf=strptr(dbuf(ibuf))
  '
End Sub


'----------------------------------------------
sub o2_as alias "o2_as" (byval isrc as any ptr)
'==============================================
  '
  gsrc=istr_to_fstr(isrc)
  o2_a()
End Sub


'compile source code string to binary code, and return pointer
'---------------------------------------------------------------------
function o2_asmo alias "o2_asmo" (byval isrc as any ptr) as sys export
'=====================================================================
  '
  o2_as(isrc) 'o2h default is now 1 (basic syntax supported)
  return cast(long,pbuf)
End Function


'compile source code string to binary code, and return pointer
'-----------------------------------------------------------------------
function o2_basic alias "o2_basic" (byval isrc as any ptr) as sys export
'=======================================================================
  '
  o2_as(isrc)
  return cast(long,pbuf)
End Function


'-------------------------------------------
Function O2_Vp(byval isrc as any ptr) as sys
'===========================================
  '
  gsrc=istr_to_fstr(isrc)
  o2_a()
  return fstr_to_ostr( strptr(gsco),len(gsco))	
End Function


'compile source code string and return o2 machine script string
'---------------------------------------------------------------------
Function o2_view alias "o2_view" (byval isrc as any ptr) as sys export
'=====================================================================
  vew=2 : return O2_Vp(isrc)
End Function


'compile source code string and return assembly code string
'---------------------------------------------------------------------
Function o2_prep alias "o2_prep" (byval isrc as any ptr) as sys export
'=====================================================================
  vew=3 : return O2_Vp(isrc)
End Function


'compile source code string and return intermediate code string
'---------------------------------------------------------------------
function o2_abst alias "o2_abst" (byval isrc as any ptr) as sys export
'=====================================================================
  '
  abst=1 : vew=3 : return O2_Vp(isrc) : abst=0
End Function



'return error number, if any
'--------------------------------------------------
Function o2_errno alias "o2_errno" () as sys export
'==================================================
  '
  return ert
  '	
End Function


'return compiling error string, if any
'--------------------------------------------------
Function o2_error alias "o2_error" () as sys export
'==================================================
  '
  return fstr_to_ostr( strptr(ers), Len(ers) )
  '	
End Function


'return version string, include time/datestamp
'------------------------------------------------------
Function o2_version alias "o2_version" () as sys export
'======================================================
  '
  static as string v
  v=version
  return fstr_to_ostr( strptr(v), Len(v) )
  '	
End Function





'==============================================================
'THE COMPILE FUNCTIONS ARE NOT AVAILABLE IN STANDALONE BINARIES
'==============================================================



'--------------------------------------------------------------
function compile(byval srcBSTR as BSTR, byval dp as sys) as sys
'==============================================================
  '
  dim as string  cod,s
  dim as any ptr p
  dim as sys    ert
  bstr_to_fstr(srcBSTR,gsrc)
  dep=1
  gsrc=sp+gsrc+ep 'CONFINE SCOPE
  o2_compile()    'PARENTAL STATE BUT RESTRICTED SCOPE
  '
  if vew=0 then
    cod=HexLink()
  else
    cod=gsco
  end if
  '
  vew=0
  dep=0
  '
  function = cast (long, AllocString(strptr(cod), len(cod) ) )
  '
end function




'------------------
sub sysfuns_build()
'==================

'This procedure is called from DLLmain when Oxygen is loaded.
'It builds an address table and storage area for the runtime library.
'This table is copied into bssdata area for each compiled binary as part
'of the compiled binary's setup when it is called.

'In independent mode the entire build process must be handled by the Executable
'which contains all the run-time functions required.



psysfuns=@sysfuns(0)


#ifdef freebasic

'===============================================
'O2
'===============================================
    sysfuns(00)=@psysfuns              '000 'POINTER TO ALLOW CHANGE OF PSYSFUNS
    sysfuns(02)=@getmem                '008 'NEWS
    sysfuns(04)=@freemem               '016 'FREES
    sysfuns(06)=@LoadLibrary           '024 'LOADLIBRARY
    sysfuns(08)=@FreeLibrary           '032 'FREELIBRARY
    sysfuns(10)=@GetProcAddress        '040 'GETPROCADDRESS
   'sysfuns(12)=@procaddrs             '048 'BIND (indirectly) 'obsolete
    sysfuns(14)=@copy0                 '056 'COPY0
    sysfuns(16)=@copy00                '064 'COPY00
    sysfuns(18)=@copyn                 '072 'COPY COPYN
    sysfuns(20)=@getvarptr             '080 'O2 GET HOST VAR ADDRESS
   'sysfuns(22)=@strd                  '088 'obsolete
   'sysfuns(24)=@vald                  '096 'obsolete
'===============================================

'UNUSED 104 112 120


'===============================================
'O2H
'===============================================
    sysfuns(32)=@errors                '128
    sysfuns(40)=@SysAllocStringByteLen '160  **
    sysfuns(42)=@SysFreestring         '168  **
    sysfuns(48)=@ascii_to_float        '192 replace @vals
    sysfuns(50)=@float_to_ascii        '200 replace @strs
    sysfuns(52)=@hexs                  '208
    sysfuns(54)=@hexsl                 '216
    sysfuns(80)=@instrsh               '320
'   sysfuns(82)=@replaces              '328 unused
    sysfuns(84)=@getfiles              '336
    sysfuns(86)=@putfiles              '344
    sysfuns(88)=@guidval               '352
    sysfuns(90)=@guidtxt               '360
    sysfuns(92)=@compile               '368
'===============================================

'UNUSED:
'136 144 152 176 184
'224 232 240 248 256 264 272 280 288 296 304 312 328 376 384 392

'NOTE:
'** these must be preloaded for the import table in in dependent mode

'first 400 bytes will be copied to bss


#endif 'freebasic




'the following locations are used in independent mode

'===============================================
'RESERVED LOCATIONS FOR OS CALLS
'===============================================
   'sysfuns(110)=GetModuleHandle       '440  **
   'sysfuns(112)=GetCommandLine        '448  **
   'sysfuns(114)=GetExitCodeProcess    '456  **
   'sysfuns(116)=ExitProcess           '464  **
   'sysfuns(118)=MessageBoxA           '472  **
   'sysfuns(120)=CreateFileA           '480  **
   'sysfuns(122)=ReadFile              '488  **
   'sysfuns(124)=CloseHandle           '496  **
   'sysfuns(126)=MessageBoxW           '504  **
'===============================================
'NOTE:
'** these must be preloaded for the import table in in dependent mode


'the following locations are available in all modes
'but primarily used in oxygen dependent mode.
'They are initialised in the Basic prolog.

'===============================================
'RESERVED LOCATIONS FOR HANDLES
'===============================================
   '             bootstrap lib base    '600  **
   '             process handle        '608  ** 0
   '             oxygen lib handle     '616  ** 0
   '             OxygenLibBaseEBX      '624  **
'===============================================


'the following locations are used in all modes

'===============================================
'RESERVED LOCATIONS FOR BUFFER POINTERS etc
'===============================================
   'STRING CAT LIST                    '640
   'STRING TEMPS                       '648
   'STRING LOCALS                      '656
   'STRING GLOBALS                     '664
   '---------------------------------------
   'DLL BINDING DATA POINTER           '672
   'DLL HANDLE LIST                    '680
   'STRING POOL                        '688
'===============================================




'STRING POOL RECORD / HELD IN BSTRING
'===============================================
   'STRING LBOUND                      '0O
   'STRING NEXT AVAIL                  '04
   'STRING ALLOCATION UNIT SIZE        '08
   'STRING STACK POINTER               '12
   '
'===============================================





'------------------------
 ' add naked procs &h400+
'========================
    asm
      mov ecx,2048 ' 512.. 
      add ecx,[psysfuns]
      call mapruntimes
      'mov eax,[psysfuns]
      'sub ecx,eax
      'mov [eax],ecx ' next available place in table
    end asm
'=================================

'when combirs=1:
'2048-4095 bytes will be copied to bss+2048 to bss+4095

end sub





'for FB 0.20 and above



'---------------------
sub ctor() constructor
'=====================
    '
    'SETTINGS ON ENTRY
    '-----------------
    '
    'STRING AND CHARACTER MODE
    '
    #ifdef OS_MS
      omo=8 'BSTR 8bit character (+2=16 BIT character)  
    #else
      omo=0
    #endif
    '
    pvarcall=0 'callback for host var pointers. Set by o2_varcall
    '
    'BUILD RUNTIME TABLE (functions for runtime use)
    '
    sysfuns_build()
    '
    'NUMBER FORMAT CONTROL
    '
    num.dp =16 ' DECIMAL PLACES
    num.trz= 1 ' STRIP TRAILING ZEROS
    num.sn = 0 ' SCIENTIFIC NOTATION BY DEFAULT
    num.sdp= 0 ' INHIBIT ZERO BEFORE DECIMAL POINT
    '
    'RootDir=space(256)
    'dim as zstring ptr FilePart
    'GetFullPathNameA("Oxygen.dll",256,RootDir,FilePart)
    '
end sub


'--------------------
sub dtor() destructor
'====================
    'print "process detach"
end sub


End Extern
