Author: coke
Date: Fri Mar 2 17:58:27 2007
New Revision: 17299
Added:
trunk/languages/tcl/src/class/tclproc.pir
Removed:
trunk/languages/tcl/src/pmc/tclproc.pmc
Modified:
trunk/ (props changed)
trunk/MANIFEST
trunk/languages/tcl/config/makefiles/root.in
trunk/languages/tcl/runtime/builtin/info.pir
trunk/languages/tcl/runtime/builtin/proc.pir
trunk/languages/tcl/runtime/builtin/rename.pir
trunk/languages/tcl/runtime/tcllib.pir
Log:
[tcl]
* Convert the TclProc PMC into a ParrotObject, so attributes work with it.
* update [proc] to generate an anonymous TclProc, and then store it
in the appropriate namespace. (rather than having this happen at
in the PIR compiler).
* Set attributes on each user defined procedure in [proc] and retrieve them
via [info], avoiding the need for several hidden globals that were
carrying this information.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Fri Mar 2 17:58:27 2007
@@ -2049,6 +2049,7 @@
languages/tcl/src/builtin/update.pir [tcl]
languages/tcl/src/builtin/while.tmt [tcl]
languages/tcl/src/class/tclconst.pir [tcl]
+languages/tcl/src/class/tclproc.pir [tcl]
languages/tcl/src/grammar/expr/expression.pg [tcl]
languages/tcl/src/grammar/expr/functions.pir [tcl]
languages/tcl/src/grammar/expr/operators.pir [tcl]
@@ -2064,7 +2065,6 @@
languages/tcl/src/pmc/tclint.pmc [tcl]
languages/tcl/src/pmc/tcllist.pmc [tcl]
languages/tcl/src/pmc/tclobject.pmc [tcl]
-languages/tcl/src/pmc/tclproc.pmc [tcl]
languages/tcl/src/pmc/tclstring.pmc [tcl]
languages/tcl/src/returncodes.pir [tcl]
languages/tcl/src/tclsh.pir [tcl]
Modified: trunk/languages/tcl/config/makefiles/root.in
==============================================================================
--- trunk/languages/tcl/config/makefiles/root.in (original)
+++ trunk/languages/tcl/config/makefiles/root.in Fri Mar 2 17:58:27 2007
@@ -31,8 +31,7 @@
tclfloat \
tcllist \
tclarray \
- tcldict \
- tclproc
+ tcldict
GENERATED_INLINES = \
$(C_BUILTIN)/break.pir \
@@ -106,7 +105,8 @@
$(PARROT) tcl.pbc $< --pir > $@
CLASSES = \
- $(CLASSDIR)/tclconst.pir
+ $(CLASSDIR)/tclconst.pir \
+ $(CLASSDIR)/tclproc.pir
pmcs:
@cd $(PMCDIR) && $(PMCBUILD) generate $(PMCS)
Modified: trunk/languages/tcl/runtime/builtin/info.pir
==============================================================================
--- trunk/languages/tcl/runtime/builtin/info.pir (original)
+++ trunk/languages/tcl/runtime/builtin/info.pir Fri Mar 2 17:58:27 2007
@@ -76,9 +76,24 @@
.local string procname
procname = shift argv
- $P1 = get_root_global ['_tcl'], 'proc_args'
- $P2 = $P1[procname]
- if_null $P2, no_args
+
+ .local pmc __namespace
+ __namespace = get_root_global ['_tcl'], '__namespace'
+
+ .local pmc ns
+ .local string name
+ ns = __namespace(procname)
+ name = pop ns
+ name = '&' . name
+
+ unshift ns, 'tcl'
+ $P1 = get_root_global ns, name
+ if null $P1 goto no_args
+
+ $P2 = getattribute $P1, 'args'
+ if null $P2 goto no_args
+ .return($P2)
+
.return($P2)
no_args:
@@ -108,11 +123,12 @@
.local string name
ns = __namespace(procname)
name = pop ns
+ name = '&' . name
unshift ns, 'tcl'
- $P1 = get_root_global ns, 'proc_body'
+ $P1 = get_root_global ns, name
if null $P1 goto no_body
- $P2 = $P1[name]
+ $P2 = getattribute $P1, 'HLL_source'
if null $P2 goto no_body
.return($P2)
@@ -169,9 +185,23 @@
.local pmc __set
__set = get_root_global ['_tcl'], '__set'
- $P1 = get_root_global ['_tcl'], 'proc_defaults'
- $P2 = $P1[procname]
- if_null $P2, not_proc
+
+ .local pmc __namespace
+ __namespace = get_root_global ['_tcl'], '__namespace'
+
+ .local pmc ns
+ .local string name
+ ns = __namespace(procname)
+ name = pop ns
+ name = '&' . name
+
+ unshift ns, 'tcl'
+ $P1 = get_root_global ns, name
+ if null $P1 goto not_proc
+
+ $P2 = getattribute $P1, 'defaults'
+ $P9 = getattribute $P1, 'args'
+ if null $P2 goto check_arg
$P3 = $P2[argname]
if_null $P3, check_arg
@@ -184,9 +214,7 @@
check_arg:
# there's no default. is there even an arg?
- $P1 = get_root_global ['_tcl'], 'proc_args'
- $P2 = $P1[procname]
- $P3 = __list($P2)
+ $P3 = __list($P9)
$P4 = new .Iterator, $P3
loop:
unless $P4 goto not_argument
Modified: trunk/languages/tcl/runtime/builtin/proc.pir
==============================================================================
--- trunk/languages/tcl/runtime/builtin/proc.pir (original)
+++ trunk/languages/tcl/runtime/builtin/proc.pir Fri Mar 2 17:58:27 2007
@@ -32,7 +32,7 @@
code = new 'PGE::CodeString'
args_code = new 'PGE::CodeString'
defaults = new 'PGE::CodeString'
- namespace = ""
+ namespace = ''
.local pmc ns
.local string name
@@ -73,9 +73,7 @@
create:
code.emit(<<'END_PIR', namespace, name)
-.HLL 'tcl', 'tcl_group'
-.namespace %0
-.sub '&%1'
+.sub 'xxx' :anon
.param pmc args :slurpy
.include 'languages/tcl/src/returncodes.pir'
.local pmc epoch, colons, split, unk, interactive :unique_reg
@@ -97,11 +95,14 @@
unshift info_level, $P0
END_PIR
+ .local pmc defaults_info
+ defaults_info = new .TclDict
+
.local string args_usage, args_info
.local int i, elems, min, max, is_slurpy
.local pmc arg
- args_usage = ""
- args_info = ""
+ args_usage = ''
+ args_info = ''
args = __list(args)
i = 0
elems = elements args
@@ -142,17 +143,11 @@
lexpad['$%1'] = $P1
END_PIR
- $P1 = get_root_global ['_tcl'], 'proc_defaults'
- $P2 = $P1[full_name]
- if_null $P2, vivify_key
- goto got_default_key
-vivify_key:
- $P2 = new .TclDict
- $P1[full_name] = $P2
-got_default_key:
$S0 = arg[0]
$S1 = arg[1]
- $P2[$S0] = $S1
+ defaults_info[$S0] = $S1
+
+got_default_key:
defaults.emit(<<'END_PIR', i, $S0, $S1)
default_%0:
@@ -177,9 +172,6 @@
args_info .= " args"
store_info:
- # Save the args for the proc for [info args]
- $P1 = get_root_global ['_tcl'], 'proc_args'
- $P1[full_name] = args_info
code .= <<'END_PIR'
.local int argc
@@ -219,14 +211,6 @@
.local string parsed_body, body_reg
(parsed_body, body_reg) = __script(body, 'pir_only'=>1)
- # Save the code for the proc for [info body]
- $P1 = get_hll_global ns, 'proc_body'
- unless null $P1 goto save_body
- $P1 = new .Hash
- set_hll_global ns, 'proc_body', $P1
-save_body:
- $P1[name] = body
-
code .= parsed_body
code.emit(<<"END_PIR", body_reg)
@@ -263,28 +247,46 @@
$I0 = find_charset 'ascii'
$S0 = trans_charset $I0
$P0 = pir_compiler($S0)
-
+
# the PIR compiler returns an Eval PMC, which contains each sub that
- # was compiled in it. we want the first one, and we want to put it
- # into a TclProc...
+ # was compiled in it. we want the first (and only) one, and we want to
+ # put it into a TclProc...
$P0 = $P0[0]
- $P1 = new .TclProc
+ $P1 = new 'TclProc'
assign $P1, $P0
- # Attach some metadata to the sub...
- # RT#41614
- #$P8 = getclass "TclProc"
- #addattribute $P8, 'source'
- #$P9 = new .String
- #$P9 = $S0
- #setattribute $P1, 'source', $P9
- ##setattribute $P1, 'HLL_source', body
+ $P9 = new .String
+ $P9 = $S0
+ setattribute $P1, 'PIR_source', $P9
+
+ $P9 = new .String
+ $P9 = 'Tcl'
+ setattribute $P1, 'HLL', $P9
+
+ setattribute $P1, 'HLL_source', body
+
+ $P9 = new .String
+ $P9 = args_info
+ setattribute $P1, 'args', $P9
+
+ setattribute $P1, 'defaults', defaults_info
# And now store it into the appropriate slot in the namespace
+ .local pmc ns_target
+ ns_target = get_hll_namespace
+
+ .local pmc iter, sub_ns
+ iter = new .Iterator, ns
+walk_ns:
+ unless iter goto done_walk
+ sub_ns = shift iter
+ ns_target = ns_target[sub_ns]
+ goto walk_ns
+done_walk:
- #say name
- #ns[name] = $P1
+ name = '&' . name
+ ns_target[name] = $P1
.return ('')
Modified: trunk/languages/tcl/runtime/builtin/rename.pir
==============================================================================
--- trunk/languages/tcl/runtime/builtin/rename.pir (original)
+++ trunk/languages/tcl/runtime/builtin/rename.pir Fri Mar 2 17:58:27 2007
@@ -56,31 +56,16 @@
delete_builtin:
builtin = get_root_global ['_tcl'; 'builtins'], oldName
- if null builtin goto delete_args
+ if null builtin goto return
$P0 = get_root_namespace ['_tcl'; 'builtins']
delete $P0[oldName]
- if delete_only goto delete_args
+ if delete_only goto return
add_builtin:
set_root_global ['_tcl'; 'builtins'], newName, builtin
-
-delete_args:
- $P0 = get_root_global ['_tcl'], 'proc_args'
- $I0 = exists $P0[oldName]
- unless $I0 goto return
-
- args = $P0[oldName]
- delete $P0[oldName]
-
- if delete_only goto return
-
-add_args:
- $P0[newName] = args
-
-
return:
.return('')
Modified: trunk/languages/tcl/runtime/tcllib.pir
==============================================================================
--- trunk/languages/tcl/runtime/tcllib.pir (original)
+++ trunk/languages/tcl/runtime/tcllib.pir Fri Mar 2 17:58:27 2007
@@ -34,6 +34,7 @@
# class files (HLL: _Tcl)
.include 'languages/tcl/src/class/tclconst.pir'
+.include 'languages/tcl/src/class/tclproc.pir'
# create the 'tcl' namespace -- see RT #39852
# http://rt.perl.org/rt3/Ticket/Display.html?id=39852
@@ -188,12 +189,6 @@
$P1 = new .ResizablePMCArray
store_global 'events', $P1
- $P1 = new .TclArray
- store_global 'proc_args', $P1
-
- $P1 = new .TclDict
- store_global 'proc_defaults', $P1
-
# Global variable initialization
#version info
Added: trunk/languages/tcl/src/class/tclproc.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/src/class/tclproc.pir Fri Mar 2 17:58:27 2007
@@ -0,0 +1,32 @@
+=head1 TclProc
+
+A .Sub with attributes
+
+=cut
+
+.include "languages/tcl/src/returncodes.pir"
+.include "languages/tcl/src/macros.pir"
+
+.HLL 'parrot', ''
+.namespace [ 'TclProc' ]
+
+.cloneable()
+
+=head2 __class_init
+
+Define the attributes required for the class.
+
+=cut
+
+.sub __class_init :load
+
+ $P0 = getclass 'Sub'
+ $P1 = subclass $P0, 'TclProc'
+
+ addattribute $P1, 'PIR_source'
+ addattribute $P1, 'namespace'
+ addattribute $P1, 'HLL' # In our case, Tcl...
+ addattribute $P1, 'HLL_source'
+ addattribute $P1, 'args'
+ addattribute $P1, 'defaults' # Should combine this with 'args' for a more
Perl-sixy way of specifying args.
+.end
