Argh, I accidentally sent TWO patch.txt's. The one attached to THIS
message is the right one.
--Brent Dax
[EMAIL PROTECTED]
Parrot Configure pumpking and regex hacker
Check out the Parrot FAQ: http://www.panix.com/~ziggy/parrot.html (no,
it's not mine)
<obra> mmmm. hawt sysadmin chx0rs
<lathos> This is sad. I know of *a* hawt sysamin chx0r.
<obra> I know more than a few.
<lathos> obra: There are two? Are you sure it's not the same one?
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/MANIFEST /parrot/MANIFEST
--- /parrot-cvs/MANIFEST Tue Feb 5 00:36:28 2002
+++ /parrot/MANIFEST Tue Feb 5 00:40:00 2002
@@ -93,6 +93,7 @@
include/parrot/jit.h
include/parrot/key.h
include/parrot/memory.h
+include/parrot/misc.h
include/parrot/op.h
include/parrot/oplib.h
include/parrot/packfile.h
@@ -109,6 +110,7 @@
include/parrot/string_funcs.h
include/parrot/trace.h
include/parrot/unicode.h
+include/parrot/warnings.h
interpreter.c
io.ops
io/TODO
@@ -200,6 +202,7 @@
make_vtable_ops.pl
manicheck.pl
memory.c
+misc.c
obscure.ops
ops2c.pl
ops2pm.pl
@@ -250,3 +253,4 @@
trace.c
vtable.tbl
vtable_h.pl
+warnings.c
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/Makefile.in /parrot/Makefile.in
--- /parrot-cvs/Makefile.in Tue Feb 5 00:36:28 2002
+++ /parrot/Makefile.in Tue Feb 5 00:35:48 2002
@@ -63,10 +63,12 @@
GENERAL_H_FILES = $(INC)/config.h $(INC)/exceptions.h $(INC)/io.h $(INC)/op.h \
$(INC)/register.h $(INC)/string.h $(INC)/events.h $(INC)/interpreter.h \
$(INC)/memory.h $(INC)/parrot.h $(INC)/stacks.h $(INC)/packfile.h \
-$(INC)/global_setup.h $(INC)/vtable.h $(INC)/oplib/core_ops.h
$(INC)/oplib/core_ops_prederef.h \
-$(INC)/runops_cores.h $(INC)/trace.h \
+$(INC)/global_setup.h $(INC)/vtable.h $(INC)/oplib/core_ops.h \
+$(INC)/oplib/core_ops_prederef.h $(INC)/runops_cores.h $(INC)/trace.h \
$(INC)/pmc.h $(INC)/key.h $(INC)/resources.h $(INC)/platform.h \
-$(INC)/interp_guts.h ${jit_h} $(INC)/rx.h $(INC)/rxstacks.h $(INC)/embed.h
+$(INC)/interp_guts.h ${jit_h} $(INC)/rx.h $(INC)/rxstacks.h \
+$(INC)/embed.h $(INC)/warnings.h $(INC)/misc.h
+
ALL_H_FILES = $(GENERAL_H_FILES) ${jit_struct_h}
CLASS_O_FILES = classes/default$(O) classes/array$(O) \
@@ -84,7 +86,8 @@
INTERP_O_FILES = exceptions$(O) global_setup$(O) interpreter$(O) parrot$(O)
register$(O) \
core_ops$(O) core_ops_prederef$(O) memory$(O) packfile$(O) stacks$(O) \
string$(O) encoding$(O) chartype$(O) runops_cores$(O) trace$(O) pmc$(O) key$(O) \
-platform$(O) ${jit_o} resources$(O) rx$(O) rxstacks$(O) embed$(O)
+platform$(O) ${jit_o} resources$(O) rx$(O) rxstacks$(O) embed$(O) warnings$(O) \
+misc$(O)
O_FILES = $(INTERP_O_FILES) $(IO_O_FILES) $(CLASS_O_FILES) $(ENCODING_O_FILES)
$(CHARTYPE_O_FILES)
@@ -167,30 +170,30 @@
$(LD) $(LD_SHARED) -Wl,-soname,libparrot$(SO).${MAJOR} $(LDFLAGS)
$(LD_OUT)blib/lib/libparrot$(SO).${VERSION} $(O_FILES)
blib/lib/libparrot$(SO).${MAJOR}.${MINOR}: blib/lib/libparrot$(SO).${VERSION}
- rm -f $@
+ $(RM_F) $@
cd blib/lib; ln -s libparrot$(SO).${VERSION} libparrot$(SO).${MAJOR}.${MINOR}
blib/lib/libparrot$(SO).${MAJOR}: blib/lib/libparrot$(SO).${MAJOR}.${MINOR}
- rm -f $@
+ $(RM_F) $@
cd blib/lib; ln -s libparrot$(SO).${MAJOR}.${MINOR} libparrot$(SO).${MAJOR}
blib/lib/libparrot$(SO): blib/lib/libparrot$(SO).${MAJOR}
- rm -f $@
+ $(RM_F) $@
cd blib/lib; ln -s libparrot$(SO).${MAJOR} libparrot$(SO)
blib/lib/libcore_prederef$(SO).${VERSION}: blib_lib core_ops_prederef$(O)
$(LD) $(LD_SHARED) -Wl,-soname,libparrot$(SO).${MAJOR} $(LDFLAGS)
$(LD_OUT)blib/lib/libcore_prederef$(SO).${VERSION} core_ops_prederef$(O)
blib/lib/libcore_prederef$(SO).${MAJOR}.${MINOR}:
blib/lib/libcore_prederef$(SO).${VERSION}
- rm -f $@
+ $(RM_F) $@
cd blib/lib; ln -s libcore_prederef$(SO).${VERSION}
libcore_prederef$(SO).${MAJOR}.${MINOR}
blib/lib/libcore_prederef$(SO).${MAJOR}:
blib/lib/libcore_prederef$(SO).${MAJOR}.${MINOR}
- rm -f $@
+ $(RM_F) $@
cd blib/lib; ln -s libcore_prederef$(SO).${MAJOR}.${MINOR}
libcore_prederef$(SO).${MAJOR}
blib/lib/libcore_prederef$(SO): blib/lib/libcore_prederef$(SO).${MAJOR}
- rm -f $@
+ $(RM_F) $@
cd blib/lib; ln -s libcore_prederef$(SO).${MAJOR} libcore_prederef$(SO)
$(TEST_PROG_SO): test_main$(O) blib/lib/libparrot$(SO) lib/Parrot/OpLib/core.pm
lib/Parrot/PMC.pm
@@ -332,6 +335,10 @@
core_ops_prederef.c $(INC)/oplib/core_ops_prederef.h: $(OPS_FILES) ops2c.pl
lib/Parrot/OpsFile.pm lib/Parrot/Op.pm
$(PERL) ops2c.pl CPrederef $(OPS_FILES)
+
+warnings$(O): $(H_FILES)
+
+misc$(O): $(H_FILES)
vtable.ops: make_vtable_ops.pl
$(PERL) make_vtable_ops.pl > vtable.ops
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/classes/perlundef.pmc
/parrot/classes/perlundef.pmc
--- /parrot-cvs/classes/perlundef.pmc Mon Jan 28 23:28:20 2002
+++ /parrot/classes/perlundef.pmc Sun Feb 3 01:39:52 2002
@@ -45,6 +45,7 @@
}
INTVAL get_integer () {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+integer context");
return 0;
}
@@ -52,6 +53,7 @@
}
FLOATVAL get_number () {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+numeric context");
return 0;
}
@@ -60,7 +62,8 @@
}
STRING* get_string () {
- return string_make(INTERP,NULL,0,NULL,0,NULL);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+string context");
+ return NULL;
}
STRING* get_string_index (INTVAL idx) {
@@ -68,10 +71,12 @@
}
BOOLVAL get_bool () {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+boolean context");
return 0;
}
void* get_value () {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of unintialized value");
return NULL;
}
@@ -155,182 +160,259 @@
}
void add (PMC * value, PMC* dest) {
- if(value->vtable == &Parrot_base_vtables[enum_class_PerlUndef]) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
- }
- else if(value->vtable == &Parrot_base_vtables[enum_class_PerlInt]) {
- dest->vtable->set_integer(INTERP, dest, value);
- }
- else {
- dest->vtable->set_number(INTERP, dest, value);
- }
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+addition");
+
+ if(value->vtable == &Parrot_base_vtables[enum_class_PerlUndef]) {
+ dest->vtable->set_integer_native(INTERP, dest, 0);
+ }
+ else if(value->vtable == &Parrot_base_vtables[enum_class_PerlInt]) {
+ dest->vtable->set_integer(INTERP, dest, value);
+ }
+ else {
+ dest->vtable->set_number(INTERP, dest, value);
+ }
}
void add_int (INTVAL value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, value);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+integer addition");
+ dest->vtable->set_integer_native(INTERP, dest, value);
}
void add_bigint (BIGINT value, PMC* dest) {
}
void add_float (FLOATVAL value, PMC* dest) {
- dest->vtable->set_number_native(INTERP, dest, value);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+numeric addition");
+ dest->vtable->set_number_native(INTERP, dest, value);
}
void add_bigfloat (BIGFLOAT value, PMC* dest) {
}
void add_same (PMC * value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of two uninitialized
+values in addition");
dest->vtable->set_integer_native(INTERP, dest, 0);
}
void subtract (PMC * value, PMC* dest) {
- if(value->vtable == &Parrot_base_vtables[enum_class_PerlUndef]) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
- }
- else if(value->vtable == &Parrot_base_vtables[enum_class_PerlInt]) {
- dest->vtable->set_integer_native(INTERP, dest,
- -value->vtable->get_integer(INTERP, value));
- }
- else {
- dest->vtable->set_number_native(INTERP, dest,
- -value->vtable->get_number(INTERP, value));
- }
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+subtraction");
+
+ if(value->vtable == &Parrot_base_vtables[enum_class_PerlUndef]) {
+ dest->vtable->set_integer_native(INTERP, dest, 0);
+ }
+ else if(value->vtable == &Parrot_base_vtables[enum_class_PerlInt]) {
+ dest->vtable->set_integer_native(
+ INTERP, dest, 0-value->vtable->get_integer(INTERP, value)
+ /* It doesn't hurt to be more explicit */
+ );
+ }
+ else {
+ dest->vtable->set_number_native(INTERP, dest,
+0-value->vtable->get_number(INTERP, value));
+ }
}
void subtract_int (INTVAL value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, -value);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+integer subtraction");
+ dest->vtable->set_integer_native(INTERP, dest, 0-value);
}
void subtract_bigint (BIGINT value, PMC* dest) {
}
void subtract_float (FLOATVAL value, PMC* dest) {
- dest->vtable->set_number_native(INTERP, dest, -value);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+numeric subtraction");
+ dest->vtable->set_number_native(INTERP, dest, 0-value);
}
void subtract_bigfloat (BIGFLOAT value, PMC* dest) {
}
void subtract_same (PMC * value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of two uninitialized
+values in subtraction");
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void multiply (PMC * value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+multiplication");
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void multiply_int (INTVAL value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+integer multiplication");
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void multiply_bigint (BIGINT value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+bigint multiplication");
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void multiply_float (FLOATVAL value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+numeric multiplication");
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void multiply_bigfloat (BIGFLOAT value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+bigfloat multiplication");
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void multiply_same (PMC * value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of two uninitialized
+values in multiplication");
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void divide (PMC * value, PMC* dest) {
- if(value->vtable == &Parrot_base_vtables[enum_class_PerlUndef]) {
- internal_exception(DIV_BY_ZERO, "division by zero!\n");
- }
- else if(value->vtable == &Parrot_base_vtables[enum_class_PerlInt]) {
- if(value->vtable->get_integer(INTERP, value) == 0) {
- internal_exception(DIV_BY_ZERO, "division by zero!\n");
- }
- }
- else if(value->vtable->get_number(INTERP, value) == 0) {
- internal_exception(DIV_BY_ZERO, "division by zero!\n");
- }
-
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+division");
+ if(value->vtable == &Parrot_base_vtables[enum_class_PerlUndef]) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+ else if(value->vtable == &Parrot_base_vtables[enum_class_PerlInt]) {
+ if(value->vtable->get_integer(INTERP, value) == 0) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+ }
+ else if(value->vtable->get_number(INTERP, value) == 0) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void divide_int (INTVAL value, PMC* dest) {
- if(value == 0) {
- internal_exception(DIV_BY_ZERO, "division by zero!\n");
- }
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+integer division");
+ if(value == 0) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void divide_bigint (BIGINT value, PMC* dest) {
- /* need test for value == 0 */
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+bigint division");
+ /* need test for value == 0 */
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void divide_float (FLOATVAL value, PMC* dest) {
- if(value == 0) {
- internal_exception(DIV_BY_ZERO, "division by zero!\n");
- }
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+numeric division");
+ if(value == 0) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void divide_bigfloat (BIGFLOAT value, PMC* dest) {
- /* need test for value == 0 */
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+bigfloat division");
+ /* need test for value == 0 */
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void divide_same (PMC * value, PMC* dest) {
- internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of two uninitialized
+values in division");
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
}
void modulus (PMC * value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+modulus");
+ if(value->vtable == &Parrot_base_vtables[enum_class_PerlUndef]) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+ else if(value->vtable == &Parrot_base_vtables[enum_class_PerlInt]) {
+ if(value->vtable->get_integer(INTERP, value) == 0) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+ }
+ else if(value->vtable->get_number(INTERP, value) == 0) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void modulus_int (INTVAL value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+integer modulus");
+ if(value == 0) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void modulus_bigint (BIGINT value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+bigint modulus");
+ /* need test for value == 0 */
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void modulus_float (FLOATVAL value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+numeric modulus");
+ if(value == 0) {
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
+ }
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void modulus_bigfloat (BIGFLOAT value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+bigfloat modulus");
+ /* need test for value == 0 */
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void modulus_same (PMC * value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of two uninitialized
+values in modulus");
+ internal_exception(DIV_BY_ZERO, "division by zero!\n");
}
void concatenate (PMC * value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+concatenation");
+ dest->vtable->set_string(INTERP, dest, value);
}
void concatenate_native (STRING * value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+concatenation");
+ dest->vtable->set_string_native(INTERP, dest, value);
}
void concatenate_unicode (STRING * value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+concatenation");
+ dest->vtable->set_string_native(INTERP, dest, value);
}
void concatenate_other (STRING * value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+concatenation");
+ dest->vtable->set_string_native(INTERP, dest, value);
}
void concatenate_same (PMC * value, PMC* dest) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+concatenation");
+ dest->vtable->set_string_native(INTERP, dest, NULL);
}
BOOLVAL is_equal (PMC* value) {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+equals");
+ if(value->vtable==SELF->vtable) {
+ return 1;
+ }
+ else if(value->vtable->get_integer(INTERP, value) == 0) {
+ return 1;
+ }
+ else if(0==string_compare(INTERP, value->vtable->get_string(INTERP, value),
+NULL)) {
+ return 1;
+ }
+ else {
+ return 0;
+ }
}
void logical_or (PMC* value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest,
- value->vtable->get_bool(INTERP, value));
+ dest->vtable->set_integer_native(INTERP, dest, value->vtable->get_bool(INTERP,
+value));
}
void logical_and (PMC* value, PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 0);
+ dest->vtable->set_integer_native(INTERP, dest, 0);
}
void logical_not (PMC* dest) {
- dest->vtable->set_integer_native(INTERP, dest, 1);
+ dest->vtable->set_integer_native(INTERP, dest, 1);
}
void match (PMC * value, REGEX* re) {
@@ -349,28 +431,28 @@
}
void repeat (PMC * value, PMC* dest) {
- dest->vtable = &Parrot_base_vtables[enum_class_PerlString];
- dest->cache.struct_val = string_make(INTERP, NULL,0,NULL,0, NULL);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+repeat");
+ dest->vtable->set_string(INTERP, dest, NULL);
}
void repeat_native (STRING * value, PMC* dest) {
- dest->vtable = &Parrot_base_vtables[enum_class_PerlString];
- dest->cache.struct_val = string_make(INTERP, NULL,0,NULL,0, NULL);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+repeat");
+ dest->vtable->set_string(INTERP, dest, NULL);
}
void repeat_unicode (STRING * value, PMC* dest) {
- dest->vtable = &Parrot_base_vtables[enum_class_PerlString];
- dest->cache.struct_val = string_make(INTERP, NULL,0,NULL,0, NULL);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+repeat");
+ dest->vtable->set_string(INTERP, dest, NULL);
}
void repeat_other (STRING * value, PMC* dest) {
- dest->vtable = &Parrot_base_vtables[enum_class_PerlString];
- dest->cache.struct_val = string_make(INTERP, NULL,0,NULL,0, NULL);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+repeat");
+ dest->vtable->set_string(INTERP, dest, NULL);
}
void repeat_same (PMC * value, PMC* dest) {
- dest->vtable = &Parrot_base_vtables[enum_class_PerlString];
- dest->cache.struct_val = string_make(INTERP, NULL,0,NULL,0, NULL);
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG, "Use of uninitialized value in
+repeat");
+ dest->vtable->set_string(INTERP, dest, NULL);
}
}
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/core.ops /parrot/core.ops
--- /parrot-cvs/core.ops Tue Feb 5 00:36:28 2002
+++ /parrot/core.ops Tue Feb 5 00:34:44 2002
@@ -2632,6 +2632,44 @@
goto NEXT();
}
+=item B<warningson>(in INT)
+
+Turns on warnings categories. Categories already turned on will
+stay on. Current categories and the numbers they map to are:
+
+=over 4
+
+=item 1: undef
+
+=item 2: IO
+
+=item -1: all
+
+=back
+
+To turn on multiple categories, OR the category numbers together.
+
+=cut
+
+inline op warningson(in INT) {
+ PARROT_WARNINGS_on(interpreter, $1);
+ goto NEXT();
+}
+
+=item B<warningsoff>(in INT)
+
+Turns off warnings categories. Categories already turned off will
+stay off. See the documentation for B<warningson> for category
+numbers.
+
+=cut
+
+inline op warningsoff(in INT) {
+ PARROT_WARNINGS_off(interpreter, $1);
+ goto NEXT();
+}
+
+
=back
=cut
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/embed.c /parrot/embed.c
--- /parrot-cvs/embed.c Tue Feb 5 00:36:28 2002
+++ /parrot/embed.c Tue Feb 5 00:34:44 2002
@@ -40,6 +40,12 @@
interpreter->flags |= flag;
}
+void
+Parrot_setwarnings(struct Parrot_Interp *interpreter, Parrot_warnclass wc) {
+ char* msg=mem_sys_allocate(32);
+ PARROT_WARNINGS_on(interpreter, wc);
+}
+
struct PackFile *
Parrot_readbc(struct Parrot_Interp *interpreter, char *filename) {
/* XXX This ugly mess ought to be cleanupable. */
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/include/parrot/embed.h
/parrot/include/parrot/embed.h
--- /parrot-cvs/include/parrot/embed.h Wed Jan 30 05:54:28 2002
+++ /parrot/include/parrot/embed.h Fri Feb 1 14:32:36 2002
@@ -14,18 +14,14 @@
#if !defined(PARROT_EMBED_H_GUARD)
#define PARROT_EMBED_H_GUARD
-#include "parrot/config.h"
+#include "parrot/config.h" /* PARROT_VERSION, PARROT_JIT_CAPABLE... */
+#include "parrot/interpreter.h" /* give us the interpreter flags */
+#include "parrot/warnings.h" /* give us the warnings flags */
typedef int Parrot_flag;
+typedef int Parrot_warnclass;
typedef void * Parrot_flag_val;
-/* plucked these straight from interpreter.h */
-#define PARROT_DEBUG_FLAG 0x01 /* We're debugging */
-#define PARROT_TRACE_FLAG 0x02 /* We're tracing execution */
-#define PARROT_BOUNDS_FLAG 0x04 /* We're tracking byte code bounds */
-#define PARROT_PROFILE_FLAG 0x08 /* We're gathering profile information */
-#define PARROT_PREDEREF_FLAG 0x10 /* We're using the prederef runops */
-#define PARROT_JIT_FLAG 0x20 /* We're using the jit runops */
/* These two are basically Magic Cookies to the outside world. */
struct Parrot_Interp;
@@ -36,6 +32,8 @@
void Parrot_init(struct Parrot_Interp *);
void Parrot_setflag(struct Parrot_Interp *, Parrot_flag, Parrot_flag_val);
+
+void Parrot_setwarnings(struct Parrot_Interp *, Parrot_warnclass);
struct PackFile * Parrot_readbc(struct Parrot_Interp *, char *);
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/include/parrot/interpreter.h
/parrot/include/parrot/interpreter.h
--- /parrot-cvs/include/parrot/interpreter.h Mon Jan 28 23:28:22 2002
+++ /parrot/include/parrot/interpreter.h Fri Feb 1 15:59:46 2002
@@ -12,14 +12,18 @@
#if !defined(PARROT_INTERPRETER_H_GUARD)
#define PARROT_INTERPRETER_H_GUARD
+
+#if defined(PARROT_IN_CORE)
+
#include "parrot/register.h"
#include "parrot/parrot.h"
#include "parrot/op.h"
#include "parrot/oplib.h"
-
-
+typedef struct warnings_t {
+ INTVAL classes;
+} * Warnings;
#if 0
typedef STRING_FUNCS * (str_func_t)();
@@ -68,6 +72,9 @@
INTVAL flags; /* Various interpreter
flagBut whBut what
that signal that runops
should do something */
+
+ Warnings warns; /* Keeps track of
+what warnings have been activated */
+
ProfData* profile; /* The array where we keep the profile
counters */
INTVAL resume_flag;
@@ -82,13 +89,6 @@
UINTVAL pmc_count;
};
-#define PARROT_DEBUG_FLAG 0x01 /* We're debugging */
-#define PARROT_TRACE_FLAG 0x02 /* We're tracing execution */
-#define PARROT_BOUNDS_FLAG 0x04 /* We're tracking byte code bounds */
-#define PARROT_PROFILE_FLAG 0x08 /* We're gathering profile information */
-#define PARROT_PREDEREF_FLAG 0x10 /* We're using the prederef runops */
-#define PARROT_JIT_FLAG 0x20 /* We're using the jit runops */
-
#define PCONST(i) PF_CONST(interpreter->code, (i))
#define PNCONST PF_NCONST(interpreter->code)
@@ -104,6 +104,18 @@
runops(struct Parrot_Interp *, struct PackFile *, size_t offset);
VAR_SCOPE opcode_t* (*run_native)(struct Parrot_Interp *interpreter, opcode_t
*cur_opcode, opcode_t *start_code);
+
+#endif
+
+/* These should be visible to embedders. */
+
+/* General flags */
+#define PARROT_DEBUG_FLAG 0x01 /* We're debugging */
+#define PARROT_TRACE_FLAG 0x02 /* We're tracing execution */
+#define PARROT_BOUNDS_FLAG 0x04 /* We're tracking byte code bounds */
+#define PARROT_PROFILE_FLAG 0x08 /* We're gathering profile information */
+#define PARROT_PREDEREF_FLAG 0x10 /* We're using the prederef runops */
+#define PARROT_JIT_FLAG 0x20 /* We're using the jit runops */
#endif
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/include/parrot/misc.h
/parrot/include/parrot/misc.h
--- /parrot-cvs/include/parrot/misc.h Wed Dec 31 16:00:00 1969
+++ /parrot/include/parrot/misc.h Sun Feb 3 00:57:52 2002
@@ -0,0 +1,24 @@
+#if !defined(PARROT_MISC_H_GUARD)
+#define PARROT_MISC_H_GUARD
+
+#include "parrot/parrot.h"
+#include <stdarg.h>
+
+STRING* Parrot_vsprintf_s(struct Parrot_Interp *, STRING* pat, va_list *);
+
+STRING* Parrot_vsprintf_c(struct Parrot_Interp *, char * pat, va_list *);
+
+void Parrot_vsprintf(struct Parrot_Interp *, char *targ, char *pat, va_list *);
+
+void Parrot_vsnprintf(struct Parrot_Interp *, char *targ, INTVAL len, char *pat,
+va_list *);
+
+STRING* Parrot_sprintf_s(struct Parrot_Interp *, STRING* pat, ...);
+
+STRING* Parrot_sprintf_c(struct Parrot_Interp *, char * pat, ...);
+
+void Parrot_sprintf(struct Parrot_Interp *, char *targ, char *pat, ....);
+
+void Parrot_snprintf(struct Parrot_Interp *, char *targ, INTVAL len, char *pat, ...);
+
+
+#endif
\ No newline at end of file
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/include/parrot/parrot.h
/parrot/include/parrot/parrot.h
--- /parrot-cvs/include/parrot/parrot.h Thu Jan 31 01:18:18 2002
+++ /parrot/include/parrot/parrot.h Sun Feb 3 01:15:08 2002
@@ -88,6 +88,7 @@
#include "parrot/register.h"
#include "parrot/regfuncs.h"
#include "parrot/exceptions.h"
+#include "parrot/warnings.h"
#include "parrot/memory.h"
#include "parrot/packfile.h"
#include "parrot/io.h"
@@ -98,6 +99,7 @@
#include "parrot/stacks.h"
#include "parrot/resources.h"
#include "parrot/string_funcs.h"
+#include "parrot/misc.h"
#endif
/*
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/include/parrot/warnings.h
/parrot/include/parrot/warnings.h
--- /parrot-cvs/include/parrot/warnings.h Wed Dec 31 16:00:00 1969
+++ /parrot/include/parrot/warnings.h Sun Feb 3 01:28:00 2002
@@ -0,0 +1,25 @@
+#if !defined(PARROT_WARNINGS_H_GUARD)
+#define PARROT_WARNINGS_H_GUARD
+
+#define PARROT_WARNINGS_ALL_FLAG -1
+#define PARROT_WARNINGS_NONE_FLAG 0
+#define PARROT_WARNINGS_UNDEF_FLAG 1
+#define PARROT_WARNINGS_IO_FLAG 2
+
+#if defined(PARROT_IN_CORE)
+
+#include "parrot/parrot.h"
+
+#define PARROT_WARNINGS_on(interp, flag) interp->warns->classes |= flag
+#define PARROT_WARNINGS_off(interp, flag) interp->warns->classes &= ~flag
+#define PARROT_WARNINGS_test(interp, flag) interp->warns->classes & flag
+
+INTVAL
+Parrot_warn(struct Parrot_Interp *, INTVAL warnclass, char* message, ....);
+
+INTVAL
+Parrot_warn_s(struct Parrot_Interp *, INTVAL warnclass, STRING* message, ...);
+
+#endif
+
+#endif
\ No newline at end of file
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/interpreter.c /parrot/interpreter.c
--- /parrot-cvs/interpreter.c Thu Jan 31 01:18:18 2002
+++ /parrot/interpreter.c Tue Feb 5 00:25:02 2002
@@ -466,14 +466,16 @@
/* Initialize interpreter's flags */
interpreter->flags = flags;
+ interpreter->warns = mem_sys_allocate(sizeof(struct warnings_t));
+ PARROT_WARNINGS_off(interpreter, PARROT_WARNINGS_ALL_FLAG);
interpreter->pmc_count = 0;
interpreter->string_count = 0;
/* Set up defaults for line/package/file */
interpreter->current_line = 0;
- interpreter->current_file = NULL;
- interpreter->current_package = NULL;
+ interpreter->current_file = string_make(interpreter, "(unknown file)", 14, NULL,
+0, NULL);
+ interpreter->current_package = string_make(interpreter, "(unknown package)", 18,
+NULL, 0, NULL);;
/* Set up the initial register chunks */
interpreter->int_reg_base = mem_allocate_aligned(sizeof(struct IRegChunk));
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/misc.c /parrot/misc.c
--- /parrot-cvs/misc.c Wed Dec 31 16:00:00 1969
+++ /parrot/misc.c Tue Feb 5 00:07:56 2002
@@ -0,0 +1,1241 @@
+#include "parrot/parrot.h"
+
+#include <stdarg.h>
+
+typedef long HUGEINTVAL;
+typedef unsigned long UHUGEINTVAL;
+
+typedef struct spfinfo_t {
+ INTVAL flags;
+ INTVAL width;
+ INTVAL prec;
+ INTVAL type;
+ INTVAL phase;
+} * SpfInfo;
+
+#define cstr2pstr(cstr) string_make(interpreter, cstr, strlen(cstr), NULL, 0, NULL)
+#define char2pstr(ch) string_make(interpreter, &ch, 1, NULL, 0, NULL)
+
+#define PHASE_FLAGS 0
+#define PHASE_WIDTH 1
+#define PHASE_PREC 2
+#define PHASE_TYPE 3
+#define PHASE_TERM 4
+#define PHASE_DONE 5
+
+#define FLAG_MINUS 1
+#define FLAG_PLUS 2
+#define FLAG_ZERO 4
+#define FLAG_SPACE 8
+#define FLAG_SHARP 16
+
+#define SIZE_REG 0
+#define SIZE_SHORT 1
+#define SIZE_LONG 2
+#define SIZE_HUGE 3
+#define SIZE_XVAL 4
+
+#define GetInt(targ, whichone)
+ \
+ switch(whichone) {
+ \
+ case SIZE_REG:
+ \
+ targ=(HUGEINTVAL)(int)va_arg(*args, int);
+ \
+ break;
+
+ \
+ case SIZE_SHORT:
+ \
+ targ=(HUGEINTVAL)(short)va_arg(*args, short);
+ \
+ break;
+
+ \
+ case SIZE_LONG:
+ \
+ targ=(HUGEINTVAL)(long)va_arg(*args, long);
+ \
+ break;
+
+ \
+ case SIZE_HUGE:
+ \
+ targ=(HUGEINTVAL)(long /*long*/)va_arg(*args, long /*long*/);
+ \
+ break;
+
+ \
+ case SIZE_XVAL:
+ \
+ targ=(HUGEINTVAL)(INTVAL)va_arg(*args, INTVAL);
+ \
+ break;
+
+ \
+ }
+
+#define GetUInt(targ, whichone)
+ \
+ switch(whichone) {
+ \
+ case SIZE_REG:
+ \
+ targ=(UHUGEINTVAL)(unsigned int)va_arg(*args, unsigned int);
+ \
+ break;
+
+ \
+ case SIZE_SHORT:
+ \
+ targ=(UHUGEINTVAL)(unsigned short)va_arg(*args, unsigned
+short); \
+ break;
+
+ \
+ case SIZE_LONG:
+ \
+ targ=(UHUGEINTVAL)(unsigned long)va_arg(*args, unsigned long);
+ \
+ break;
+
+ \
+ case SIZE_HUGE:
+ \
+ targ=(UHUGEINTVAL)(unsigned long /*long*/)va_arg(*args,
+unsigned long /*long*/);\
+ break;
+
+ \
+ case SIZE_XVAL:
+ \
+ targ=(UHUGEINTVAL)(UINTVAL)va_arg(*args, UINTVAL);
+ \
+ break;
+
+ \
+ }
+
+void
+uint_to_str(char *buf1, char *buf2, UHUGEINTVAL num, INTVAL base) {
+ int i=0, cur;
+
+ do {
+ cur=num % base;
+
+ if(cur < 10) {
+ buf2[i]='0'+cur;
+ }
+ else {
+ buf2[i]='a'+cur;
+ }
+
+ i++;
+ } while(num /= base);
+
+ cur=i;
+
+ for(i=0; i <= cur; i++) {
+ buf1[i]=buf2[cur-i];
+ }
+}
+
+void
+int_to_str(char *buf1, char *buf2, HUGEINTVAL num, INTVAL base) {
+ BOOLVAL neg;
+ int i=0, cur;
+
+ if(num < 0) {
+ neg=1;
+ num= -num;
+ }
+ else {
+ neg=0;
+ }
+
+ do {
+ cur=num % base;
+
+ if(cur < 10) {
+ buf2[i]='0'+cur;
+ }
+ else {
+ buf2[i]='a'+cur;
+ }
+
+ i++;
+ } while(num /= base);
+
+ if(neg) {
+ buf2[i++]='-';
+ }
+
+ cur=i;
+
+ for(i=0; i < cur; i++) {
+ buf1[i]=buf2[cur-i-1];
+ }
+
+ buf1[i]=0;
+}
+
+void
+Pad_it(SpfInfo info, char *buf) {
+ int i;
+ int len=strlen(buf);
+ int howmuch=info->width - len;
+
+ if(!info->width || howmuch == 0) {
+ return;
+ }
+ else if(howmuch < 0) {
+ memmove(buf, buf-howmuch, len+howmuch);
+ }
+ else if(info->flags & FLAG_MINUS) { //left-align
+ for(i=0; i < howmuch; i++) {
+ buf[i+len]=' ';
+ }
+
+ buf[i+len]=0;
+ }
+ else { //right-align
+ memmove(buf+howmuch, buf, len);
+
+ for(i=0; i < howmuch; i++) {
+ buf[i]=' ';
+ }
+ }
+}
+
+void
+gen_sprintf_call(char *buf, char* buf2, SpfInfo info, char thingy) {
+ int i=0;
+ buf[i++]='%';
+
+ if(info->flags) {
+ if(info->flags & FLAG_MINUS) {
+ buf[i++]='-';
+ }
+ if(info->flags & FLAG_PLUS) {
+ buf[i++]='+';
+ }
+ if(info->flags & FLAG_ZERO) {
+ buf[i++]='0';
+ }
+ if(info->flags & FLAG_SPACE) {
+ buf[i++]=' ';
+ }
+ if(info->flags & FLAG_SHARP) {
+ buf[i++]='#';
+ }
+ }
+
+ if(info->width) {
+ int_to_str(buf+i, buf2, info->width, 10);
+ i=strlen(buf);
+ }
+
+ if(info->prec) {
+ buf[i++]='.';
+ int_to_str(buf+i, buf2, info->prec, 10);
+ i=strlen(buf);
+ }
+
+ buf[i++]=thingy;
+ buf[i]=0;
+}
+
+STRING *
+Parrot_vsprintf_s(struct Parrot_Interp *interpreter, STRING* pat, va_list *args) {
+ INTVAL i;
+ STRING* targ=NULL;
+ register char * t1=mem_sys_allocate(4096);
+ register char * t2=mem_sys_allocate(4096);
+
+ for(i=0; i < string_length(pat); i++) {
+ if(string_ord(pat, i) == '%') {
+ if(string_ord(pat, i+1) == '%') {
+ i++;
+ }
+ else {
+ /* hoo boy, here we go... */
+ char * chptr;
+ STRING * string;
+ double dbl;
+ FLOATVAL fv;
+ register HUGEINTVAL theint;
+ register UHUGEINTVAL theuint;
+
+ struct spfinfo_t info={0, 0, 0, 0, 0};
+
+ for(i++; i < string_length(pat) && info.phase !=
+PHASE_DONE; i++) {
+ char ch=string_ord(pat, i);
+AGAIN:
+ switch(info.phase) {
+ case PHASE_FLAGS:
+ switch(ch) {
+ case '-':
+ info.flags |=
+FLAG_MINUS; break;
+
+ case '+':
+ info.flags |=
+FLAG_PLUS; break;
+
+ case '0':
+ info.flags |=
+FLAG_ZERO; break;
+
+ case ' ':
+ info.flags |=
+FLAG_SPACE; break;
+
+ case '#':
+ info.flags |=
+FLAG_SHARP; break;
+
+ default:
+
+info.phase=PHASE_WIDTH;
+ goto AGAIN;
+ }
+
+ case PHASE_WIDTH:
+ switch(ch) {
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '8':
+ case '9':
+ info.width *=
+10;
+ info.width +=
+ch-'0';
+ break;
+
+ case '.':
+
+info.phase=PHASE_PREC;
+ continue;
+
+ default:
+
+info.phase=PHASE_PREC;
+ goto AGAIN;
+ }
+
+ case PHASE_PREC:
+ switch(ch) {
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '8':
+ case '9':
+ info.prec *=
+10;
+ info.prec +=
+ch-'0';
+ continue;
+
+ default:
+
+info.phase=PHASE_TYPE;
+ goto AGAIN;
+ }
+
+ case PHASE_TYPE:
+ switch(ch) {
+ case 'h':
+
+info.type=SIZE_SHORT; break;
+
+ case 'l':
+
+info.type=SIZE_LONG; break;
+
+ case 'H':
+
+info.type=SIZE_HUGE; break;
+
+ case 'v':
+
+info.type=SIZE_XVAL; break;
+
+ default:
+
+info.phase=PHASE_TERM;
+ goto AGAIN;
+ }
+
+ info.phase=PHASE_TERM;
+ continue;
+
+ case PHASE_TERM:
+ switch(ch) {
+ /* INTEGERS */
+ case 'c':
+
+targ=string_concat(interpreter, targ, char2pstr(ch), 0);
+ break;
+
+ case 'd':
+ case 'i':
+ GetInt(theint,
+info.type);
+ int_to_str(t1,
+t2, theint, 10);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t1), 0);
+ break;
+
+ case 'o':
+ GetInt(theint,
+info.type);
+ int_to_str(t1,
+t2, theint, 8);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t1), 0);
+ break;
+
+ case 'x':
+ GetInt(theint,
+info.type);
+ int_to_str(t1,
+t2, theint, 16);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t1), 0);
+ break;
+
+ case 'u':
+
+GetUInt(theuint, info.type);
+
+uint_to_str(t1, t2, theuint, 10);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t1), 0);
+ break;
+
+ case 'p':
+
+chptr=va_arg(*args, void*);
+ int_to_str(t1,
+t2, (HUGEINTVAL)chptr, 16);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t1), 0);
+ break;
+
+ /* FLOATS - We cheat
+on these and use the system sprintf. */
+ case 'e':
+
+dbl=va_arg(*args, double);
+
+gen_sprintf_call(t1, t2, &info, 'e');
+ sprintf(t2,
+t1, dbl);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t2), 0);
+ break;
+
+ case 'E':
+
+dbl=va_arg(*args, double);
+
+gen_sprintf_call(t1, t2, &info, 'E');
+ sprintf(t2,
+t1, dbl);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t2), 0);
+ break;
+
+ case 'f':
+
+dbl=va_arg(*args, double);
+
+gen_sprintf_call(t1, t2, &info, 'f');
+ sprintf(t2,
+t1, dbl);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t2), 0);
+ break;
+
+ case 'g':
+
+dbl=va_arg(*args, double);
+
+gen_sprintf_call(t1, t2, &info, 'g');
+ sprintf(t2,
+t1, dbl);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t2), 0);
+ break;
+
+ case 'G':
+
+dbl=va_arg(*args, double);
+
+gen_sprintf_call(t1, t2, &info, 'G');
+ sprintf(t2,
+t1, dbl);
+
+targ=string_concat(interpreter, targ, cstr2pstr(t2), 0);
+ break;
+
+ /* STRINGS */
+ case 's':
+
+chptr=va_arg(*args, char*);
+
+targ=string_concat(interpreter, targ, cstr2pstr(chptr), 0);
+ break;
+
+ case 'S':
+
+string=va_arg(*args, STRING*);
+
+targ=string_concat(interpreter, targ, string, 0);
+ break;
+ }
+
+ info.phase=PHASE_DONE;
+ }
+ }
+ }
+
+ i--;
+ }
+ else {
+ STRING* substr=NULL;
+ string_substr(interpreter, pat, i, 1, &substr);
+ targ=string_concat(interpreter, targ, substr,0);
+ }
+ }
+
+ mem_sys_free(t1);
+ mem_sys_free(t2);
+
+ return targ;
+}
+
+
+STRING *
+Parrot_vsprintf_c(struct Parrot_Interp *interpreter, char *pat, va_list *args) {
+ STRING *realpat=string_make(interpreter, pat, strlen(pat), NULL, 0, NULL);
+
+ return Parrot_vsprintf_s(interpreter, realpat, args);
+}
+void
+Parrot_vsprintf(struct Parrot_Interp *interpreter, char *targ, char *pat, va_list
+*args) {
+ STRING *ret=Parrot_vsprintf_c(interpreter, pat, args);
+/* string_transcode(interpreter, ret, NULL, NULL, &ret);*/
+
+ memcpy(targ, ret->bufstart, ret->bufused);
+ targ[ret->bufused+1]=00;
+}
+
+void
+Parrot_vsnprintf(struct Parrot_Interp *interpreter, char *targ, UINTVAL len, char
+*pat, va_list *args) {
+ STRING *ret=Parrot_vsprintf_c(interpreter, pat, args);
+ string_transcode(interpreter, ret, NULL, NULL, &ret);
+
+ if(len > ret->bufused) {
+ len=ret->bufused;
+ }
+
+ memcpy(targ, ret->bufstart, len);
+ targ[len+1]=0;
+}
+
+STRING *
+Parrot_sprintf_s(struct Parrot_Interp *interpreter, STRING* pat, ...)
+{
+ STRING *ret;
+ va_list args;
+
+ va_start(args, pat);
+
+ ret=Parrot_vsprintf_s(interpreter, pat, &args);
+
+ va_end(args);
+
+ return ret;
+}
+
+STRING *
+Parrot_sprintf_c(struct Parrot_Interp *interpreter, char* pat, ...) {
+ STRING *ret;
+ va_list args;
+
+ va_start(args, pat);
+
+ ret=Parrot_vsprintf_c(interpreter, pat, &args);
+
+ va_end(args);
+
+ return ret;
+}
+
+void
+Parrot_sprintf(struct Parrot_Interp *interpreter, char* targ, char* pat, ...) {
+ va_list args;
+
+ va_start(args, pat);
+
+ Parrot_vsprintf(interpreter, targ, pat, &args);
+
+ va_end(args);
+}
+
+void
+Parrot_snprintf(struct Parrot_Interp *interpreter, char* targ, UINTVAL len, char*
+pat, ...) {
+ va_list args;
+
+ va_start(args, pat);
+
+ Parrot_vsnprintf(interpreter, targ, len, pat, &args);
+
+ va_end(args);
+}
+
+#if 0
+void /* barely started conversion to Parrot, but abandoned it. */
+perl5s_vsprintf(struct Parrot_Interp *interpreter, STRING *targ, const char *pat,
+INTVAL patlen, va_list *args)
+{
+ char *p;
+ char *q;
+ char *patend;
+ INTVAL origlen;
+ INTVAL svix = 0;
+ static char nullstr[] = "(null)";
+ STRING *argsv = NULL;
+
+ /* special-case "", "%s", and "%_" */
+ if (patlen == 0) {
+ return;
+ }
+
+ if (patlen == 2 && pat[0] == '%') {
+ switch (pat[1]) {
+ case 's':
+ if (args) {
+ char *s = va_arg(*args, char*);
+ //sv_catpv(sv, s ? s : nullstr);
+ targ=string_concat(interpreter, "
+ }
+ else if (svix < svmax) {
+ sv_catsv(sv, *svargs);
+ if (DO_UTF8(*svargs))
+ SvUTF8_on(sv);
+ }
+ return;
+ case '_':
+ if (args) {
+ argsv = va_arg(*args, SV*);
+ sv_catsv(sv, argsv);
+ if (DO_UTF8(argsv))
+ SvUTF8_on(sv);
+ return;
+ }
+ /* See comment on '_' below */
+ break;
+ }
+ }
+
+ patend = (char*)pat + patlen;
+ for (p = (char*)pat; p < patend; p = q) {
+ bool alt = FALSE;
+ bool left = FALSE;
+ bool vectorize = FALSE;
+ bool vectorarg = FALSE;
+ bool vec_utf = FALSE;
+ char fill = ' ';
+ char plus = 0;
+ char intsize = 0;
+ INTVAL width = 0;
+ INTVAL zeros = 0;
+ bool has_precis = FALSE;
+ INTVAL precis = 0;
+ bool is_utf = FALSE;
+
+ char esignbuf[4];
+ U8 utf8buf[UTF8_MAXLEN+1];
+ INTVAL esignlen = 0;
+
+ char *eptr = Nullch;
+ INTVAL elen = 0;
+ /* Times 4: a decimal digit takes more than 3 binary digits.
+ * NV_DIG: mantissa takes than many decimal digits.
+ * Plus 32: Playing safe. */
+ char ebuf[IV_DIG * 4 + NV_DIG + 32];
+ /* large enough for "%#.#f" --chip */
+ /* what about long double NVs? --jhi */
+
+ SV *vecsv;
+ U8 *vecstr = Null(U8*);
+ INTVAL veclen = 0;
+ char c;
+ int i;
+ unsigned base = 0;
+ IV iv = 0;
+ UV uv = 0;
+ NV nv;
+ INTVAL have;
+ INTVAL need;
+ INTVAL gap;
+ char *dotstr = ".";
+ INTVAL dotstrlen = 1;
+ INTVAL efix = 0; /* explicit format parameter index */
+ INTVAL ewix = 0; /* explicit width index */
+ INTVAL epix = 0; /* explicit precision index */
+ INTVAL evix = 0; /* explicit vector index */
+ bool asterisk = FALSE;
+
+ /* echo everything up to the next format specification */
+ for (q = p; q < patend && *q != '%'; ++q) ;
+ if (q > p) {
+ sv_catpvn(sv, p, q - p);
+ p = q;
+ }
+ if (q++ >= patend)
+ break;
+
+/*
+ We allow format specification elements in this order:
+ \d+\$ explicit format parameter index
+ [-+ 0#]+ flags
+ \*?(\d+\$)?v vector with optional (optionally specified) arg
+ \d+|\*(\d+\$)? width using optional (optionally specified) arg
+ \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
+ [hlqLV] size
+ [%bcdefginopsux_DFOUX] format (mandatory)
+*/
+ if (EXPECT_NUMBER(q, width)) {
+ if (*q == '$') {
+ ++q;
+ efix = width;
+ } else {
+ goto gotwidth;
+ }
+ }
+
+ /* FLAGS */
+
+ while (*q) {
+ switch (*q) {
+ case ' ':
+ case '+':
+ plus = *q++;
+ continue;
+
+ case '-':
+ left = TRUE;
+ q++;
+ continue;
+
+ case '0':
+ fill = *q++;
+ continue;
+
+ case '#':
+ alt = TRUE;
+ q++;
+ continue;
+
+ default:
+ break;
+ }
+ break;
+ }
+
+ tryasterisk:
+ if (*q == '*') {
+ q++;
+ if (EXPECT_NUMBER(q, ewix))
+ if (*q++ != '$')
+ goto unknown;
+ asterisk = TRUE;
+ }
+ if (*q == 'v') {
+ q++;
+ if (vectorize)
+ goto unknown;
+ if ((vectorarg = asterisk)) {
+ evix = ewix;
+ ewix = 0;
+ asterisk = FALSE;
+ }
+ vectorize = TRUE;
+ goto tryasterisk;
+ }
+
+ if (!asterisk)
+ EXPECT_NUMBER(q, width);
+
+ if (vectorize) {
+ if (vectorarg) {
+ if (args)
+ vecsv = va_arg(*args, SV*);
+ else
+ vecsv = (evix ? evix <= svmax : svix < svmax) ?
+ svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
+ dotstr = SvPVx(vecsv, dotstrlen);
+ if (DO_UTF8(vecsv))
+ is_utf = TRUE;
+ }
+ if (args) {
+ vecsv = va_arg(*args, SV*);
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ vec_utf = DO_UTF8(vecsv);
+ }
+ else if (efix ? efix <= svmax : svix < svmax) {
+ vecsv = svargs[efix ? efix-1 : svix++];
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ vec_utf = DO_UTF8(vecsv);
+ }
+ else {
+ vecstr = (U8*)"";
+ veclen = 0;
+ }
+ }
+
+ if (asterisk) {
+ if (args)
+ i = va_arg(*args, int);
+ else
+ i = (ewix ? ewix <= svmax : svix < svmax) ?
+ SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
+ left |= (i < 0);
+ width = (i < 0) ? -i : i;
+ }
+ gotwidth:
+
+ /* PRECISION */
+
+ if (*q == '.') {
+ q++;
+ if (*q == '*') {
+ q++;
+ if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
+ goto unknown;
+ if (args)
+ i = va_arg(*args, int);
+ else
+ i = (ewix ? ewix <= svmax : svix < svmax)
+ ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
+ precis = (i < 0) ? 0 : i;
+ }
+ else {
+ precis = 0;
+ while (isDIGIT(*q))
+ precis = precis * 10 + (*q++ - '0');
+ }
+ has_precis = TRUE;
+ }
+
+ /* SIZE */
+
+ switch (*q) {
+#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+ case 'L': /* Ld */
+ /* FALL THROUGH */
+#endif
+#ifdef HAS_QUAD
+ case 'q': /* qd */
+ intsize = 'q';
+ q++;
+ break;
+#endif
+ case 'l':
+#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+ if (*(q + 1) == 'l') { /* lld, llf */
+ intsize = 'q';
+ q += 2;
+ break;
+ }
+#endif
+ /* FALL THROUGH */
+ case 'h':
+ /* FALL THROUGH */
+ case 'V':
+ intsize = *q++;
+ break;
+ }
+
+ /* CONVERSION */
+
+ if (*q == '%') {
+ eptr = q++;
+ elen = 1;
+ goto string;
+ }
+
+ if (!args)
+ argsv = (efix ? efix <= svmax : svix < svmax) ?
+ svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
+
+ switch (c = *q++) {
+
+ /* STRINGS */
+
+ case 'c':
+ uv = args ? va_arg(*args, int) : SvIVx(argsv);
+ if ((uv > 255 ||
+ (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
+ && !IN_BYTES) {
+ eptr = (char*)utf8buf;
+ elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
+ is_utf = TRUE;
+ }
+ else {
+ c = (char)uv;
+ eptr = &c;
+ elen = 1;
+ }
+ goto string;
+
+ case 's':
+ if (args) {
+ eptr = va_arg(*args, char*);
+ if (eptr)
+#ifdef MACOS_TRADITIONAL
+ /* On MacOS, %#s format is used for Pascal strings */
+ if (alt)
+ elen = *eptr++;
+ else
+#endif
+ elen = strlen(eptr);
+ else {
+ eptr = nullstr;
+ elen = sizeof nullstr - 1;
+ }
+ }
+ else {
+ eptr = SvPVx(argsv, elen);
+ if (DO_UTF8(argsv)) {
+ if (has_precis && precis < elen) {
+ INTVAL p = precis;
+ sv_pos_u2b(argsv, &p, 0); /* sticks at end */
+ precis = p;
+ }
+ if (width) { /* fudge width (can't fudge elen) */
+ width += elen - sv_len_utf8(argsv);
+ }
+ is_utf = TRUE;
+ }
+ }
+ goto string;
+
+ case '_':
+ /*
+ * The "%_" hack might have to be changed someday,
+ * if ISO or ANSI decide to use '_' for something.
+ * So we keep it hidden from users' code.
+ */
+ if (!args)
+ goto unknown;
+ argsv = va_arg(*args, SV*);
+ eptr = SvPVx(argsv, elen);
+ if (DO_UTF8(argsv))
+ is_utf = TRUE;
+
+ string:
+ vectorize = FALSE;
+ if (has_precis && elen > precis)
+ elen = precis;
+ break;
+
+ /* INTEGERS */
+
+ case 'p':
+ if (alt)
+ goto unknown;
+ uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
+ base = 16;
+ goto integer;
+
+ case 'D':
+#ifdef IV_IS_QUAD
+ intsize = 'q';
+#else
+ intsize = 'l';
+#endif
+ /* FALL THROUGH */
+ case 'd':
+ case 'i':
+ if (vectorize) {
+ INTVAL ulen;
+ if (!veclen)
+ continue;
+ if (vec_utf)
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
+ else {
+ uv = *vecstr;
+ ulen = 1;
+ }
+ vecstr += ulen;
+ veclen -= ulen;
+ if (plus)
+ esignbuf[esignlen++] = plus;
+ }
+ else if (args) {
+ switch (intsize) {
+ case 'h': iv = (short)va_arg(*args, int); break;
+ default: iv = va_arg(*args, int); break;
+ case 'l': iv = va_arg(*args, long); break;
+ case 'V': iv = va_arg(*args, IV); break;
+#ifdef HAS_QUAD
+ case 'q': iv = va_arg(*args, Quad_t); break;
+#endif
+ }
+ }
+ else {
+ iv = SvIVx(argsv);
+ switch (intsize) {
+ case 'h': iv = (short)iv; break;
+ default: break;
+ case 'l': iv = (long)iv; break;
+ case 'V': break;
+#ifdef HAS_QUAD
+ case 'q': iv = (Quad_t)iv; break;
+#endif
+ }
+ }
+ if ( !vectorize ) /* we already set uv above */
+ {
+ if (iv >= 0) {
+ uv = iv;
+ if (plus)
+ esignbuf[esignlen++] = plus;
+ }
+ else {
+ uv = -iv;
+ esignbuf[esignlen++] = '-';
+ }
+ }
+ base = 10;
+ goto integer;
+
+ case 'U':
+#ifdef IV_IS_QUAD
+ intsize = 'q';
+#else
+ intsize = 'l';
+#endif
+ /* FALL THROUGH */
+ case 'u':
+ base = 10;
+ goto uns_integer;
+
+ case 'b':
+ base = 2;
+ goto uns_integer;
+
+ case 'O':
+#ifdef IV_IS_QUAD
+ intsize = 'q';
+#else
+ intsize = 'l';
+#endif
+ /* FALL THROUGH */
+ case 'o':
+ base = 8;
+ goto uns_integer;
+
+ case 'X':
+ case 'x':
+ base = 16;
+
+ uns_integer:
+ if (vectorize) {
+ INTVAL ulen;
+ vector:
+ if (!veclen)
+ continue;
+ if (vec_utf)
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
+ else {
+ uv = *vecstr;
+ ulen = 1;
+ }
+ vecstr += ulen;
+ veclen -= ulen;
+ }
+ else if (args) {
+ switch (intsize) {
+ case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
+ default: uv = va_arg(*args, unsigned); break;
+ case 'l': uv = va_arg(*args, unsigned long); break;
+ case 'V': uv = va_arg(*args, UV); break;
+#ifdef HAS_QUAD
+ case 'q': uv = va_arg(*args, Quad_t); break;
+#endif
+ }
+ }
+ else {
+ uv = SvUVx(argsv);
+ switch (intsize) {
+ case 'h': uv = (unsigned short)uv; break;
+ default: break;
+ case 'l': uv = (unsigned long)uv; break;
+ case 'V': break;
+#ifdef HAS_QUAD
+ case 'q': uv = (Quad_t)uv; break;
+#endif
+ }
+ }
+
+ integer:
+ eptr = ebuf + sizeof ebuf;
+ switch (base) {
+ unsigned dig;
+ case 16:
+ if (!uv)
+ alt = FALSE;
+ p = (char*)((c == 'X')
+ ? "0123456789ABCDEF" : "0123456789abcdef");
+ do {
+ dig = uv & 15;
+ *--eptr = p[dig];
+ } while (uv >>= 4);
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = c; /* 'x' or 'X' */
+ }
+ break;
+ case 8:
+ do {
+ dig = uv & 7;
+ *--eptr = '0' + dig;
+ } while (uv >>= 3);
+ if (alt && *eptr != '0')
+ *--eptr = '0';
+ break;
+ case 2:
+ do {
+ dig = uv & 1;
+ *--eptr = '0' + dig;
+ } while (uv >>= 1);
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = 'b';
+ }
+ break;
+ default: /* it had better be ten or less */
+#if defined(PERL_Y2KWARN)
+ if (ckWARN(WARN_Y2K)) {
+ INTVAL n;
+ char *s = SvPV(sv,n);
+ if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
+ && (n == 2 || !isDIGIT(s[n-3])))
+ {
+ Perl_warner(aTHX_ WARN_Y2K,
+ "Possible Y2K bug: %%%c %s",
+ c, "format string following '19'");
+ }
+ }
+#endif
+ do {
+ dig = uv % base;
+ *--eptr = '0' + dig;
+ } while (uv /= base);
+ break;
+ }
+ elen = (ebuf + sizeof ebuf) - eptr;
+ if (has_precis) {
+ if (precis > elen)
+ zeros = precis - elen;
+ else if (precis == 0 && elen == 1 && *eptr == '0')
+ elen = 0;
+ }
+ break;
+
+ /* FLOATING POINT */
+
+ case 'F':
+ c = 'f'; /* maybe %F isn't supported here */
+ /* FALL THROUGH */
+ case 'e': case 'E':
+ case 'f':
+ case 'g': case 'G':
+
+ /* This is evil, but floating point is even more evil */
+
+ vectorize = FALSE;
+ nv = args ? va_arg(*args, NV) : SvNVx(argsv);
+
+ need = 0;
+ if (c != 'e' && c != 'E') {
+ i = PERL_INT_MIN;
+ (void)Perl_frexp(nv, &i);
+ if (i == PERL_INT_MIN)
+ Perl_die(aTHX_ "panic: frexp");
+ if (i > 0)
+ need = BIT_DIGITS(i);
+ }
+ need += has_precis ? precis : 6; /* known default */
+ if (need < width)
+ need = width;
+
+ need += 20; /* fudge factor */
+ if (PL_efloatsize < need) {
+ Safefree(PL_efloatbuf);
+ PL_efloatsize = need + 20; /* more fudge */
+ New(906, PL_efloatbuf, PL_efloatsize, char);
+ PL_efloatbuf[0] = '\0';
+ }
+
+ eptr = ebuf + sizeof ebuf;
+ *--eptr = '\0';
+ *--eptr = c;
+#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+ {
+ /* Copy the one or more characters in a long double
+ * format before the 'base' ([efgEFG]) character to
+ * the format string. */
+ static char const prifldbl[] = PERL_PRIfldbl;
+ char const *p = prifldbl + sizeof(prifldbl) - 3;
+ while (p >= prifldbl) { *--eptr = *p--; }
+ }
+#endif
+ if (has_precis) {
+ base = precis;
+ do { *--eptr = '0' + (base % 10); } while (base /= 10);
+ *--eptr = '.';
+ }
+ if (width) {
+ base = width;
+ do { *--eptr = '0' + (base % 10); } while (base /= 10);
+ }
+ if (fill == '0')
+ *--eptr = fill;
+ if (left)
+ *--eptr = '-';
+ if (plus)
+ *--eptr = plus;
+ if (alt)
+ *--eptr = '#';
+ *--eptr = '%';
+
+ /* No taint. Otherwise we are in the strange situation
+ * where printf() taints but print($float) doesn't.
+ * --jhi */
+ (void)sprintf(PL_efloatbuf, eptr, nv);
+
+ eptr = PL_efloatbuf;
+ elen = strlen(PL_efloatbuf);
+ break;
+
+ /* SPECIAL */
+
+ case 'n':
+ vectorize = FALSE;
+ i = SvCUR(sv) - origlen;
+ if (args) {
+ switch (intsize) {
+ case 'h': *(va_arg(*args, short*)) = i; break;
+ default: *(va_arg(*args, int*)) = i; break;
+ case 'l': *(va_arg(*args, long*)) = i; break;
+ case 'V': *(va_arg(*args, IV*)) = i; break;
+#ifdef HAS_QUAD
+ case 'q': *(va_arg(*args, Quad_t*)) = i; break;
+#endif
+ }
+ }
+ else
+ sv_setuv_mg(argsv, (UV)i);
+ continue; /* not "break" */
+
+ /* UNKNOWN */
+
+ default:
+ unknown:
+ vectorize = FALSE;
+ if (!args && ckWARN(WARN_PRINTF) &&
+ (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
+ SV *msg = sv_newmortal();
+ Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
+ (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
+ if (c) {
+ if (isPRINT(c))
+ Perl_sv_catpvf(aTHX_ msg,
+ "\"%%%c\"", c & 0xFF);
+ else
+ Perl_sv_catpvf(aTHX_ msg,
+ "\"%%\\%03"UVof"\"",
+ (UV)c & 0xFF);
+ } else
+ sv_catpv(msg, "end of string");
+ Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant
+*/
+ }
+
+ /* output mangled stuff ... */
+ if (c == '\0')
+ --q;
+ eptr = p;
+ elen = q - p;
+
+ /* ... right here, because formatting flags should not apply */
+ SvGROW(sv, SvCUR(sv) + elen + 1);
+ p = SvEND(sv);
+ Copy(eptr, p, elen, char);
+ p += elen;
+ *p = '\0';
+ SvCUR(sv) = p - SvPVX(sv);
+ continue; /* not "break" */
+ }
+
+ have = esignlen + zeros + elen;
+ need = (have > width ? have : width);
+ gap = need - have;
+
+ SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
+ p = SvEND(sv);
+ if (esignlen && fill == '0') {
+ for (i = 0; i < esignlen; i++)
+ *p++ = esignbuf[i];
+ }
+ if (gap && !left) {
+ memset(p, fill, gap);
+ p += gap;
+ }
+ if (esignlen && fill != '0') {
+ for (i = 0; i < esignlen; i++)
+ *p++ = esignbuf[i];
+ }
+ if (zeros) {
+ for (i = zeros; i; i--)
+ *p++ = '0';
+ }
+ if (elen) {
+ Copy(eptr, p, elen, char);
+ p += elen;
+ }
+ if (gap && left) {
+ memset(p, ' ', gap);
+ p += gap;
+ }
+ if (vectorize) {
+ if (veclen) {
+ Copy(dotstr, p, dotstrlen, char);
+ p += dotstrlen;
+ }
+ else
+ vectorize = FALSE; /* done iterating over vecstr */
+ }
+ if (is_utf)
+ SvUTF8_on(sv);
+ *p = '\0';
+ SvCUR(sv) = p - SvPVX(sv);
+ if (vectorize) {
+ esignlen = 0;
+ goto vector;
+ }
+ }
+}
+#endif
\ No newline at end of file
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/test_main.c /parrot/test_main.c
--- /parrot-cvs/test_main.c Tue Feb 5 00:36:28 2002
+++ /parrot/test_main.c Mon Feb 4 22:25:00 2002
@@ -73,13 +73,19 @@
case 'P':
setopt(PARROT_PREDEREF_FLAG); break;
case 't':
- setopt(PARROT_TRACE_FLAG); break;
+ setopt(PARROT_TRACE_FLAG); break;
case 'd':
- setopt(PARROT_DEBUG_FLAG); break;
+ setopt(PARROT_DEBUG_FLAG); break;
case 'h':
- usage(); break;
+ usage(); break;
case 'v':
- version(); break;
+ version(); break;
+ case 'w':
+ Parrot_setwarnings(interpreter,
+PARROT_WARNINGS_ALL_FLAG); break;
+
+ case '.':
+ fgetc(stdin); break;
+
case '-':
(*argc)--;
(*argv)++;
diff -uNrx CVS -x .cvs -x .# /parrot-cvs/warnings.c /parrot/warnings.c
--- /parrot-cvs/warnings.c Wed Dec 31 16:00:00 1969
+++ /parrot/warnings.c Sun Feb 3 01:23:08 2002
@@ -0,0 +1,61 @@
+#include "parrot/parrot.h"
+
+#include <stdarg.h>
+
+INTVAL
+Parrot_warn(struct Parrot_Interp *interpreter, INTVAL warnclass, char* message, ...) {
+ STRING * targ;
+
+ va_list args;
+ va_start(args, message);
+
+ if(!PARROT_WARNINGS_test(interpreter, warnclass)) {
+ return 2;
+ }
+
+ if(!(targ=Parrot_vsprintf_c(interpreter, message, &args))) {
+ return -1;
+ }
+
+ va_end(args);
+
+ if(!(targ=Parrot_sprintf_c(interpreter, "%S at %S line %d.\n", targ,
+interpreter->current_file, interpreter->current_line))) {
+ return -1;
+ }
+
+ if(PIO_write(interpreter, PIO_STDERR(interpreter), targ->bufstart,
+targ->bufused) < 0) {
+ return -2;
+ }
+ else {
+ return 1;
+ }
+}
+
+INTVAL
+Parrot_warn_s(struct Parrot_Interp *interpreter, INTVAL warnclass, STRING* message,
+...) {
+ STRING * targ;
+
+ va_list args;
+ va_start(args, message);
+
+ if(!PARROT_WARNINGS_test(interpreter, warnclass)) {
+ return 2;
+ }
+
+ if(!(targ=Parrot_vsprintf_s(interpreter, message, &args))) {
+ return -1;
+ }
+
+ va_end(args);
+
+ if(!(targ=Parrot_sprintf_c(interpreter, "%S at %S line %d.\n", targ,
+interpreter->current_file, interpreter->current_line))) {
+ return -1;
+ }
+
+ if(PIO_write(interpreter, PIO_STDERR(interpreter), targ->bufstart,
+targ->bufused) < 0) {
+ return -2;
+ }
+ else {
+ return 1;
+ }
+}
\ No newline at end of file
