Ticket #86: TclLibrary.pir

File TclLibrary.pir, 10.9 KB (added by vkon, 5 years ago)
Line 
1# Copyright (C) 2008, The Perl Foundation.
2# vkon
3
4=head1 TITLE
5
6TclLibrary.pir - NCI interface to Tcl language (http://www.tcl.tk)
7
8=head1 DESCRIPTION
9
10This module implements Tcl/Tk interface for Parrot.
11
12=head1 TODO
13
14=over 2
15
16=item Tcl_GetStringFromObj - check its declaration and usage
17
18  func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
19
20=back
21
22=cut
23
24.include "hllmacros.pir"
25.include "datatypes.pasm"
26
27.namespace ['TclLibrary']
28
29
30# derived from tcl.h:
31.const int TCL_OK       = 0
32.const int TCL_ERROR    = 1
33.const int TCL_RETURN   = 2
34.const int TCL_BREAK    = 3
35.const int TCL_CONTINUE = 4
36
37# DEBUG
38.const int debug_objresult = 1
39
40#
41.sub eval :method
42    .param string str
43
44    .local string res, error
45    .local pmc f_evalex, f_getobjresult, f_getstringresult, f_resetresult
46    f_resetresult = get_global '_tcl_resetresult'
47    f_evalex = get_global '_tcl_evalex'
48    f_getobjresult = get_global '_tcl_getobjresult'
49    f_getstringresult = get_global '_tcl_getstringresult'
50
51    .local pmc interp
52    interp = getattribute self,'interp'
53
54    f_resetresult(interp)
55
56    .local int rc
57    rc = f_evalex(interp,str,-1,0) # interp, string, length or -1, flags
58    # check if the result is TCL_OK(=0)
59    if rc==TCL_OK goto eval_ok
60    res = f_getstringresult(interp,0)
61    error = "error during Tcl_EvalEx: " . res
62    die error
63
64eval_ok:   
65    # get the result (list result, etc - TBD)
66    .IfElse(debug_objresult==1,{
67        .local pmc obj
68        obj = f_getobjresult(interp,0)
69        .local pmc tcl_obj_decl
70        tcl_obj_decl = get_global '_tcl_obj_decl' # retrieve tcl_obj structure
71        assign obj, tcl_obj_decl                  # ... and use it
72        res = _pmc_from_tclobj(interp,obj)
73    },{
74        res = f_getstringresult(interp,0)
75    })
76    .return(res)
77.end
78
79# Constructor for the interpreter object.
80# optional parameter - path to the tcl shared library.
81.sub init :method :vtable
82    .param string libname :optional
83    .param int has_libname :opt_flag
84
85    # get interpreter, store it globally
86    .local pmc interp, f_createinterp, f_tclinit
87    .local pmc libtcl
88    libtcl = get_global '_libtcl'
89    # if _libtcl not defined yet, then we're starting first time, so need
90    # to call _tcl_load_lib
91
92    unless_null libtcl, libtcl_loaded
93
94    if has_libname goto with_libname
95    '_tcl_load_lib'()
96    goto with_libname_e
97with_libname:
98    '_tcl_load_lib'(libname)
99with_libname_e:
100    libtcl = get_global '_libtcl'
101
102libtcl_loaded:
103    f_createinterp = dlfunc libtcl, "Tcl_CreateInterp", "p"
104    interp = f_createinterp()
105
106    unless_null interp, ok_interp
107    die "NO interp\n"
108
109  ok_interp:
110    setattribute self,'interp', interp
111    f_tclinit = dlfunc libtcl, "Tcl_Init", "vp"
112    f_tclinit(interp)
113.end
114
115=item _init
116
117Performs the initialization of Tcl bridge, namely instantiates TclLibrary class
118
119=cut
120
121.sub _init :load :init
122    .local pmc tclclass
123    tclclass = newclass ['TclLibrary']
124    addattribute tclclass, 'interp'
125
126.end
127
128=item _init_tclobj
129
130 - creates a helper for Tcl_Obj struct
131    # do the tcl.h adoptations
132
133=cut
134
135.sub _init_tclobj
136
137    # "declare" a helper for Tcl_Obj structure
138    # here is the definition of the Tcl_Obj struct
139    # typedef struct Tcl_Obj {
140    #     int refCount; // When 0 the object will be freed.
141    #     char *bytes;  // points to the first byte of the obj string representation...
142    #     int length;   // number of bytes at *bytes, not incl.the term.null.
143    #     Tcl_ObjType *typePtr; // obj type. if NULL - no int.rep.
144    #     union {                    /* The internal representation: */
145    #         long longValue;        /*   - an long integer value */
146    #         double doubleValue;    /*   - a double-precision floating value */
147    #         VOID *otherValuePtr;   /*   - another, type-specific value */
148    #         Tcl_WideInt wideValue; /*   - a long long value */
149    #         struct {          /*   - internal rep as two pointers */
150    #             VOID *ptr1;
151    #             VOID *ptr2;
152    #         } twoPtrValue;
153    #         struct {          /*   - internal rep as a wide int, tightly
154    #                                  *     packed fields */
155    #             VOID *ptr;            /* Pointer to digits */
156    #             unsigned long value;/* Alloc, used, and signum packed into a
157    #                                  * single word */
158    #         } ptrAndLongRep;
159    #     } internalRep;
160    # } Tcl_Obj;
161
162    .local pmc tcl_obj_struct, tcl_obj_decl
163    tcl_obj_decl = new 'ResizablePMCArray'
164    push tcl_obj_decl, .DATATYPE_INT
165    push tcl_obj_decl, 0
166    push tcl_obj_decl, 0
167    push tcl_obj_decl, .DATATYPE_CSTR
168    push tcl_obj_decl, 0
169    push tcl_obj_decl, 0
170    push tcl_obj_decl, .DATATYPE_INT
171    push tcl_obj_decl, 0
172    push tcl_obj_decl, 0
173    push tcl_obj_decl, .DATATYPE_INT
174    push tcl_obj_decl, 0
175    push tcl_obj_decl, 0
176    # following items are for union, let it be 2 longs, which eventually
177    # could be transformed to the required type
178    push tcl_obj_decl, .DATATYPE_LONG
179    push tcl_obj_decl, 2
180    push tcl_obj_decl, 0
181
182    # union TBD
183    tcl_obj_struct = new 'UnManagedStruct', tcl_obj_decl
184    set_global '_tcl_obj_decl', tcl_obj_decl # XXXXXXXXX <----------
185.end
186
187# find proper shared library and use it.
188.sub _tcl_load_lib
189    .param string libname :optional
190    .param int has_libname :opt_flag
191
192    # load shared library
193    .local pmc libnames
194    libnames = new 'ResizableStringArray'
195    unless has_libname goto standard_names
196    push libnames, libname
197    say libname
198    goto standard_names_e
199standard_names:
200    push libnames, 'tcl85'
201    push libnames, 'tcl84'
202    push libnames, 'libtcl8.5'
203    push libnames, 'libtcl8.4'
204standard_names_e:
205
206    .local pmc libtcl
207    libtcl = _load_lib_with_fallbacks('tcl', libnames)
208    set_global '_libtcl', libtcl
209
210
211    # initialize Tcl library
212    .local pmc func_findexec
213    func_findexec = dlfunc libtcl, "Tcl_FindExecutable", "vp"
214    func_findexec(0)
215
216    # few more functions, store them globally
217    .local pmc func
218    # need: Tcl_ResetResult, Tcl_EvalEx, Tcl_GetStringResult, etc
219    func = dlfunc libtcl, "Tcl_ResetResult", "vp"
220    set_global '_tcl_resetresult', func
221    func = dlfunc libtcl, "Tcl_EvalEx", "iptii"
222    set_global '_tcl_evalex', func
223    func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
224    set_global '_tcl_getstringfromobj', func
225    func = dlfunc libtcl, "Tcl_GetStringResult", "tp"
226    set_global '_tcl_getstringresult', func
227    func = dlfunc libtcl, "Tcl_ListObjGetElements", "vippp"  # should be "vip3p"
228    set_global '_tcl_listobjgetelements', func
229    func = dlfunc libtcl, "Tcl_GetObjResult", "pp"
230    set_global '_tcl_getobjresult', func
231    func = dlfunc libtcl, "Tcl_GetObjType", "it"
232    set_global '_tcl_getobjtype', func
233
234    '_init_tclobj'()
235
236.end
237
238=comment
239=cut
240
241#
242#static SV *
243#SvFromTclObj(pTHX_ Tcl_Obj *objPtr)
244=item pmc _pmc_from_tclobj(pmc interp, pmc tclobj)
245
246This is a (static) funciton that will convert Tcl object to pmc
247
248=cut
249
250.sub _pmc_from_tclobj
251    .param pmc interp
252    .param pmc tclobj
253
254    # check what type this tcl obj is
255    say "enter pmc_from_tclobj"
256
257    # check what tclobj actually is (null, integer, list, etc)
258
259    # --->  these lines will be factored out into some init stage! ....
260    .local int tclBooleanTypePtr   
261    .local int tclByteArrayTypePtr
262    .local int tclDoubleTypePtr   
263    .local int tclIntTypePtr       
264    .local int tclListTypePtr     
265    .local int tclStringTypePtr   
266    .local int tclWideIntTypePtr   
267
268    .local pmc f_getobjtype
269    f_getobjtype = get_global '_tcl_getobjtype'
270
271    tclBooleanTypePtr   = f_getobjtype("boolean")
272    tclByteArrayTypePtr = f_getobjtype("bytearray")
273    tclDoubleTypePtr    = f_getobjtype("double")
274    tclIntTypePtr       = f_getobjtype("int")
275    tclListTypePtr      = f_getobjtype("list")
276    tclStringTypePtr    = f_getobjtype("string")
277    tclWideIntTypePtr   = f_getobjtype("wideInt")
278    # ..... <---- (see above)
279
280    #.local pmc tcl_obj_struct
281    #tcl_obj_struct = get_global '_tcl_obj_struct'
282
283    if tclobj!=0 goto not_null
284    # null
285    say "NULL???"
286    goto EOJ
287
288not_null:
289    .local int obj_type
290
291    obj_type = tclobj[3]
292
293    if obj_type==0 goto EOJ # if obj_type is null, there's no internal rep
294
295    if obj_type!=tclBooleanTypePtr goto m00
296    say "implement tclBooleanTypePtr!"
297    goto EOJ
298m00:
299    if obj_type!=tclByteArrayTypePtr goto m01
300    say "implement tclByteArrayTypePtr"
301    goto EOJ
302m01:
303    if obj_type!=tclDoubleTypePtr goto m02
304    #sv = newSViv(objPtr->internalRep.doubleValue);
305    say "implement tclDoubleTypePtr"
306    goto EOJ
307m02:
308    if obj_type!=tclIntTypePtr goto m03
309    #sv = newSViv(objPtr->internalRep.longValue);
310    .local int ires
311    ires = tclobj[4]
312    say ires
313    .return(ires)
314m03:
315    if obj_type!=tclListTypePtr goto m04
316
317    .local int objc
318    .local pmc objv # pointer which will hold array of tcl_obj's
319
320    # Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
321    # if (objc) { .... }
322    .local pmc f_listobjgetelements
323    f_listobjgetelements = get_global '_tcl_listobjgetelements'
324    #f_listobjgetelements.(0, tclobj, objc, objv)
325
326    say "implement tclListTypePtr"
327    goto EOJ
328m04:
329    if obj_type!=tclStringTypePtr goto m05
330    say "implement tclStringTypePtr"
331    goto EOJ
332m05:
333    print "implement TCL obj_type "
334    say obj_type
335
336EOJ:
337
338    .local string str
339    .local pmc f_getstr
340    f_getstr = get_global '_tcl_getstringfromobj'
341    str = f_getstr(tclobj, 0)
342
343    .return(str)
344.end
345
346.sub MainLoop :method
347    say "MainLoop"
348    # TO BE FIXED
349    self.'eval'(<<'EOS')
350while {[winfo exists .]} {
351    update
352}
353EOS
354#    .local pmc libtcl, f_mainloop
355#    libtcl = get_global '_libtcl'
356#    f_mainloop = dlfunc libtcl, "Tk_MainLoop", "v"
357#    f_mainloop()
358    say "MainLoop-e!"
359.end
360
361=item _load_lib_with_fallbacks(string friendly_name, pmc fallback_list)
362
363This function is more generally useful than just for this module -- it
364implements the search for a particular libary that may appear under any
365of several different filenames.  The C<fallback_list> should be a simple
366array of strings, each naming one of the possible filenames, I<without>
367the trailing shared library extension (e.g. C<.dll> or C<.so>).  The
368C<friendly_name> is only used to fill in the error message in case no
369match can be found on the system.
370
371BORROWED from OpenGL.pir - keep an eye on it (e.g. if it will be organized
372elsewhere - reuse it from there)
373
374=cut
375
376.sub _load_lib_with_fallbacks
377    .param string friendly_name
378    .param pmc    fallback_list
379
380    .local pmc    list_iter
381    list_iter = iter fallback_list
382
383    .local string libname
384    .local pmc    library
385  iter_loop:
386    unless list_iter goto failed
387    libname = shift list_iter
388    library = loadlib libname
389    unless library goto iter_loop
390
391  loaded:
392    print "tcl lib is "
393    say libname
394    .return (library)
395
396  failed:
397    .local string message
398    message  = 'Could not find a suitable '
399    message .= friendly_name
400    message .= ' shared library!'
401    die message
402.end
403
404
405
406
407=head1 SEE ALSO
408
409http://www.tcl.tk
410
411=head1 AUTHORS
412
413TBD
414
415=cut
416
417
418# Local Variables:
419#   mode: pir
420#   fill-column: 100
421# End:
422# vim: expandtab shiftwidth=4 ft=pir: