Native FreeBASIC class as script class.
you can share your native classes with the VM.
Code: Select all
' nativeClassTest.bas
' test for native script class
#include once "crt.bi"
#include once "inc/squirrel.bi"
#include once "inc/sqstdlib.bi"
'#define debug
#ifdef DEBUG
#define DPRINT(txt) open err for output as #99:print #99,"dbg:"+txt:close #99
#else
#define DPRINT(txt) :
#endif
type Vector3
' script class helpers
declare function script_new(v as HSQUIRRELVM) as SQInteger
declare function script_push(v as HSQUIRRELVM,idx as SQInteger) as SQInteger
declare static function script_typetag(typetag as SQUserPointer=0) as SQUserPointer
' script class (all C calling)
declare static function script_typeof cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_tostring cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_constructor cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_destructor cdecl (p as SQUserPointer,size as SQInteger) as SQInteger
declare static function script_nexti cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_get cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_set cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_unm cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_add cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_sub cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_mul cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_div cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_modulo cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_length cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_distance cdecl (v as HSQUIRRELVM) as SQInteger
declare static function script_normalize cdecl (v as HSQUIRRELVM) as SQInteger
' native class
declare constructor(v as HSQUIRRELVM)
declare constructor(p as Vector3 ptr)
declare constructor(x as SQFloat,y as SQFloat,z as SQFloat)
declare destructor
union
type
as SQFloat x,y,z,w
end type
as SQFloat m(3)
end union
private:
declare sub ClassBegin (v as HSQUIRRELVM)
declare sub ClassMember(v as HSQUIRRELVM, _
sName as SQChar ptr, _
pFunc as SQFUNCTION, _
iCheck as SQInteger, _
sMask as SQChar ptr)
declare sub ClassEnd (v as HSQUIRRELVM)
end type
' create new Vector3 instance
function Vector3.script_new(v as HSQUIRRELVM) as SQInteger
sq_pushroottable(v)
sq_pushstring(v,"Vector3",-1) ' push name
sq_rawget(v,-2) ' pop as instance name
sq_createinstance(v,-1) ' new instance
sq_remove(v,-3) ' removes the root table
sq_remove(v,-2) '`removes the this class
return 1
end function
' push native instance on script stack
function Vector3.script_push(v as HSQUIRRELVM,idx as SQInteger) as SQInteger
sq_setinstanceup(v,idx,@this)
sq_setreleasehook(v,idx,@script_destructor)
return 1
end function
' set or get the class typetag
function Vector3.script_typetag(typetag as SQUserPointer=0) as SQUserPointer
static as SQUserPointer tag=0
if typetag then tag=typetag
return tag
end function
' return native class type
function Vector3.script_typeof cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_typeof")
sq_pushstring(v,"Vector3",-1)
return 1
end function
' return a string representation of the Vector3 class
function Vector3.script_tostring cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_tostring")
dim as Vector3 ptr pSelf = any
if(SQ_FAILED(sq_getinstanceup(v,1,@pSelf,script_typetag()))) then
return sq_throwerror(v,"invalid instance type")
end if
dim as string s = str(pSelf->x) & "," & str(pSelf->y) & "," & str(pSelf->z) + chr(0)
sq_pushstring(v,strptr(s),-1)
return 1
end function
' var = Vecor3() or var = vector3(vector3) or var = Vector3(x,y,z[,w])
function Vector3.script_constructor cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_constructor")
dim as SQFloat x,y,z
' get the number of params Note param 1=the hidden this pointer
dim as SQInteger n = sq_gettop(v)
dim as Vector3 ptr pNew
' param
if (n>3) andalso (sq_gettype(v,4) and SQOBJECT_NUMERIC) then sq_getfloat(v,4,@z)
if (n>2) andalso (sq_gettype(v,3) and SQOBJECT_NUMERIC) then sq_getfloat(v,3,@y)
if (n>1) then
' is the first param numeric ?
if (sq_gettype(v,2) and SQOBJECT_NUMERIC) then
dprint("script_constructor numeric")
sq_getfloat(v,2,@x)
pNew=new Vector3(x,y,z)
' is the first param instance ?
elseif (sq_gettype(v,2)=OT_INSTANCE) then
dprint("script_constructor instance")
' is it a instance of
if(SQ_FAILED(sq_getinstanceup(v,2,@pNew,script_typetag()))) then
return sq_throwerror(v,"invalid instance type")
end if
pNew=new Vector3(pNew)
else
return sq_throwerror(v,"must be numeric or instance")
end if
end if
pNew->script_push(v,1)
return 1
end function
function Vector3.script_destructor cdecl (p as SQUserPointer,size as SQInteger) as SQInteger
dprint("script_destructor")
dim as Vector3 ptr pRelease = p
' call the native constructor
if pRelease then delete pRelease
return 1
end function
' the foreach iterator _nexti
function Vector3.script_nexti cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_nexti")
dim as Vector3 ptr pSelf
dim as SQInteger iN=-1
' is it a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,1,@pSelf,script_typetag()))) then
return sq_throwerror(v,"_nexti invalid instance type")
end if
dim as SQInteger typ = sq_gettype(v,2)
' first iterator ? return 'x'
if (typ = OT_NULL) then
sq_pushstring(v,"x",-1):return 1
' is it a numeric index [0|1|2] ?
elseif (typ and SQOBJECT_NUMERIC) then
sq_getinteger(v,2,@iN) ' index
' or is it a string index .y|.z|.w ?
elseif (typ = OT_STRING) then
dim as SQChar ptr sN
sq_getstring(v,2,@sN)
if len(*sN)<>1 then
return sq_throwerror(v,"_nexti invalid string index [x|y|z]")
end if
iN=sN[0] ' first char = index
endif
select case as const iN
' [0|1|2],x|y|z,X|Y|Z
case 0,88,120:sq_pushstring(v,"y",-1):return 1
case 1,89,121:sq_pushstring(v,"z",-1):return 1
case 2,90,122:return 0
case else
return sq_throwerror(v,"_nexti invalid index [0..2] [x..z]")
end select
end function
' operator _get var = Vector3.x|y|z or var = Vector3[0|1|2]
function Vector3.script_get cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_get")
dim as Vector3 ptr pSelf
dim as SQInteger iN=-1
' is it a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,1,@pSelf,script_typetag()))) then
return sq_throwerror(v,"_get invalid instance type")
end if
' is it var = Vector3[0|1|2|3]
if (sq_gettype(v,2) and SQOBJECT_NUMERIC) then
sq_getinteger(v,2,@iN) ' index
' is it var = Vector3.x|.y|.z|.w ?
elseif (sq_gettype(v,2) = OT_STRING) then
dim as SQChar ptr sN
sq_getstring(v,2,@sN)
if len(*sN)<>1 then
return sq_throwerror(v,"_set invalid string index must be x|y|z")
end if
iN=sN[0] ' first char = index
endif
select case as const iN
' [0|1|2] | .x|X | .y|Y | .z|Z
case 0,88,120:sq_pushfloat(v,pSelf->x)
case 1,89,121:sq_pushfloat(v,pSelf->y)
case 2,90,122:sq_pushfloat(v,pSelf->z)
case else
return sq_throwerror(v,"_get unknow index must be [0|1|2] or .x|.y|.z")
end select
return 1 ' return value on stack
end function
' operator _set Vector3.x|y|z=value or Vector3[0|1|2] = value
function Vector3.script_set cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_set")
dim as Vector3 ptr pSelf
' is it a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,1,@pSelf,script_typetag))) then
return sq_throwerror(v,"_set invalid instance type")
end if
dim as SQInteger iN
' is it Vector3[0|1|2|3] = var ?
if (sq_gettype(v,2) and SQOBJECT_NUMERIC) then
sq_getinteger(v,2,@iN)
' is it Vector3.x|.y|.z|.w = var ?
elseif (sq_gettype(v,2) = OT_STRING) then
dim as SQChar ptr sN
sq_getstring(v,2,@sN)
if len(*sN)<>1 then
return sq_throwerror(v,"_set invalid string index must be x|y|z")
end if
iN=sN[0]
else
return sq_throwerror(v,"_set invalid index type")
endif
dim as SQFloat f
sq_getfloat(v,3,@f)
select case as const iN
case 0,88,120:pSelf->x=f
case 1,89,121:pSelf->y=f
case 2,90,122:pSelf->z=f
case else
return sq_throwerror(v,"_set unknow index must be [0|1|2] or .x|.y|.z")
end select
return 0 ' no return value on stack
end function
' operator _unm unary minus
function Vector3.script_unm cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_unm")
dim as Vector3 ptr pL=any,pNew=any
' is left param a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_unm invalid instance type")
end if
' var = -Vector3
pNew = new Vector3(-pL->x,-pL->y,-pL->z)
pNew->script_new(v)
pNew->script_push(v,-1)
return 1 ' new instance on stack
end function
' + operator _add
function Vector3.script_add cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_add")
dim as Vector3 ptr pL=any,pR=any,pNew=any
' is left param a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_add invalid left instance type")
end if
' is right param a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,2,@pR,script_typetag))) then
return sq_throwerror(v,"_add invalid right instance type")
end if
' var = a + b
pNew = new Vector3(pL->x+pR->x,pL->y+pR->y,pL->z+pR->z)
pNew->script_new(v)
pNew->script_push(v,-1)
return 1 ' new instance on stack
end function
' - operator _sub
function Vector3.script_sub cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_sub")
dim as Vector3 ptr pL=any,pR=any,pNew=any
' is left param a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_add invalid left instance type")
end if
' is right param a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,2,@pR,script_typetag))) then
return sq_throwerror(v,"_add invalid right instance type")
end if
' var = a - b
pNew = new Vector3(pL->x-pR->x, pL->y-pR->y, pL->z-pR->z)
pNew->script_new(v)
pNew->script_push(v,-1)
return 1 ' new instance on stack
end function
' * operator _mul
function Vector3.script_mul cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_mul")
dim as Vector3 ptr pL=any,pR=any,pNew=any
dim as SQFloat f
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_mul invalid left instance type")
end if
' dotproduct = Vector * Vector
if (sq_gettype(v,2) = OT_INSTANCE) then
if(SQ_FAILED(sq_getinstanceup(v,2,@pR,script_typetag))) then
return sq_throwerror(v,"_mul invalid right instance type")
end if
f = pL->x*pR->x + pL->y*pR->y + pL->z*pR->z
sq_pushfloat(v,f)
return 1
' Vector3 = Vector3 * numver
elseif (sq_gettype(v,2) and SQOBJECT_NUMERIC) then
sq_getfloat(v,2,@f)
pNew = new Vector3(pL->x*f,pL->y*f,pL->z*f)
pNew->script_new(v)
pNew->script_push(v,-1)
return 1
end if
return SQ_ERROR
end function
' / operator _div
function Vector3.script_div cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_div")
dim as Vector3 ptr pL=any,pNew=any
dim as SQFloat f
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_div invalid left instance type")
end if
sq_getfloat(v,2,@f)
if (f=0) then return sq_throwerror(v,"_div divide by 0 ")
pNew = new Vector3(pL->x/f,pL->y/f,pL->z/f)
pNew->script_new(v)
pNew->script_push(v,-1)
return 1
end function
' % operator _modulo (cross product)
function Vector3.script_modulo cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_modulo")
dim as Vector3 ptr pL=any,pR=any,pNew=any
dim as SQFloat f
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_modulo invalid left instance type")
end if
if(SQ_FAILED(sq_getinstanceup(v,2,@pR,script_typetag))) then
return sq_throwerror(v,"_modulo invalid right instance type")
end if
' Vector3 = Vector3 % Vector3
pNew = new Vector3(pL->y*pR->z - pL->z*pR->y, _
pL->z*pR->x - pL->x*pR->z, _
pL->x*pR->y - pL->y*pR->x)
pNew->script_new(v)
pNew->script_push(v,-1)
return 1
end function
' float = Vector3.length()
function Vector3.script_length cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_length")
dim as Vector3 ptr pL=any
dim as SQFloat f=any
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_length invalid instance type")
end if
f = pL->x*pL->x + pL->y*pL->y + pL->z*pL->z
if (f<>0.0) then f=sqr(f)
sq_pushfloat(v,f)
return 1
end function
' float = Vector3.distance(Vector3)
function Vector3.script_distance cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_distance")
dim as Vector3 ptr pL=any,pR=any
dim as SQFloat f=any,dx=any,dy=any,dz=any
' is left param a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_distance invalid left instance type")
end if
' is right param a instance of Vector3 ?
if(SQ_FAILED(sq_getinstanceup(v,2,@pR,script_typetag))) then
return sq_throwerror(v,"_distance invalid right instance type")
end if
' float = |a - b|
dx = pL->x-pR->x: dy=pL->y-pR->y: dz=pL->z-pR->z
f = dx*dx + dy*dy + dz*dz
if (f<>0.0) then f=sqr(f)
sq_pushfloat(v,f)
return 1
end function
' Vector3 = Vector3.normalize()
function Vector3.script_normalize cdecl (v as HSQUIRRELVM) as SQInteger
dprint("_normalize")
dim as Vector3 ptr pL=any,pNew=any
dim as SQFloat f
if(SQ_FAILED(sq_getinstanceup(v,1,@pL,script_typetag))) then
return sq_throwerror(v,"_normalize invalid left instance type")
end if
f = pL->x*pL->x + pL->y*pL->y + pL->z*pL->z
if (f<>0.0) then f=1.0/sqr(f)
' Vector3 = Vector3.normalize()
pNew = new Vector3(pL->x*f,pL->y*f,pL->z*f)
pNew->script_new(v)
pNew->script_push(v,-1)
return 1
end function
' script class factory
sub Vector3.ClassBegin(v as HSQUIRRELVM)
sq_pushroottable(v)
sq_pushstring(v,"Vector3",-1)
sq_newclass(v,0)
sq_settypetag(v,-1,script_typetag(@this))
end sub
sub Vector3.ClassMember(v as HSQUIRRELVM, _
sName as SQChar ptr, _
pFunc as SQFUNCTION, _
iCheck as SQInteger, _
sMask as SQChar ptr)
sq_pushstring(v,sName,-1)
sq_newclosure(v,pFunc,0)
sq_setparamscheck(v,iCheck,sMask)
sq_setnativeclosurename(v,-1,sName)
sq_createslot(v,-3)
end sub
sub Vector3.ClassEnd(v as HSQUIRRELVM)
sq_createslot(v,-3)
sq_pop(v,1)
end sub
' base class constructor
constructor Vector3(v as HSQUIRRELVM)
dprint("base_constructor")
ClassBegin(v)
ClassMember(v,"_typeof" ,@script_typeof , 1,0)
ClassMember(v,"_tostring" ,@script_tostring , 1,"x")
ClassMember(v,"constructor",@script_constructor,-1,". x|n nnn")
ClassMember(v,"_nexti" ,@script_nexti , 2,"x o|s|n")
ClassMember(v,"_get" ,@script_get , 2,"x s|n")
ClassMember(v,"_set" ,@script_set , 3,"x s|n n")
ClassMember(v,"_unm" ,@script_unm , 1,"x")
ClassMember(v,"_add" ,@script_add , 2,"x x")
ClassMember(v,"_sub" ,@script_sub , 2,"x x")
ClassMember(v,"_mul" ,@script_mul , 2,"x x|n")
ClassMember(v,"_div" ,@script_div , 2,"x n")
ClassMember(v,"_modulo" ,@script_modulo , 2,"x x")
ClassMember(v,"length" ,@script_length , 1,"x")
ClassMember(v,"distance" ,@script_distance , 2,"x x")
ClassMember(v,"normalize" ,@script_normalize , 1,"x")
ClassEnd(v)
end constructor
' native
constructor Vector3(p as Vector3 ptr)
dprint("native_constructor(Vector3)")
x=p->x:y=p->y:z=p->z:w=1
end constructor
constructor Vector3(fx as SQFloat,fy as SQFloat,fz as SQFloat)
dprint("native_constructor(x,y,z)")
x=fx:y=fy:z=fz:w=1
end constructor
destructor Vector3
dprint("native_destructor~")
end destructor
sub printfunc cdecl (v as HSQUIRRELVM,s as SQChar ptr,...)
dim as va_list vl = va_first()
vfprintf(stdout, s, vl)
end sub
sub errorfunc cdecl (v as HSQUIRRELVM,s as SQChar ptr,...)
dim as va_list vl = va_first()
vfprintf(stderr, s, vl)
end sub
' create VM
dim as HSQUIRRELVM v = sq_open(1024)
' optional set handlers
sqstd_seterrorhandlers(v)
sq_setprintfunc(v, @printfunc,@errorfunc)
' save current stack
sq_pushroottable(v)
' register some std libs
sqstd_register_bloblib(v)
sqstd_register_iolib(v)
sqstd_register_mathlib(v)
sqstd_register_stringlib(v)
sqstd_register_systemlib(v)
' register native class
dim as Vector3 BaseVector3 = Vector3(v)
' load/compile and call a script
sqstd_dofile(v, "nativeClassTest.nut", SQFalse, SQTrue)
'restore the stack
sq_pop(v,1)
' delete VM
sq_close(v)
sleep