[patch for 34031] first part of Tcl/Tk for parrot

[Vadim Konovalov]

Hi,

attached is my first attempt for the Tcl/Tk binding, which in turn will bring 
Tk interface for parrot.
The file Tcl.pir should go into the ./runtime/parrot/library/ directory

I am planning to make more subsequent patches on the matter, so I will 
appreciate if this first part will be considered for inclusion.

Also, a typo.

Thanks in advance,
Vadim.
-------------- next part --------------
# Copyright (C) 2008, The Perl Foundation.
# vkon

=head1 TITLE

libtcl.pir - NCI interface to Tcl language (http://www.tcl.tk)

=head1 DESCRIPTION

This module implements Tcl/Tk interface for Parrot.

=cut


.namespace ['Tcl']


.sub try :main
    .local pmc interp
    .local int b 
    interp = get_global '_tcl_interp'
    b = isnull interp
    unless b goto ok_interp
    die "NO interp\n"
  ok_interp:
    .local string res
    res = 'eval'(0,"puts this")
    res = 'eval'(0,"expr {2+3}")
    print "res="
    print res
    print "\n"
    res = 'eval'(0,<<"EOS")
# does not work yet
package require Tk
pack [button .b]
update
EOS
    res = 'eval'(0,"expr {3+3}")
    print "res="
    print res
    print "\n"
.end

.sub eval :method
    .param string str
    .local pmc interp, f_eval, f_getobjresult, f_getstringresult
    interp = get_global '_tcl_interp'
    f_eval = get_global '_tcl_eval'
    f_getobjresult = get_global '_tcl_getobjresult'
    f_getstringresult = get_global '_tcl_getstringresult'
    .local int res
    res = f_eval(interp,str)
    .local string str
    str = f_getstringresult(interp,0)
    .return(str)
.end

.sub _tcl_init :init

    # load shared library
    .local pmc libnames
    libnames = new 'ResizableStringArray'
    push libnames, 'tcl85'
    push libnames, 'tcl84'
    push libnames, 'libtcl8.5'
    push libnames, 'libtcl8.4'
    .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)

    # get interpreter, store it globally
    .local pmc interp, func_createinterp
    func_createinterp = dlfunc libtcl, "Tcl_CreateInterp", "p"
    interp = func_createinterp()
    set_global '_tcl_interp', interp

    .local int b 
    b = isnull interp
    unless b goto ok_interp
    die "NO interp\n"
  ok_interp:

    # few more functions, store them globally
    .local pmc func
    func = dlfunc libtcl, "Tcl_Eval", "ipt"
    set_global '_tcl_eval', 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_GetObjResult", "pp"
    set_global '_tcl_getobjresult', func

.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:
    .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:
-------------- next part --------------
diff -ru parrot-32666-orig/docs/art/pp002-pmc.pod parrot-32666/docs/art/pp002-pmc.pod
--- parrot-32666-orig/docs/art/pp002-pmc.pod	2008-11-18 07:45:05.000000000 +0000
+++ parrot-32666/docs/art/pp002-pmc.pod	2008-11-15 18:07:38.000000000 +0000
@@ -15,7 +15,7 @@
 a register-based virtual machine with 4 register types:
 Integer, String, Number, PMC. Registers are
 referenced by a capital letter signifying the register type
-followed by the register number (C<$S15> is String register
+followed by the register number (C<S15> is String register
 number 15). Parrot programs consist of lines of text where
 each line contains one opcode and its arguments.