Author: mdiep
Date: Sat Jan 6 14:03:06 2007
New Revision: 16447
Added:
trunk/languages/tcl/src/binary.c
trunk/languages/tcl/src/binary.h
Modified:
trunk/MANIFEST
trunk/languages/tcl/config/makefiles/root.in
trunk/languages/tcl/src/ops/tcl.ops
Log:
[tcl]: Create a .c file for [binary] functions
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Sat Jan 6 14:03:06 2007
@@ -1934,6 +1934,8 @@
languages/tcl/src/pmc/tcllist.pmc [tcl]
languages/tcl/src/pmc/tclobject.pmc [tcl]
languages/tcl/src/pmc/tclstring.pmc [tcl]
+languages/tcl/src/binary.c [tcl]
+languages/tcl/src/binary.h [tcl]
languages/tcl/src/returncodes.pir [tcl]
languages/tcl/src/tclsh.pir [tcl]
languages/tcl/t/cmd_after.t [tcl]
Modified: trunk/languages/tcl/config/makefiles/root.in
==============================================================================
--- trunk/languages/tcl/config/makefiles/root.in (original)
+++ trunk/languages/tcl/config/makefiles/root.in Sat Jan 6 14:03:06 2007
@@ -16,8 +16,6 @@
PGE_DIR = ../../compilers/pge
TGE_DIR = ../../compilers/tge
-OPSLIBS = tcl
-
# can't use $(wildcard) and friends for PMCS, as these have to be in
# dependency order; with no duplicates.
PMCS = \
@@ -110,11 +108,20 @@
@cd $(PMCDIR) && $(PMCBUILD) linklibs $(PMCS)
@cd $(PMCDIR) && $(PMCBUILD) copy "--destination=$(DESTDIR)" $(PMCS)
-ops:
- @cd $(OPSDIR) && $(OPSBUILD) generate $(OPSLIBS)
- @cd $(OPSDIR) && $(OPSBUILD) compile $(OPSLIBS)
- @cd $(OPSDIR) && $(OPSBUILD) linklibs $(OPSLIBS)
- @cd $(OPSDIR) && $(OPSBUILD) copy "--destination=$(DESTDIR)" $(OPSLIBS)
+# THIS WAS COPIED FROM THE ROOT MAKEFILE
+# Passing an empty argument in @ARGV to cc_flags.pl to indicate where extra -Is
+# (etc) should go. Otherwise it will insert them after the first space, which
+# makes life go horribly wrong if $(CC) contains spaces but can't have -I
+# arguments (etc) injected in the middle.
+# There is probably a better way to do this, but I can't work it out right now.
+.c$(O) :
+ @$(PERL) ../../tools/dev/cc_flags.pl ../../CFLAGS $(CC) "" $(CFLAGS)
[EMAIL PROTECTED]@@[EMAIL PROTECTED] @[EMAIL PROTECTED]@ -c $<
+
+ops: src/binary.o
+ @cd $(OPSDIR) && $(OPSBUILD) generate tcl
+ @cd $(OPSDIR) && $(OPSBUILD) compile tcl
+ @cd $(OPSDIR) && $(OPSBUILD) linklibs tcl ../binary.o
+ @cd $(OPSDIR) && $(OPSBUILD) copy "--destination=$(DESTDIR)" tcl
runtime/builtins.pir: $(GENERATED_INLINES) $(DEPS) tools/gen_builtins.pl
$(PERL) tools/gen_builtins.pl > runtime/builtins.pir
@@ -306,6 +313,7 @@
$(GENERATED_INLINES) \
"$(OPSDIR)/*.c" \
"$(OPSDIR)/*.h" \
+"src/*$(O)" \
"$(OPSDIR)/*$(O)" \
"$(OPSDIR)/*.bundle" \
"$(TCL_LIB)/*.pir"
Added: trunk/languages/tcl/src/binary.c
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/src/binary.c Sat Jan 6 14:03:06 2007
@@ -0,0 +1,88 @@
+
+#include "parrot/parrot.h"
+
+#include "binary.h"
+
+PMC *ParTcl_binary_scan(Interp *interp, STRING *BINSTR, STRING *FORMAT)
+{
+ char *binstr = string_to_cstring(interp, BINSTR);
+ INTVAL binstrlen = string_length(interp, BINSTR);
+ INTVAL binstrpos = 0;
+ char *format = string_to_cstring(interp, FORMAT);
+ INTVAL formatlen = string_length(interp, FORMAT);
+ INTVAL formatpos = 0;
+ INTVAL value = 0;
+ PMC *values = pmc_new(interp, enum_class_ResizablePMCArray);
+
+ while (formatpos < formatlen)
+ {
+ char *c;
+ double *d;
+ INTVAL len;
+ PMC *pmcval;
+ switch (format[formatpos++])
+ {
+ case 'c':
+ if (binstrpos + 1 > binstrlen)
+ {
+ formatpos = formatlen;
+ break;
+ }
+ c = binstr + binstrpos;
+ pmcval = pmc_new(interp, enum_class_Integer);
+ VTABLE_set_integer_native(interp, pmcval, (int)(char)*c);
+ VTABLE_push_pmc(interp, values, pmcval);
+ binstrpos += 1;
+ break;
+ case 'd':
+ len = sizeof(double)/sizeof(char);
+ if (binstrpos + len > binstrlen)
+ {
+ formatpos = formatlen;
+ break;
+ }
+ d = (double *)(binstr + binstrpos);
+ pmcval = pmc_new(interp, enum_class_Float);
+ VTABLE_set_number_native(interp, pmcval, *d);
+ VTABLE_push_pmc(interp, values, pmcval);
+ binstrpos += len;
+ break;
+ default:
+ break;
+ }
+ }
+
+ return values;
+}
+
+STRING *ParTcl_binary_format(Interp *interp, STRING *FORMAT, PMC *values)
+{
+ char *format = string_to_cstring(interp, FORMAT);
+ INTVAL formatlen = string_length(interp, FORMAT);
+ INTVAL pos = 0;
+ INTVAL value = 0;
+ STRING *binstr = string_from_cstring(interp, "", 0);
+
+ while (pos < formatlen)
+ {
+ char c;
+ double d;
+ INTVAL len;
+ switch (format[pos++])
+ {
+ case 'c':
+ c = (char)VTABLE_get_integer_keyed_int(interp, values,
value++);
+ binstr = string_concat(interp, binstr,
string_from_cstring(interp, &c, 1), 1);
+ break;
+ case 'd':
+ d = VTABLE_get_integer_keyed_int(interp, values, value++);
+ len = sizeof(double)/sizeof(char);
+ binstr = string_concat(interp, binstr,
string_from_cstring(interp, &d, len), len);
+ break;
+ default:
+ break;
+ }
+ }
+
+ return binstr;
+}
Added: trunk/languages/tcl/src/binary.h
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/src/binary.h Sat Jan 6 14:03:06 2007
@@ -0,0 +1,3 @@
+
+PMC *ParTcl_binary_scan(Interp *interp, STRING *BINSTR, STRING *FORMAT);
+STRING *ParTcl_binary_format(Interp *interp, STRING *FORMAT, PMC *values);
Modified: trunk/languages/tcl/src/ops/tcl.ops
==============================================================================
--- trunk/languages/tcl/src/ops/tcl.ops (original)
+++ trunk/languages/tcl/src/ops/tcl.ops Sat Jan 6 14:03:06 2007
@@ -2,9 +2,11 @@
** tcl.ops
*/
-#include "parrot/dynext.h"
+#include "parrot/parrot.h"
#include "parrot/string_funcs.h"
+#include "../binary.h"
+
VERSION = PARROT_VERSION;
=head1 NAME
@@ -34,53 +36,7 @@
=cut
inline op tcl_binary_scan(out PMC, in STR, in STR) {
- char *binstr = string_to_cstring(interp, $2);
- INTVAL binstrlen = string_length(interp, $2);
- INTVAL binstrpos = 0;
- char *format = string_to_cstring(interp, $3);
- INTVAL formatlen = string_length(interp, $3);
- INTVAL formatpos = 0;
- INTVAL value = 0;
- $1 = pmc_new(interp, enum_class_ResizablePMCArray);
-
- while (formatpos < formatlen)
- {
- char *c;
- double *d;
- INTVAL len;
- PMC *pmcval;
- switch (format[formatpos++])
- {
- case 'c':
- if (binstrpos + 1 > binstrlen)
- {
- formatpos = formatlen;
- break;
- }
- c = binstr + binstrpos;
- pmcval = pmc_new(interp, enum_class_Integer);
- VTABLE_set_integer_native(interp, pmcval, (int)(char)*c);
- VTABLE_push_pmc(interp, $1, pmcval);
- binstrpos += 1;
- break;
- case 'd':
- len = sizeof(double)/sizeof(char);
- if (binstrpos + len > binstrlen)
- {
- formatpos = formatlen;
- break;
- }
- d = (double *)(binstr + binstrpos);
- pmcval = pmc_new(interp, enum_class_Float);
- VTABLE_set_number_native(interp, pmcval, *d);
- VTABLE_push_pmc(interp, $1, pmcval);
- binstrpos += len;
- break;
- default:
- break;
- }
- }
-
+ $1 = ParTcl_binary_scan(interp, $2, $3);
goto NEXT();
}
@@ -91,33 +47,7 @@
=cut
inline op tcl_binary_format(out STR, in STR, in PMC) {
- char *format = string_to_cstring(interp, $2);
- INTVAL formatlen = string_length(interp, $2);
- INTVAL pos = 0;
- INTVAL value = 0;
- $1 = string_from_cstring(interp, "", 0);
-
- while (pos < formatlen)
- {
- char c;
- double d;
- INTVAL len;
- switch (format[pos++])
- {
- case 'c':
- c = (char)VTABLE_get_integer_keyed_int(interp, $3, value++);
- $1 = string_concat(interp, $1, string_from_cstring(interp, &c,
1), 1);
- break;
- case 'd':
- d = VTABLE_get_integer_keyed_int(interp, $3, value++);
- len = sizeof(double)/sizeof(char);
- $1 = string_concat(interp, $1, string_from_cstring(interp,
&d, len), len);
- break;
- default:
- break;
- }
- }
-
+ $1 = ParTcl_binary_format(interp, $2, $3);
goto NEXT();
}
