Ticket #1085: parrot-41587-tcltklib-new-diff.txt

diff -bru parrot-41727-o/config/gen/call_list/misc.in parrot-41727/config/gen/call_list/misc.in
--- parrot-41727-o/config/gen/call_list/misc.in Fri Jul 24 19:07:17 2009
+++ parrot-41727/config/gen/call_list/misc.in   Sun Oct 11 00:13:46 2009
@@ -60,6 +60,12 @@
 I    JOSI
 P    JOSII
 
+# Added for TclLibrary
+t    p3
+i    pp3p
+i    pp3
+i    ppd
+
 # libpast
 p    Ji
 p    Jipp
diff -bru parrot-41727-o/runtime/parrot/library/TclLibrary.pir parrot-41727/runtime/parrot/library/TclLibrary.pir
--- parrot-41727-o/runtime/parrot/library/TclLibrary.pir        Fri Jul 24 18:59:39 2009
+++ parrot-41727/runtime/parrot/library/TclLibrary.pir  Fri Oct 16 17:30:57 2009
@@ -10,16 +10,6 @@
 
 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"
@@ -35,6 +25,11 @@
 .const int TCL_BREAK    = 3
 .const int TCL_CONTINUE = 4
 
+.const int TCL_GLOBAL_ONLY     = 1
+.const int TCL_NAMESPACE_ONLY  = 2
+.const int TCL_APPEND_VALUE    = 4
+.const int TCL_LIST_ELEMENT    = 8
+
 # DEBUG
 .const int debug_objresult = 1
 
@@ -42,7 +37,8 @@
 .sub eval :method
     .param string str
 
-    .local string res, error
+    .local string error, sres
+    .local pmc res
     .local pmc f_evalex, f_getobjresult, f_getstringresult, f_resetresult
     f_resetresult = get_global '_tcl_resetresult'
     f_evalex = get_global '_tcl_evalex'
@@ -58,8 +54,8 @@
     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
+    sres = f_getstringresult(interp,0)
+    error = "error during Tcl_EvalEx: " . sres
     die error
 
 eval_ok:
@@ -72,11 +68,39 @@
         assign obj, tcl_obj_decl                  # ... and use it
        res = _pmc_from_tclobj(interp,obj)
     },{
-       res = f_getstringresult(interp,0)
+       sres = f_getstringresult(interp,0)
     })
     .return(res)
 .end
 
+# pure string eval, which evals and returns a string
+.sub eval_str :method
+    .param string str
+
+    .local string res, error
+    .local pmc f_eval, f_getstringresult, f_resetresult
+    f_resetresult = get_global '_tcl_resetresult'
+    f_eval = get_global '_tcl_eval'
+    f_getstringresult = get_global '_tcl_getstringresult'
+
+    .local pmc interp
+    interp = getattribute self,'interp'
+
+    f_resetresult(interp)
+
+    .local int rc
+    rc = f_eval(interp,str)
+    # check if the result is TCL_OK(=0)
+    if rc==TCL_OK goto eval_ok
+    res = f_getstringresult(interp,0)
+    error = "error during Tcl_Eval: " . res
+    die error
+
+eval_ok:
+    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
@@ -92,12 +116,11 @@
 
     unless_null libtcl, libtcl_loaded
 
-    if has_libname goto with_libname
-    '_tcl_load_lib'()
-    goto with_libname_e
-with_libname:
+    .IfElse(has_libname,{
     '_tcl_load_lib'(libname)
-with_libname_e:
+    },{
+        '_tcl_load_lib'()
+    })
     libtcl = get_global '_libtcl'
 
 libtcl_loaded:
@@ -125,13 +148,11 @@
     .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
 
@@ -162,7 +183,7 @@
     #     } internalRep;
     # } Tcl_Obj;
 
-    .local pmc tcl_obj_struct, tcl_obj_decl
+    .local pmc tcl_obj_struct, tcl_obj_struct_d, tcl_obj_decl
     tcl_obj_decl = new 'ResizablePMCArray'
     push tcl_obj_decl, .DATATYPE_INT
     push tcl_obj_decl, 0
@@ -184,7 +205,13 @@
 
     # union TBD
     tcl_obj_struct = new 'UnManagedStruct', tcl_obj_decl
-    set_global '_tcl_obj_decl', tcl_obj_decl # XXXXXXXXX <----------
+    set_global '_tcl_obj_decl', tcl_obj_decl
+
+    set tcl_obj_decl[12], .DATATYPE_DOUBLE
+    set tcl_obj_decl[13], 0
+
+    tcl_obj_struct_d = new 'UnManagedStruct', tcl_obj_decl
+    set_global '_tcl_obj_decl_d', tcl_obj_decl
 .end
 
 # find proper shared library and use it.
@@ -225,16 +252,41 @@
     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"
+    func = dlfunc libtcl, "Tcl_Eval", "ipt"
+    set_global '_tcl_eval', func
+    func = dlfunc libtcl, "Tcl_GetStringFromObj", "tp3"
     set_global '_tcl_getstringfromobj', func
+    func = dlfunc libtcl, "Tcl_GetIntFromObj", "ipp3"
+    set_global '_tcl_getintfromobj', func
+    func = dlfunc libtcl, "Tcl_GetDoubleFromObj", "ippp"
+    set_global '_tcl_getdoublefromobj', 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
+    func = dlfunc libtcl, "Tcl_GetVar", "tpti"
+    set_global '_tcl_getvar', func
+    func = dlfunc libtcl, "Tcl_GetVar2", "tptti"
+    set_global '_tcl_getvar2', func
+    func = dlfunc libtcl, "Tcl_SetVar", "tptti"
+    set_global '_tcl_setvar', func
+    func = dlfunc libtcl, "Tcl_SetVar2", "tpttti"
+    set_global '_tcl_setvar2', func
+    func = dlfunc libtcl, "Tcl_UnsetVar", "tpti"
+    set_global '_tcl_unsetvar', func
+    func = dlfunc libtcl, "Tcl_UnsetVar2", "tptti"
+    set_global '_tcl_unsetvar2', func
+
+    # for TclLibrary List
+    # need: Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjGetElements
+    func = dlfunc libtcl, "Tcl_ListObjLength", "ipp3"
+    set_global '_tcl_listobjlength', func
+    func = dlfunc libtcl, "Tcl_ListObjIndex", "ippip"
+    set_global '_tcl_listobjindex', func
+    func = dlfunc libtcl, "Tcl_ListObjGetElements", "ipp3p"
+    set_global '_tcl_listobjgetelements', func
 
     '_init_tclobj'()
 
@@ -254,7 +306,8 @@
     .param pmc tclobj
 
     # check what type this tcl obj is
-    say "enter pmc_from_tclobj"
+
+    .local int rc
 
     # check what tclobj actually is (null, integer, list, etc)
 
@@ -292,50 +345,81 @@
 
     obj_type = tclobj[3]
 
+    #print "TCL obj_type is "
+    #say obj_type
+
     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);
+    # the code below doesn't currently work, so go to fallback
+    # (fix it!)
     say "implement tclDoubleTypePtr"
     goto EOJ
+
+    .local pmc f_getdoublefromobj
+    .local pmc dres
+    f_getdoublefromobj = get_global '_tcl_getdoublefromobj'
+    dres = new 'Float'
+    rc = f_getdoublefromobj(interp, tclobj, dres)
+    say dres
+    #.local pmc tcl_obj_decl_d
+    #tcl_obj_decl_d = get_global '_tcl_obj_decl_d' # retrieve tcl_obj_d structure
+    #assign tclobj, tcl_obj_decl_d                  # ... and use it
+    #say "hujd1"
+    #dres = tclobj[4]
+    print "dres="
+    say dres
+    .return(dres)
+
 m02:
     if obj_type!=tclIntTypePtr goto m03
     #sv = newSViv(objPtr->internalRep.longValue);
-    .local int ires
-    ires = tclobj[4]
-    say ires
-    .return(ires)
+    .local pmc f_getintfromobj
+    .local pmc iint
+    f_getintfromobj = get_global '_tcl_getintfromobj'
+    # "direct" way:
+    #.local int ires
+    #ires = tclobj[4]
+    # "better" way:
+    iint = new 'Integer'
+    rc = f_getintfromobj(interp, tclobj, iint)
+    .return(iint)
+
 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"
+    .local pmc argh
+    argh = new 'Hash'
+    set argh['list'], tclobj
+    .local pmc tlist
+    tlist = new ['TclLibrary';'List'], argh
     goto EOJ
+    .return(tlist)
+
 m04:
     if obj_type!=tclStringTypePtr goto m05
     say "implement tclStringTypePtr"
     goto EOJ
+
 m05:
     print "implement TCL obj_type "
     say obj_type
 
 EOJ:
+    # this is a fallback - 
+    # if we do not have support for the type, we use 
+    # "_tcl_getstringfromobj", which is universal but we like to avoid
 
     .local string str
     .local pmc f_getstr
@@ -345,19 +429,246 @@
     .return(str)
 .end
 
+=item getvar (VARNAME, FLAGS)
+
+Returns the value of Tcl variable VARNAME. The optional argument FLAGS
+behaves as in I<setvar>.
+
+=back
+
+=cut
+
+.sub getvar :method
+    .param string var
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_getvar
+    f_getvar = get_global '_tcl_getvar'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_getvar(interp,var,flags)
+
+    .return(res)
+.end
+
+=item getvar2 (VARNAME1, VARNAME2, FLAGS)
+
+Returns the value of the element VARNAME1(VARNAME2) of a Tcl array.
+The optional argument FLAGS behaves as in I<setvar>.
+
+=back
+
+=cut
+
+.sub getvar2 :method
+    .param string name1
+    .param string name2
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_getvar2
+    f_getvar2 = get_global '_tcl_getvar2'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_getvar2(interp,name1,name2,flags)
+
+    .return(res)
+.end
+
+=item setvar (VARNAME, VALUE, FLAGS)
+
+The FLAGS field is optional. Sets Tcl variable VARNAME in the
+interpreter to VALUE. The FLAGS argument is the usual Tcl one and
+can be a bitwise OR of the constants TCL_GLOBAL_ONLY,
+TCL_LEAVE_ERR_MSG, TCL_APPEND_VALUE, TCL_LIST_ELEMENT.
+
+=back
+
+=cut
+
+.sub setvar :method
+    .param string var
+    .param string val
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_setvar
+    f_setvar = get_global '_tcl_setvar'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_setvar(interp,var,val,flags)
+
+    .return(res)
+.end
+
+=item setvar2 (VARNAME1, VARNAME2, VALUE, FLAGS)
+
+Sets the element VARNAME1(VARNAME2) of a Tcl array to VALUE. The optional
+argument FLAGS behaves as in I<SetVar> above.
+Semantically this is very much like Perl's hash element.
+
+=back
+
+=cut
+
+.sub setvar2 :method
+    .param string name1
+    .param string name2
+    .param string val
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_setvar2
+    f_setvar2 = get_global '_tcl_setvar2'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_setvar2(interp,name1,name2,val,flags)
+
+    .return(res)
+.end
+
+=item unsetvar (VARNAME, FLAGS)
+
+Unsets Tcl variable VARNAME. The optional argument FLAGS
+behaves as in I<setvar>.
+
+=back
+
+=cut
+
+.sub unsetvar :method
+    .param string var
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_unsetvar
+    f_unsetvar = get_global '_tcl_unsetvar'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_unsetvar(interp,var,flags)
+
+    .return(res)
+.end
+
+=item UnsetVar2 (VARNAME1, VARNAME2, FLAGS)
+
+Unsets the element VARNAME1(VARNAME2) of a Tcl array.
+The optional argument FLAGS behaves as in I<setvar>.
+
+=back
+
+=cut
+
+.sub unsetvar2 :method
+    .param string name1
+    .param string name2
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_unsetvar2
+    f_unsetvar2 = get_global '_tcl_unsetvar2'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_unsetvar2(interp,name1,name2,flags)
+
+    .return(res)
+.end
+
+=item MainLoop
+
+MainLoop method, which corresponds to Tcl/Tk Tk_MainLoop call
+
+=back
+
+=cut
+
 .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!"
+    # essentially we want to do:
+    #   .local pmc f_mainloop
+    #   f_mainloop = dlfunc libtk, "Tk_MainLoop", "v"
+    #   f_mainloop()
+    # we do not have libtk variable, however.
+    # providing iface with libtk is easy, but we can avoid this
+    # Instead of calling Tk_MainLoop, which is located in libtk8.5.so
+    # we do same loop as in Tcl::Tk module. So loading tk shared library
+    # is done by tcl itself.
+    .local string res
+    .local pmc libtcl
+    .local pmc f_dooneevent, f_eval, f_getstringresult
+    libtcl = get_global '_libtcl'
+    f_eval = get_global '_tcl_eval'
+    f_getstringresult = get_global '_tcl_getstringresult'
+    f_dooneevent = dlfunc libtcl, "Tcl_DoOneEvent", "ii"
+    .local pmc interp
+    interp = getattribute self,'interp'
+
+    # Loop until mainwindow exists (its path is '.')
+    # below are 2 implementations how we get know that mainwindow no more avail
+    #  1. eval "winfo exists ."
+    #  2. use global variable, which will be destroyed upon exit
+    # Now we prefer 2nd method.
+    .IfElse(0==1,{
+        .DoWhile({
+            f_dooneevent(0)  # spin it
+            # check if '.' window still exists
+            f_eval(interp, 'winfo exists .')
+            res = f_getstringresult(interp,0)
+        },res=="1")
+    },{
+        .local pmc f_getvar
+        f_getvar = get_global '_tcl_getvar'
+        self.'setvar'("MainLoop_continuing","y",TCL_GLOBAL_ONLY)
+        f_eval(interp,"trace add command . delete {unset MainLoop_continuing}")
+        .DoWhile({
+            f_dooneevent(0)  # spin it
+            # check if flag variable "MainLoop_continuing" still exists
+            res = f_getvar(interp,"MainLoop_continuing",TCL_GLOBAL_ONLY)
+         },res=="y")
+    })
+
 .end
 
 =item _load_lib_with_fallbacks(string friendly_name, pmc fallback_list)
@@ -403,6 +714,73 @@
     die message
 .end
 
+.namespace ['TclLibrary';'List']
+
+=over 4
+
+=item _init
+
+TclList support for Tcl/Tk library
+Based on Tcl list object, i.e. TclObj of type tclListType
+
+=cut
+
+.sub _init :load :init
+    .local pmc tclclass
+    tclclass = newclass ['TclLibrary';'List']
+    addattribute tclclass, 'list'
+.end
+
+.sub init :method :vtable
+    .param pmc argh
+
+    say "instantiating..."
+    #.local pmc tclobj
+    #tclobj = getattribute self, 'list'
+    say "yes, ['TclLibrary';'List'] obj created"
+.end
+
+.sub length :method
+    .local int res
+    # TBD
+    .return(res)
+.end
+
+.sub get_string :method
+    .local string res
+    # TBD
+    .return(res)
+.end
+
+=comment
+
+efficient way to extract all elements at once:
+    .local pmc objc, objv # pointer which will hold array of tcl_obj's
+    .local pmc objc_ptr, objv_ptr
+
+    objv = new 'String'
+    objv = "qwerty"
+    objv_ptr = new 'String'
+    objv_ptr = "qwerty"
+    objc = new 'Integer'
+
+    # Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
+    # if (objc) { .... }
+
+    .local pmc f_listobjgetelements
+    f_listobjgetelements = get_global '_tcl_listobjgetelements'
+    rc = f_listobjgetelements(interp, tclobj, objc, objv_ptr)
+    # we have objc TclObj in objv_ptr
+    print "objc="
+    say objc
+    print "rc="
+    say rc
+
+    TBD
+
+=cut
+
+
 =back
 
 
diff -bru parrot-41727-o/t/library/tcl_lib.t parrot-41727/t/library/tcl_lib.t
--- parrot-41727-o/t/library/tcl_lib.t  Fri Jul 24 19:07:00 2009
+++ parrot-41727/t/library/tcl_lib.t    Fri Oct 16 17:24:08 2009
@@ -31,7 +31,7 @@
     load_bytecode 'TclLibrary.pbc' # TBD pbc
     'ok'(1, 'loaded TclLibrary')
 
-    goto skip_all    # this is TEMPORARY untill the case of missing libtcl is fixed
+    goto skip_all    # this is TEMPORARY untill the hang with tcl84.dll/cygwin is fixed
 
     .local pmc tcl
     tcl = new 'TclLibrary'
@@ -39,14 +39,47 @@
 
     .local string res
     .local int ires
+
+    # misc evals
     res = tcl.'eval'("return {3+3}")
     'is'(res, '3+3', 'return of a string')
+    res = tcl.'eval'("string repeat {qwerty} 2")
+    'is'(res, 'qwertyqwerty', 'test 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')
 
+    # variable methods: getvar, setvar2, unsetvar2, etc.
+    tcl.'setvar'("foo", "ok")
+    res = tcl.'eval_str'("set foo")
+    'is'(res,"ok", "setvar ok")
+    res = tcl.'eval_str'("return $foo")
+    'is'(res,"ok", "setvar ok")
+
+    goto skip2
+    tcl.'eval_str'('set a(OK) ok; set a(five) 5')
+    res = tcl.'getvar2'('a','OK')
+    'is'(res,'ok','getvar2 ok')
+    tcl.'setvar2'("foo", "bar", "ok")
+    res = tcl.'getvar2'('foo','bar')
+    'is'(res,'ok','setvar2 ok')
+    res = tcl.'eval_str'("set bar(foo)")
+    'is'(res,"ok", "setvar ok")
+    res = tcl.'eval_str'("return $foo(bar)")
+    'is'(res,"ok", "setvar ok")
+  
+skip2:
+    # list
+    .local pmc tlist
+    tlist = tcl.'eval'("return [list a b foo bar]")
+    ires = tlist.'length'()
+    ok(ires,4,"list length")
+
+    # MORE TBD
+
+
 skip_all:
 
 .end