Front page | perl.cvs.parrot |
Postings from January 2009
[svn:parrot] r36032 - in trunk: . examples/tcl runtime/parrot/library t/library
From:
julianalbo
Date:
January 26, 2009 06:56
Subject:
[svn:parrot] r36032 - in trunk: . examples/tcl runtime/parrot/library t/library
Message ID:
20090126145623.9D75BCB9AE@x12.develooper.com
Author: julianalbo
Date: Mon Jan 26 06:56:20 2009
New Revision: 36032
Added:
trunk/examples/tcl/
trunk/examples/tcl/tcltkdemo.pir (contents, props changed)
trunk/runtime/parrot/library/TclLibrary.2.pir (contents, props changed)
trunk/runtime/parrot/library/TclLibrary.pir (contents, props changed)
trunk/t/library/tcl_lib.t (contents, props changed)
Modified:
trunk/MANIFEST
Log:
[library] add tcl/tk library, TT #86 vkon++
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Mon Jan 26 06:56:20 2009
@@ -824,6 +824,7 @@
examples/subs/no_retval.pir [main]doc
examples/subs/pasm_sub1.pasm [main]doc
examples/subs/single_retval.pir [main]doc
+examples/tcl/tcltkdemo.pir [main]doc
examples/tge/README [main]doc
examples/tge/branch/branch.g [main]doc
examples/tge/branch/lib/Branch.pir [main]doc
@@ -2703,6 +2704,8 @@
runtime/parrot/library/Stream/Writer.pir [library]
runtime/parrot/library/String/Utils.pir [library]
runtime/parrot/library/Tcl/Glob.pir [library]
+runtime/parrot/library/TclLibrary.pir [library]
+runtime/parrot/library/TclLibrary.2.pir [library]
runtime/parrot/library/Test/Builder.pir [library]
runtime/parrot/library/Test/Builder/Output.pir [library]
runtime/parrot/library/Test/Builder/Test.pir [library]
@@ -3213,6 +3216,7 @@
t/library/streams.t []
t/library/string_utils.t []
t/library/tcl_glob.t []
+t/library/tcl_lib.t []
t/library/test_builder_tester.t []
t/library/test_class.t []
t/library/test_more.t []
Added: trunk/examples/tcl/tcltkdemo.pir
==============================================================================
--- (empty file)
+++ trunk/examples/tcl/tcltkdemo.pir Mon Jan 26 06:56:20 2009
@@ -0,0 +1,41 @@
+# demonstrate Tcl/Tk GUI using NCI
+
+.include 'runtime/parrot/library/TclLibrary.pir'
+
+.sub try :main
+ .local pmc tcl
+ tcl = new 'TclLibrary'
+ .local string res
+ res = tcl.'eval'("return [expr 1.0/3]")
+ print "double is "
+ say res
+ res = tcl.'eval'("return [list a b foo bar]")
+ print "list is "
+ say res
+ res = tcl.'eval'("return {3+3}")
+ print "string is "
+ say res
+ tcl.'eval'("puts this")
+ res = tcl.'eval'("expr {2+3}")
+ print "res="
+ say res
+ res = tcl.'eval'(<<"EOS")
+package require Tk
+pack [button .b -text {useful button} -command {puts this}]
+pack [text .t]
+.t insert end {foo, bar, fluffy}
+pack [button .bquit -text {quit} -command {exit}]
+EOS
+ res = tcl.'eval'("expr {3+3}")
+ print "res="
+ say res
+ tcl.'MainLoop'()
+.end
+
+#
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/runtime/parrot/library/TclLibrary.2.pir
==============================================================================
--- (empty file)
+++ trunk/runtime/parrot/library/TclLibrary.2.pir Mon Jan 26 06:56:20 2009
@@ -0,0 +1,423 @@
+# Copyright (C) 2008, The Perl Foundation.
+# $Id$
+# vkon
+
+=head1 TITLE
+
+TclLibrary.pir - NCI interface to Tcl language (http://www.tcl.tk)
+
+=head1 DESCRIPTION
+
+This module implements Tcl/Tk interface for Parrot.
+
+=head1 TODO
+
+=over 2
+
+=item Tcl_GetStringFromObj - check its declaration and usage
+
+ func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
+
+=back
+
+=cut
+
+.include "hllmacros.pir"
+.include "datatypes.pasm"
+
+.namespace ['TclLibrary']
+
+
+# derived from tcl.h:
+.const int TCL_OK = 0
+.const int TCL_ERROR = 1
+.const int TCL_RETURN = 2
+.const int TCL_BREAK = 3
+.const int TCL_CONTINUE = 4
+
+# DEBUG
+.const int debug_objresult = 1
+
+#
+.sub eval :method
+ .param string str
+
+ .local string res, error
+ .local pmc f_evalex, f_getobjresult, f_getstringresult, f_resetresult
+ f_resetresult = get_global '_tcl_resetresult'
+ f_evalex = get_global '_tcl_evalex'
+ f_getobjresult = get_global '_tcl_getobjresult'
+ f_getstringresult = get_global '_tcl_getstringresult'
+
+ .local pmc interp
+ interp = getattribute self,'interp'
+
+ f_resetresult(interp)
+
+ .local int rc
+ rc = f_evalex(interp,str,-1,0) # interp, string, length or -1, flags
+ # check if the result is TCL_OK(=0)
+ if rc==TCL_OK goto eval_ok
+ res = f_getstringresult(interp,0)
+ error = "error during Tcl_EvalEx: " . res
+ die error
+
+eval_ok:
+ # get the result (list result, etc - TBD)
+ .IfElse(debug_objresult==1,{
+ .local pmc obj
+ obj = f_getobjresult(interp,0)
+ .local pmc tcl_obj_decl
+ tcl_obj_decl = get_global '_tcl_obj_decl' # retrieve tcl_obj structure
+ assign obj, tcl_obj_decl # ... and use it
+ res = _pmc_from_tclobj(interp,obj)
+ },{
+ res = f_getstringresult(interp,0)
+ })
+ .return(res)
+.end
+
+# Constructor for the interpreter object.
+# optional parameter - path to the tcl shared library.
+.sub init :method :vtable
+ .param string libname :optional
+ .param int has_libname :opt_flag
+
+ # get interpreter, store it globally
+ .local pmc interp, f_createinterp, f_tclinit
+ .local pmc libtcl
+ libtcl = get_global '_libtcl'
+ # if _libtcl not defined yet, then we're starting first time, so need
+ # to call _tcl_load_lib
+
+ unless_null libtcl, libtcl_loaded
+
+ if has_libname goto with_libname
+ '_tcl_load_lib'()
+ goto with_libname_e
+with_libname:
+ '_tcl_load_lib'(libname)
+with_libname_e:
+ libtcl = get_global '_libtcl'
+
+libtcl_loaded:
+ f_createinterp = dlfunc libtcl, "Tcl_CreateInterp", "p"
+ interp = f_createinterp()
+
+ unless_null interp, ok_interp
+ die "NO interp\n"
+
+ ok_interp:
+ setattribute self,'interp', interp
+ f_tclinit = dlfunc libtcl, "Tcl_Init", "vp"
+ f_tclinit(interp)
+.end
+
+=item _init
+
+Performs the initialization of Tcl bridge, namely instantiates TclLibrary class
+
+=cut
+
+.sub _init :load :init
+ .local pmc tclclass
+ tclclass = newclass ['TclLibrary']
+ addattribute tclclass, 'interp'
+
+.end
+
+=item _init_tclobj
+
+ - creates a helper for Tcl_Obj struct
+ # do the tcl.h adoptations
+
+=cut
+
+.sub _init_tclobj
+
+ # "declare" a helper for Tcl_Obj structure
+ # here is the definition of the Tcl_Obj struct
+ # typedef struct Tcl_Obj {
+ # int refCount; // When 0 the object will be freed.
+ # char *bytes; // points to the first byte of the obj string representation...
+ # int length; // number of bytes at *bytes, not incl.the term.null.
+ # Tcl_ObjType *typePtr; // obj type. if NULL - no int.rep.
+ # union { /* The internal representation: */
+ # long longValue; /* - an long integer value */
+ # double doubleValue; /* - a double-precision floating value */
+ # VOID *otherValuePtr; /* - another, type-specific value */
+ # Tcl_WideInt wideValue; /* - a long long value */
+ # struct { /* - internal rep as two pointers */
+ # VOID *ptr1;
+ # VOID *ptr2;
+ # } twoPtrValue;
+ # struct { /* - internal rep as a wide int, tightly
+ # * packed fields */
+ # VOID *ptr; /* Pointer to digits */
+ # unsigned long value;/* Alloc, used, and signum packed into a
+ # * single word */
+ # } ptrAndLongRep;
+ # } internalRep;
+ # } Tcl_Obj;
+
+ .local pmc tcl_obj_struct, tcl_obj_decl
+ tcl_obj_decl = new 'ResizablePMCArray'
+ push tcl_obj_decl, .DATATYPE_INT
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, .DATATYPE_CSTR
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, .DATATYPE_INT
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, .DATATYPE_INT
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, 0
+ # following items are for union, let it be 2 longs, which eventually
+ # could be transformed to the required type
+ push tcl_obj_decl, .DATATYPE_LONG
+ push tcl_obj_decl, 2
+ push tcl_obj_decl, 0
+
+ # union TBD
+ tcl_obj_struct = new 'UnManagedStruct', tcl_obj_decl
+ set_global '_tcl_obj_decl', tcl_obj_decl # XXXXXXXXX <----------
+.end
+
+# find proper shared library and use it.
+.sub _tcl_load_lib
+ .param string libname :optional
+ .param int has_libname :opt_flag
+
+ # load shared library
+ .local pmc libnames
+ libnames = new 'ResizableStringArray'
+ unless has_libname goto standard_names
+ push libnames, libname
+ say libname
+ goto standard_names_e
+standard_names:
+ push libnames, 'tcl85'
+ push libnames, 'tcl84'
+ push libnames, 'libtcl8.5'
+ push libnames, 'libtcl8.4'
+standard_names_e:
+
+ .local pmc libtcl
+ libtcl = _load_lib_with_fallbacks('tcl', libnames)
+ set_global '_libtcl', libtcl
+
+
+ # initialize Tcl library
+ .local pmc func_findexec
+ func_findexec = dlfunc libtcl, "Tcl_FindExecutable", "vp"
+ func_findexec(0)
+
+ # few more functions, store them globally
+ .local pmc func
+ # need: Tcl_ResetResult, Tcl_EvalEx, Tcl_GetStringResult, etc
+ func = dlfunc libtcl, "Tcl_ResetResult", "vp"
+ set_global '_tcl_resetresult', func
+ func = dlfunc libtcl, "Tcl_EvalEx", "iptii"
+ set_global '_tcl_evalex', func
+ func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
+ set_global '_tcl_getstringfromobj', func
+ func = dlfunc libtcl, "Tcl_GetStringResult", "tp"
+ set_global '_tcl_getstringresult', func
+ func = dlfunc libtcl, "Tcl_ListObjGetElements", "vippp" # should be "vip3p"
+ set_global '_tcl_listobjgetelements', func
+ func = dlfunc libtcl, "Tcl_GetObjResult", "pp"
+ set_global '_tcl_getobjresult', func
+ func = dlfunc libtcl, "Tcl_GetObjType", "it"
+ set_global '_tcl_getobjtype', func
+
+ '_init_tclobj'()
+
+.end
+
+=comment
+=cut
+
+#
+#static SV *
+#SvFromTclObj(pTHX_ Tcl_Obj *objPtr)
+=item pmc _pmc_from_tclobj(pmc interp, pmc tclobj)
+
+This is a (static) funciton that will convert Tcl object to pmc
+
+=cut
+
+.sub _pmc_from_tclobj
+ .param pmc interp
+ .param pmc tclobj
+
+ # check what type this tcl obj is
+ say "enter pmc_from_tclobj"
+
+ # check what tclobj actually is (null, integer, list, etc)
+
+ # ---> these lines will be factored out into some init stage! ....
+ .local int tclBooleanTypePtr
+ .local int tclByteArrayTypePtr
+ .local int tclDoubleTypePtr
+ .local int tclIntTypePtr
+ .local int tclListTypePtr
+ .local int tclStringTypePtr
+ .local int tclWideIntTypePtr
+
+ .local pmc f_getobjtype
+ f_getobjtype = get_global '_tcl_getobjtype'
+
+ tclBooleanTypePtr = f_getobjtype("boolean")
+ tclByteArrayTypePtr = f_getobjtype("bytearray")
+ tclDoubleTypePtr = f_getobjtype("double")
+ tclIntTypePtr = f_getobjtype("int")
+ tclListTypePtr = f_getobjtype("list")
+ tclStringTypePtr = f_getobjtype("string")
+ tclWideIntTypePtr = f_getobjtype("wideInt")
+ # ..... <---- (see above)
+
+ #.local pmc tcl_obj_struct
+ #tcl_obj_struct = get_global '_tcl_obj_struct'
+
+ if tclobj!=0 goto not_null
+ # null
+ say "NULL???"
+ goto EOJ
+
+not_null:
+ .local int obj_type
+
+ obj_type = tclobj[3]
+
+ if obj_type==0 goto EOJ # if obj_type is null, there's no internal rep
+
+ if obj_type!=tclBooleanTypePtr goto m00
+ say "implement tclBooleanTypePtr!"
+ goto EOJ
+m00:
+ if obj_type!=tclByteArrayTypePtr goto m01
+ say "implement tclByteArrayTypePtr"
+ goto EOJ
+m01:
+ if obj_type!=tclDoubleTypePtr goto m02
+ #sv = newSViv(objPtr->internalRep.doubleValue);
+ say "implement tclDoubleTypePtr"
+ goto EOJ
+m02:
+ if obj_type!=tclIntTypePtr goto m03
+ #sv = newSViv(objPtr->internalRep.longValue);
+ .local int ires
+ ires = tclobj[4]
+ say ires
+ .return(ires)
+m03:
+ if obj_type!=tclListTypePtr goto m04
+
+ .local int objc
+ .local pmc objv # pointer which will hold array of tcl_obj's
+
+ # Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
+ # if (objc) { .... }
+ .local pmc f_listobjgetelements
+ f_listobjgetelements = get_global '_tcl_listobjgetelements'
+ #f_listobjgetelements.(0, tclobj, objc, objv)
+
+ say "implement tclListTypePtr"
+ goto EOJ
+m04:
+ if obj_type!=tclStringTypePtr goto m05
+ say "implement tclStringTypePtr"
+ goto EOJ
+m05:
+ print "implement TCL obj_type "
+ say obj_type
+
+EOJ:
+
+ .local string str
+ .local pmc f_getstr
+ f_getstr = get_global '_tcl_getstringfromobj'
+ str = f_getstr(tclobj, 0)
+
+ .return(str)
+.end
+
+.sub MainLoop :method
+ say "MainLoop"
+ # TO BE FIXED
+ self.'eval'(<<'EOS')
+while {[winfo exists .]} {
+ update
+}
+EOS
+# .local pmc libtcl, f_mainloop
+# libtcl = get_global '_libtcl'
+# f_mainloop = dlfunc libtcl, "Tk_MainLoop", "v"
+# f_mainloop()
+ say "MainLoop-e!"
+.end
+
+=item _load_lib_with_fallbacks(string friendly_name, pmc fallback_list)
+
+This function is more generally useful than just for this module -- it
+implements the search for a particular libary that may appear under any
+of several different filenames. The C<fallback_list> should be a simple
+array of strings, each naming one of the possible filenames, I<without>
+the trailing shared library extension (e.g. C<.dll> or C<.so>). The
+C<friendly_name> is only used to fill in the error message in case no
+match can be found on the system.
+
+BORROWED from OpenGL.pir - keep an eye on it (e.g. if it will be organized
+elsewhere - reuse it from there)
+
+=cut
+
+.sub _load_lib_with_fallbacks
+ .param string friendly_name
+ .param pmc fallback_list
+
+ .local pmc list_iter
+ list_iter = iter fallback_list
+
+ .local string libname
+ .local pmc library
+ iter_loop:
+ unless list_iter goto failed
+ libname = shift list_iter
+ library = loadlib libname
+ unless library goto iter_loop
+
+ loaded:
+ print "tcl lib is "
+ say libname
+ .return (library)
+
+ failed:
+ .local string message
+ message = 'Could not find a suitable '
+ message .= friendly_name
+ message .= ' shared library!'
+ die message
+.end
+
+
+
+
+=head1 SEE ALSO
+
+http://www.tcl.tk
+
+=head1 AUTHORS
+
+TBD
+
+=cut
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/runtime/parrot/library/TclLibrary.pir
==============================================================================
--- (empty file)
+++ trunk/runtime/parrot/library/TclLibrary.pir Mon Jan 26 06:56:20 2009
@@ -0,0 +1,423 @@
+# Copyright (C) 2008, The Perl Foundation.
+# $Id$
+# vkon
+
+=head1 TITLE
+
+TclLibrary.pir - NCI interface to Tcl language (http://www.tcl.tk)
+
+=head1 DESCRIPTION
+
+This module implements Tcl/Tk interface for Parrot.
+
+=head1 TODO
+
+=over 2
+
+=item Tcl_GetStringFromObj - check its declaration and usage
+
+ func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
+
+=back
+
+=cut
+
+.include "hllmacros.pir"
+.include "datatypes.pasm"
+
+.namespace ['TclLibrary']
+
+
+# derived from tcl.h:
+.const int TCL_OK = 0
+.const int TCL_ERROR = 1
+.const int TCL_RETURN = 2
+.const int TCL_BREAK = 3
+.const int TCL_CONTINUE = 4
+
+# DEBUG
+.const int debug_objresult = 1
+
+#
+.sub eval :method
+ .param string str
+
+ .local string res, error
+ .local pmc f_evalex, f_getobjresult, f_getstringresult, f_resetresult
+ f_resetresult = get_global '_tcl_resetresult'
+ f_evalex = get_global '_tcl_evalex'
+ f_getobjresult = get_global '_tcl_getobjresult'
+ f_getstringresult = get_global '_tcl_getstringresult'
+
+ .local pmc interp
+ interp = getattribute self,'interp'
+
+ f_resetresult(interp)
+
+ .local int rc
+ rc = f_evalex(interp,str,-1,0) # interp, string, length or -1, flags
+ # check if the result is TCL_OK(=0)
+ if rc==TCL_OK goto eval_ok
+ res = f_getstringresult(interp,0)
+ error = "error during Tcl_EvalEx: " . res
+ die error
+
+eval_ok:
+ # get the result (list result, etc - TBD)
+ .IfElse(debug_objresult==1,{
+ .local pmc obj
+ obj = f_getobjresult(interp,0)
+ .local pmc tcl_obj_decl
+ tcl_obj_decl = get_global '_tcl_obj_decl' # retrieve tcl_obj structure
+ assign obj, tcl_obj_decl # ... and use it
+ res = _pmc_from_tclobj(interp,obj)
+ },{
+ res = f_getstringresult(interp,0)
+ })
+ .return(res)
+.end
+
+# Constructor for the interpreter object.
+# optional parameter - path to the tcl shared library.
+.sub init :method :vtable
+ .param string libname :optional
+ .param int has_libname :opt_flag
+
+ # get interpreter, store it globally
+ .local pmc interp, f_createinterp, f_tclinit
+ .local pmc libtcl
+ libtcl = get_global '_libtcl'
+ # if _libtcl not defined yet, then we're starting first time, so need
+ # to call _tcl_load_lib
+
+ unless_null libtcl, libtcl_loaded
+
+ if has_libname goto with_libname
+ '_tcl_load_lib'()
+ goto with_libname_e
+with_libname:
+ '_tcl_load_lib'(libname)
+with_libname_e:
+ libtcl = get_global '_libtcl'
+
+libtcl_loaded:
+ f_createinterp = dlfunc libtcl, "Tcl_CreateInterp", "p"
+ interp = f_createinterp()
+
+ unless_null interp, ok_interp
+ die "NO interp\n"
+
+ ok_interp:
+ setattribute self,'interp', interp
+ f_tclinit = dlfunc libtcl, "Tcl_Init", "vp"
+ f_tclinit(interp)
+.end
+
+=item _init
+
+Performs the initialization of Tcl bridge, namely instantiates TclLibrary class
+
+=cut
+
+.sub _init :load :init
+ .local pmc tclclass
+ tclclass = newclass ['TclLibrary']
+ addattribute tclclass, 'interp'
+
+.end
+
+=item _init_tclobj
+
+ - creates a helper for Tcl_Obj struct
+ # do the tcl.h adoptations
+
+=cut
+
+.sub _init_tclobj
+
+ # "declare" a helper for Tcl_Obj structure
+ # here is the definition of the Tcl_Obj struct
+ # typedef struct Tcl_Obj {
+ # int refCount; // When 0 the object will be freed.
+ # char *bytes; // points to the first byte of the obj string representation...
+ # int length; // number of bytes at *bytes, not incl.the term.null.
+ # Tcl_ObjType *typePtr; // obj type. if NULL - no int.rep.
+ # union { /* The internal representation: */
+ # long longValue; /* - an long integer value */
+ # double doubleValue; /* - a double-precision floating value */
+ # VOID *otherValuePtr; /* - another, type-specific value */
+ # Tcl_WideInt wideValue; /* - a long long value */
+ # struct { /* - internal rep as two pointers */
+ # VOID *ptr1;
+ # VOID *ptr2;
+ # } twoPtrValue;
+ # struct { /* - internal rep as a wide int, tightly
+ # * packed fields */
+ # VOID *ptr; /* Pointer to digits */
+ # unsigned long value;/* Alloc, used, and signum packed into a
+ # * single word */
+ # } ptrAndLongRep;
+ # } internalRep;
+ # } Tcl_Obj;
+
+ .local pmc tcl_obj_struct, tcl_obj_decl
+ tcl_obj_decl = new 'ResizablePMCArray'
+ push tcl_obj_decl, .DATATYPE_INT
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, .DATATYPE_CSTR
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, .DATATYPE_INT
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, .DATATYPE_INT
+ push tcl_obj_decl, 0
+ push tcl_obj_decl, 0
+ # following items are for union, let it be 2 longs, which eventually
+ # could be transformed to the required type
+ push tcl_obj_decl, .DATATYPE_LONG
+ push tcl_obj_decl, 2
+ push tcl_obj_decl, 0
+
+ # union TBD
+ tcl_obj_struct = new 'UnManagedStruct', tcl_obj_decl
+ set_global '_tcl_obj_decl', tcl_obj_decl # XXXXXXXXX <----------
+.end
+
+# find proper shared library and use it.
+.sub _tcl_load_lib
+ .param string libname :optional
+ .param int has_libname :opt_flag
+
+ # load shared library
+ .local pmc libnames
+ libnames = new 'ResizableStringArray'
+ unless has_libname goto standard_names
+ push libnames, libname
+ say libname
+ goto standard_names_e
+standard_names:
+ push libnames, 'tcl85'
+ push libnames, 'tcl84'
+ push libnames, 'libtcl8.5'
+ push libnames, 'libtcl8.4'
+standard_names_e:
+
+ .local pmc libtcl
+ libtcl = _load_lib_with_fallbacks('tcl', libnames)
+ set_global '_libtcl', libtcl
+
+
+ # initialize Tcl library
+ .local pmc func_findexec
+ func_findexec = dlfunc libtcl, "Tcl_FindExecutable", "vp"
+ func_findexec(0)
+
+ # few more functions, store them globally
+ .local pmc func
+ # need: Tcl_ResetResult, Tcl_EvalEx, Tcl_GetStringResult, etc
+ func = dlfunc libtcl, "Tcl_ResetResult", "vp"
+ set_global '_tcl_resetresult', func
+ func = dlfunc libtcl, "Tcl_EvalEx", "iptii"
+ set_global '_tcl_evalex', func
+ func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
+ set_global '_tcl_getstringfromobj', func
+ func = dlfunc libtcl, "Tcl_GetStringResult", "tp"
+ set_global '_tcl_getstringresult', func
+ func = dlfunc libtcl, "Tcl_ListObjGetElements", "vippp" # should be "vip3p"
+ set_global '_tcl_listobjgetelements', func
+ func = dlfunc libtcl, "Tcl_GetObjResult", "pp"
+ set_global '_tcl_getobjresult', func
+ func = dlfunc libtcl, "Tcl_GetObjType", "it"
+ set_global '_tcl_getobjtype', func
+
+ '_init_tclobj'()
+
+.end
+
+=comment
+=cut
+
+#
+#static SV *
+#SvFromTclObj(pTHX_ Tcl_Obj *objPtr)
+=item pmc _pmc_from_tclobj(pmc interp, pmc tclobj)
+
+This is a (static) funciton that will convert Tcl object to pmc
+
+=cut
+
+.sub _pmc_from_tclobj
+ .param pmc interp
+ .param pmc tclobj
+
+ # check what type this tcl obj is
+ say "enter pmc_from_tclobj"
+
+ # check what tclobj actually is (null, integer, list, etc)
+
+ # ---> these lines will be factored out into some init stage! ....
+ .local int tclBooleanTypePtr
+ .local int tclByteArrayTypePtr
+ .local int tclDoubleTypePtr
+ .local int tclIntTypePtr
+ .local int tclListTypePtr
+ .local int tclStringTypePtr
+ .local int tclWideIntTypePtr
+
+ .local pmc f_getobjtype
+ f_getobjtype = get_global '_tcl_getobjtype'
+
+ tclBooleanTypePtr = f_getobjtype("boolean")
+ tclByteArrayTypePtr = f_getobjtype("bytearray")
+ tclDoubleTypePtr = f_getobjtype("double")
+ tclIntTypePtr = f_getobjtype("int")
+ tclListTypePtr = f_getobjtype("list")
+ tclStringTypePtr = f_getobjtype("string")
+ tclWideIntTypePtr = f_getobjtype("wideInt")
+ # ..... <---- (see above)
+
+ #.local pmc tcl_obj_struct
+ #tcl_obj_struct = get_global '_tcl_obj_struct'
+
+ if tclobj!=0 goto not_null
+ # null
+ say "NULL???"
+ goto EOJ
+
+not_null:
+ .local int obj_type
+
+ obj_type = tclobj[3]
+
+ if obj_type==0 goto EOJ # if obj_type is null, there's no internal rep
+
+ if obj_type!=tclBooleanTypePtr goto m00
+ say "implement tclBooleanTypePtr!"
+ goto EOJ
+m00:
+ if obj_type!=tclByteArrayTypePtr goto m01
+ say "implement tclByteArrayTypePtr"
+ goto EOJ
+m01:
+ if obj_type!=tclDoubleTypePtr goto m02
+ #sv = newSViv(objPtr->internalRep.doubleValue);
+ say "implement tclDoubleTypePtr"
+ goto EOJ
+m02:
+ if obj_type!=tclIntTypePtr goto m03
+ #sv = newSViv(objPtr->internalRep.longValue);
+ .local int ires
+ ires = tclobj[4]
+ say ires
+ .return(ires)
+m03:
+ if obj_type!=tclListTypePtr goto m04
+
+ .local int objc
+ .local pmc objv # pointer which will hold array of tcl_obj's
+
+ # Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
+ # if (objc) { .... }
+ .local pmc f_listobjgetelements
+ f_listobjgetelements = get_global '_tcl_listobjgetelements'
+ #f_listobjgetelements.(0, tclobj, objc, objv)
+
+ say "implement tclListTypePtr"
+ goto EOJ
+m04:
+ if obj_type!=tclStringTypePtr goto m05
+ say "implement tclStringTypePtr"
+ goto EOJ
+m05:
+ print "implement TCL obj_type "
+ say obj_type
+
+EOJ:
+
+ .local string str
+ .local pmc f_getstr
+ f_getstr = get_global '_tcl_getstringfromobj'
+ str = f_getstr(tclobj, 0)
+
+ .return(str)
+.end
+
+.sub MainLoop :method
+ say "MainLoop"
+ # TO BE FIXED
+ self.'eval'(<<'EOS')
+while {[winfo exists .]} {
+ update
+}
+EOS
+# .local pmc libtcl, f_mainloop
+# libtcl = get_global '_libtcl'
+# f_mainloop = dlfunc libtcl, "Tk_MainLoop", "v"
+# f_mainloop()
+ say "MainLoop-e!"
+.end
+
+=item _load_lib_with_fallbacks(string friendly_name, pmc fallback_list)
+
+This function is more generally useful than just for this module -- it
+implements the search for a particular libary that may appear under any
+of several different filenames. The C<fallback_list> should be a simple
+array of strings, each naming one of the possible filenames, I<without>
+the trailing shared library extension (e.g. C<.dll> or C<.so>). The
+C<friendly_name> is only used to fill in the error message in case no
+match can be found on the system.
+
+BORROWED from OpenGL.pir - keep an eye on it (e.g. if it will be organized
+elsewhere - reuse it from there)
+
+=cut
+
+.sub _load_lib_with_fallbacks
+ .param string friendly_name
+ .param pmc fallback_list
+
+ .local pmc list_iter
+ list_iter = iter fallback_list
+
+ .local string libname
+ .local pmc library
+ iter_loop:
+ unless list_iter goto failed
+ libname = shift list_iter
+ library = loadlib libname
+ unless library goto iter_loop
+
+ loaded:
+ print "tcl lib is "
+ say libname
+ .return (library)
+
+ failed:
+ .local string message
+ message = 'Could not find a suitable '
+ message .= friendly_name
+ message .= ' shared library!'
+ die message
+.end
+
+
+
+
+=head1 SEE ALSO
+
+http://www.tcl.tk
+
+=head1 AUTHORS
+
+TBD
+
+=cut
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/t/library/tcl_lib.t
==============================================================================
--- (empty file)
+++ trunk/t/library/tcl_lib.t Mon Jan 26 06:56:20 2009
@@ -0,0 +1,58 @@
+#!./parrot
+# Copyright (C) 2009, The Perl Foundation.
+# $Id$
+
+=head1 NAME
+
+t/library/tcl_lib.t - test parrot to external Tcl connection
+
+=head1 SYNOPSIS
+
+ % prove t/library/tcl_lib.t
+
+=head1 DESCRIPTION
+
+=cut
+
+.const int TESTS = 1
+
+.sub 'main' :main
+ load_bytecode 'library/Test/More.pbc'
+
+ .local pmc exports, curr_namespace, test_namespace
+ curr_namespace = get_namespace
+ test_namespace = get_namespace [ 'Test'; 'More' ]
+ exports = split ' ', 'plan diag ok nok is is_deeply like isa_ok skip isnt todo'
+
+ test_namespace.'export_to'(curr_namespace, exports)
+
+ plan(TESTS)
+
+ load_bytecode 'TclLibrary.pir' # TBD pbc
+ 'ok'(1, 'loaded TclLibrary')
+
+ goto skip_all # this is TEMPORARY untill the case of missing libtcl is fixed
+
+ .local pmc tcl
+ tcl = new 'TclLibrary'
+ 'ok'(1, 'created instance')
+
+ .local string res
+ .local int ires
+ res = tcl.'eval'("return {3+3}")
+ 'is'(res, '3+3', 'return of a string')
+ # TODO res = tcl.'eval'("return [list a b foo bar]")
+ ires = tcl.'eval'("expr {3+3}")
+ 'is'(ires, 6, 'return of an integer')
+ res = tcl.'eval'("return [expr 1.0]")
+ 'is'(res, '1.0', 'return of double')
+
+skip_all:
+
+.end
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
+
-
[svn:parrot] r36032 - in trunk: . examples/tcl runtime/parrot/library t/library
by julianalbo