This patch cleans up most of the MSVC-warnings when using warning level 4
(the highest, one above the default level 3). It turns off two level-4
warnings for 'unreferenced formal parameter' and 'named type definition in
parentheses', the latter of which was turning up warnings in MS VC headers.
Level 4 warnings also helped me find a couple of other lurking bugs in the
parrot code.
Replaces the various fprintf/exit combos with calls to internal_exception,
which uses var_args to emulate printf. Various exception types were added as
well. These are probably temporary until a real exception system arrives.
Fixed some places in the IO code where wrong functions were being called, or
put into the vtable.
This patch tests correctly on MSVC and cygwin. If this patch is too broad,
please let me know and I'll go back and split it up. It's my first patch,
and I'll be sure to use multiple checkout directories to allow future
patches to be more localized.
Mike Lambert
Index: Configure.pl
===================================================================
RCS file: /home/perlcvs/parrot/Configure.pl,v
retrieving revision 1.79
diff -c -r1.79 Configure.pl
*** Configure.pl 13 Jan 2002 19:44:28 -0000 1.79
--- Configure.pl 14 Jan 2002 16:40:52 -0000
***************
*** 304,310 ****
if ($a eq 'core.ops') { -1 }
elsif($b eq 'core.ops') { 1 }
else { $a cmp $b }
! } grep {!/obscure\.ops/} @ops;
my $msg;
--- 304,310 ----
if ($a eq 'core.ops') { -1 }
elsif($b eq 'core.ops') { 1 }
else { $a cmp $b }
! } grep {!/obscure\.ops/ && !/vtable\.ops/} @ops;
my $msg;
Index: MANIFEST
===================================================================
RCS file: /home/perlcvs/parrot/MANIFEST,v
retrieving revision 1.93
diff -c -r1.93 MANIFEST
*** MANIFEST 11 Jan 2002 00:32:56 -0000 1.93
--- MANIFEST 14 Jan 2002 16:40:52 -0000
***************
*** 86,91 ****
--- 86,92 ----
examples/mops/mops.py
examples/mops/mops.rb
examples/mops/mops.scheme
+ exceptions.c
global_setup.c
hints/cygwin.pl
hints/darwin.pl
Index: Makefile.in
===================================================================
RCS file: /home/perlcvs/parrot/Makefile.in,v
retrieving revision 1.116
diff -c -r1.116 Makefile.in
*** Makefile.in 13 Jan 2002 19:37:47 -0000 1.116
--- Makefile.in 14 Jan 2002 16:40:52 -0000
***************
*** 76,82 ****
IO_O_FILES = io/io$(O) io/io_stdio$(O) io/io_unix$(O) io/io_win32$(O)
! INTERP_O_FILES = 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)
--- 76,82 ----
IO_O_FILES = io/io$(O) io/io_stdio$(O) io/io_unix$(O) io/io_win32$(O)
! 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)
***************
*** 281,286 ****
--- 281,288 ----
chartype/usascii$(O): $(H_FILES)
chartype/unicode$(O): $(H_FILES)
+
+ exceptions$(O): $(H_FILES)
encoding/singlebyte$(O): $(H_FILES)
Index: core.ops
===================================================================
RCS file: /home/perlcvs/parrot/core.ops,v
retrieving revision 1.77
diff -c -r1.77 core.ops
*** core.ops 13 Jan 2002 19:23:14 -0000 1.77
--- core.ops 14 Jan 2002 16:40:52 -0000
***************
*** 150,156 ****
}
inline op open(out INT, in STR) {
! if (! ($1 = (INTVAL)fopen(($2)->bufstart, "r+"))) {
perror("Can't open");
exit(1);
}
--- 150,157 ----
}
inline op open(out INT, in STR) {
! $1 = (INTVAL)fopen(($2)->bufstart, "r+");
! if (!$1) {
perror("Can't open");
exit(1);
}
***************
*** 1499,1505 ****
inline op repeat(out STR, in STR, in INT) {
if ($3 < 0) {
! INTERNAL_EXCEPTION(NEG_REPEAT, "Cannot repeat with negative arg");
}
$1 = string_repeat(interpreter, $2, (UINTVAL)$3, NULL);
goto NEXT();
--- 1500,1506 ----
inline op repeat(out STR, in STR, in INT) {
if ($3 < 0) {
! internal_exception(NEG_REPEAT, "Cannot repeat with negative arg");
}
$1 = string_repeat(interpreter, $2, (UINTVAL)$3, NULL);
goto NEXT();
***************
*** 2269,2275 ****
Stack_Entry entry;
depth = stack_depth(interpreter, interpreter->user_stack);
if (depth <= $2) {
! INTERNAL_EXCEPTION(99, "Stack Depth wrong");
}
entry = stack_entry(interpreter, interpreter->user_stack, $2);
--- 2270,2276 ----
Stack_Entry entry;
depth = stack_depth(interpreter, interpreter->user_stack);
if (depth <= $2) {
! internal_exception(99, "Stack Depth wrong");
}
entry = stack_entry(interpreter, interpreter->user_stack, $2);
***************
*** 2526,2532 ****
inline op sleep(in INT) {
if ($1 < 0) {
! INTERNAL_EXCEPTION(NEG_SLEEP, "Cannot go back in time");
}
Parrot_sleep((UINTVAL)$1);
goto NEXT();
--- 2527,2533 ----
inline op sleep(in INT) {
if ($1 < 0) {
! internal_exception(NEG_SLEEP, "Cannot go back in time");
}
Parrot_sleep((UINTVAL)$1);
goto NEXT();
Index: global_setup.c
===================================================================
RCS file: /home/perlcvs/parrot/global_setup.c,v
retrieving revision 1.17
diff -c -r1.17 global_setup.c
*** global_setup.c 13 Jan 2002 17:45:31 -0000 1.17
--- global_setup.c 14 Jan 2002 16:40:52 -0000
***************
*** 21,26 ****
--- 21,27 ----
void Parrot_PerlString_class_init(void);
void Parrot_PerlArray_class_init(void);
void Parrot_PerlHash_class_init(void);
+ void Parrot_ParrotPointer_class_init(void);
void Parrot_IntQueue_class_init(void);
void
Index: interpreter.c
===================================================================
RCS file: /home/perlcvs/parrot/interpreter.c,v
retrieving revision 1.59
diff -c -r1.59 interpreter.c
*** interpreter.c 14 Jan 2002 07:07:01 -0000 1.59
--- interpreter.c 14 Jan 2002 16:40:53 -0000
***************
*** 73,80 ****
pc = core(interpreter, pc);
if (pc && (pc < code_start || pc >= code_end)) {
! fprintf(stderr, "Error: Control left bounds of byte-code block (now at
location %d)!\n", (int) (pc - code_start));
! exit(1);
}
}
--- 73,79 ----
pc = core(interpreter, pc);
if (pc && (pc < code_start || pc >= code_end)) {
! internal_exception(INTERP_ERROR, "Error: Control left bounds of
byte-code block (now at location %d)!\n", (int) (pc - code_start));
}
}
***************
*** 117,139 ****
prederef_oplib_handle = Parrot_dlopen(file_name);
if (!prederef_oplib_handle) {
! fprintf(stderr, "Unable to dynamically load oplib file '%s' for oplib
'%s_prederef' version %s!\n",
file_name, PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
-
- exit(1);
}
/*
** Look up the init function:
*/
! prederef_oplib_init = (oplib_init_f)Parrot_dlsym(prederef_oplib_handle,
func_name);
if (!prederef_oplib_init) {
! fprintf(stderr, "No exported symbol for oplib init function '%s' from oplib file
'%s' for oplib '%s_prederef' version %s!\n",
func_name, file_name, PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
-
- exit(1);
}
/*
--- 116,134 ----
prederef_oplib_handle = Parrot_dlopen(file_name);
if (!prederef_oplib_handle) {
! internal_exception(PREDEREF_LOAD_ERROR, "Unable to dynamically load oplib file
'%s' for oplib '%s_prederef' version %s!\n",
file_name, PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
}
/*
** Look up the init function:
*/
! prederef_oplib_init =
(oplib_init_f)(ptrcast_t)Parrot_dlsym(prederef_oplib_handle, func_name);
if (!prederef_oplib_init) {
! internal_exception(PREDEREF_LOAD_ERROR, "No exported symbol for oplib init
function '%s' from oplib file '%s' for oplib '%s_prederef' version %s!\n",
func_name, file_name, PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
}
/*
***************
*** 143,152 ****
prederef_oplib = prederef_oplib_init();
if (!prederef_oplib) {
! fprintf(stderr, "No oplib info returned by oplib init function '%s' from oplib
file '%s' for oplib '%s_prederef' version %s!\n",
func_name, file_name,
PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
- exit(1);
}
/*
--- 138,146 ----
prederef_oplib = prederef_oplib_init();
if (!prederef_oplib) {
! internal_exception(PREDEREF_LOAD_ERROR, "No oplib info returned by oplib init
function '%s' from oplib file '%s' for oplib '%s_prederef' version %s!\n",
func_name, file_name,
PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
}
/*
***************
*** 156,165 ****
prederef_op_count = prederef_oplib->op_count;
if (prederef_op_count <= 0) {
! fprintf(stderr, "Illegal op count (%d) from oplib file '%s' for oplib
'%s_prederef' version %s!\n",
(int)prederef_op_count, file_name,
PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
- exit(1);
}
/*
--- 150,158 ----
prederef_op_count = prederef_oplib->op_count;
if (prederef_op_count <= 0) {
! internal_exception(PREDEREF_LOAD_ERROR, "Illegal op count (%d) from oplib file
'%s' for oplib '%s_prederef' version %s!\n",
(int)prederef_op_count, file_name,
PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
}
/*
***************
*** 169,178 ****
prederef_op_info = prederef_oplib->op_info_table;
if (!prederef_op_info) {
! fprintf(stderr, "No op info table in oplib file '%s' for oplib '%s_prederef'
version %s!\n",
file_name,
PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
- exit(1);
}
/*
--- 162,170 ----
prederef_op_info = prederef_oplib->op_info_table;
if (!prederef_op_info) {
! internal_exception(PREDEREF_LOAD_ERROR, "No op info table in oplib file '%s' for
oplib '%s_prederef' version %s!\n",
file_name,
PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
}
/*
***************
*** 182,191 ****
prederef_op_func = prederef_oplib->op_func_table;
if (!prederef_op_func) {
! fprintf(stderr, "No op func table in oplib file '%s' for oplib '%s_prederef'
version %s!\n",
file_name,
PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
- exit(1);
}
}
--- 174,182 ----
prederef_op_func = prederef_oplib->op_func_table;
if (!prederef_op_func) {
! internal_exception(PREDEREF_LOAD_ERROR, "No op func table in oplib file '%s' for
oplib '%s_prederef' version %s!\n",
file_name,
PARROT_CORE_OPLIB_NAME, PARROT_VERSION);
}
}
***************
*** 237,243 ****
for (i = 0; i < opinfo->arg_count; i++) {
switch (opinfo->types[i]) {
case PARROT_ARG_OP:
! pc_prederef[i] = (void *)prederef_op_func[pc[i]];
break;
case PARROT_ARG_I:
--- 228,234 ----
for (i = 0; i < opinfo->arg_count; i++) {
switch (opinfo->types[i]) {
case PARROT_ARG_OP:
! pc_prederef[i] = (void *)(ptrcast_t)prederef_op_func[pc[i]];
break;
case PARROT_ARG_I:
***************
*** 268,275 ****
case PARROT_ARG_PC:
/* pc_prederef[i] = (void *)
&interpreter->code->const_table->constants[pc[i]]->pmc; */
! fprintf(stderr, "PMC constants not yet supported!\n");
! exit(1);
break;
case PARROT_ARG_SC:
--- 259,265 ----
case PARROT_ARG_PC:
/* pc_prederef[i] = (void *)
&interpreter->code->const_table->constants[pc[i]]->pmc; */
! internal_exception(ARG_OP_NOT_HANDLED, "PMC constants not yet
supported!\n");
break;
case PARROT_ARG_SC:
***************
*** 282,289 ****
}
if (opinfo->types[i] != PARROT_ARG_IC && pc_prederef[i] == 0) {
! fprintf(stderr, "Prederef generated a NULL pointer for arg of type %d!\n",
opinfo->types[i]);
! exit(1);
}
}
--- 272,278 ----
}
if (opinfo->types[i] != PARROT_ARG_IC && pc_prederef[i] == 0) {
! internal_exception(INTERP_ERROR, "Prederef generated a NULL pointer for arg of
type %d!\n", opinfo->types[i]);
}
}
***************
*** 353,359 ****
while (pc_prederef) {
pc_prederef =
! ((op_func_prederef_t)*pc_prederef) (pc_prederef, interpreter);
}
stop_prederef();
--- 342,348 ----
while (pc_prederef) {
pc_prederef =
! ((op_func_prederef_t)(ptrcast_t)*pc_prederef) (pc_prederef,
interpreter);
}
stop_prederef();
***************
*** 366,373 ****
}
if (pc && (pc < code_start || pc >= code_end)) {
! fprintf(stderr, "Error: Control left bounds of byte-code block (now at
location %d)!\n", (int) (pc - code_start));
! exit(1);
}
}
--- 355,361 ----
}
if (pc && (pc < code_start || pc >= code_end)) {
! internal_exception(INTERP_ERROR, "Error: Control left bounds of byte-code
block (now at location %d)!\n", (int) (pc - code_start));
}
}
***************
*** 421,427 ****
void ** temp = (void **)malloc(N * sizeof(void *));
for (i = 0; i < N; i++) {
! temp[i] = (void *)prederef;
}
interpreter->prederef_code = temp;
--- 409,415 ----
void ** temp = (void **)malloc(N * sizeof(void *));
for (i = 0; i < N; i++) {
! temp[i] = (void *)(ptrcast_t)prederef;
}
interpreter->prederef_code = temp;
***************
*** 431,441 ****
interpreter->prederef_code + offset);
}
else if ((interpreter->flags & PARROT_JIT_FLAG) != 0) {
! if (!JIT_CAPABLE) {
! fprintf(stderr,
! "Error: PARROT_JIT_FLAG is set, but interpreter is not JIT_CAPABLE!\n");
! exit(1);
! }
runops_jit(interpreter, pc);
}
--- 419,427 ----
interpreter->prederef_code + offset);
}
else if ((interpreter->flags & PARROT_JIT_FLAG) != 0) {
! #if !JIT_CAPABLE
! internal_exception( JIT_UNAVAILABLE, "Error: PARROT_JIT_FLAG is set, but
interpreter is not JIT_CAPABLE!\n");
! #endif
runops_jit(interpreter, pc);
}
Index: key.c
===================================================================
RCS file: /home/perlcvs/parrot/key.c,v
retrieving revision 1.15
diff -c -r1.15 key.c
*** key.c 13 Jan 2002 19:39:35 -0000 1.15
--- key.c 14 Jan 2002 16:40:53 -0000
***************
*** 284,305 ****
KEY_PAIR*
key_element_value_s(struct Parrot_Interp *interpreter, KEY* key, STRING* idx) {
! KEY_PAIR* pair;
if(key != NULL) {
if(idx != NULL) {
INTVAL hash = key_hash(interpreter,idx);
hash = hash % NUM_BUCKETS;
pair = find_bucket(interpreter,(BUCKET *)key->keys[hash].cache.struct_val,idx);
if(pair == NULL) {
! fprintf(stderr,"*** key_element_value_s pair returning a null key\n");
}
}
else {
! fprintf(stderr,"*** key_element_value_s given a NULL index\n");
}
}
else {
! fprintf(stderr,"*** key_element_value_s given a NULL key\n");
}
return pair;
}
--- 284,305 ----
KEY_PAIR*
key_element_value_s(struct Parrot_Interp *interpreter, KEY* key, STRING* idx) {
! KEY_PAIR* pair = NULL;
if(key != NULL) {
if(idx != NULL) {
INTVAL hash = key_hash(interpreter,idx);
hash = hash % NUM_BUCKETS;
pair = find_bucket(interpreter,(BUCKET *)key->keys[hash].cache.struct_val,idx);
if(pair == NULL) {
! internal_exception(KEY_NOT_FOUND,"*** key_element_value_s pair returning a
null key\n");
}
}
else {
! internal_exception(KEY_NOT_FOUND,"*** key_element_value_s given a NULL
index\n");
}
}
else {
! internal_exception(KEY_NOT_FOUND,"*** key_element_value_s given a NULL key\n");
}
return pair;
}
***************
*** 320,331 ****
memcpy(&key->keys[idx],value,sizeof(KEY_PAIR));
}
else {
! fprintf(stderr,
! "*** key_set_element_value_i setting value out of bounds\n");
}
}
else {
! fprintf(stderr,"*** key_set_element_value_i assigning to a NULL key\n");
}
}
--- 320,330 ----
memcpy(&key->keys[idx],value,sizeof(KEY_PAIR));
}
else {
! internal_exception(KEY_NOT_FOUND, "*** key_set_element_value_i setting value
out of bounds\n");
}
}
else {
! internal_exception(KEY_NOT_FOUND, "*** key_set_element_value_i assigning to a
NULL key\n");
}
}
Index: ops2c.pl
===================================================================
RCS file: /home/perlcvs/parrot/ops2c.pl,v
retrieving revision 1.13
diff -c -r1.13 ops2c.pl
*** ops2c.pl 7 Jan 2002 17:01:17 -0000 1.13
--- ops2c.pl 14 Jan 2002 16:40:53 -0000
***************
*** 13,19 ****
sub Usage {
print STDERR <<_EOF_;
! usage: $0 trans input.ops [input2.ops ...]\n";
_EOF_
exit 1;
}
--- 13,19 ----
sub Usage {
print STDERR <<_EOF_;
! usage: $0 trans input.ops [input2.ops ...]
_EOF_
exit 1;
}
***************
*** 110,115 ****
--- 110,116 ----
END_C
+ print $header;
print HEADER $preamble;
print HEADER <<END_C;
#include "parrot/parrot.h"
Index: register.c
===================================================================
RCS file: /home/perlcvs/parrot/register.c,v
retrieving revision 1.15
diff -c -r1.15 register.c
*** register.c 12 Jan 2002 15:33:08 -0000 1.15
--- register.c 14 Jan 2002 16:40:53 -0000
***************
*** 95,101 ****
}
/* Nope. So pitch a fit */
else {
! INTERNAL_EXCEPTION(NO_REG_FRAMES,
"No more I register frames to pop!");
}
}
--- 95,101 ----
}
/* Nope. So pitch a fit */
else {
! internal_exception(NO_REG_FRAMES,
"No more I register frames to pop!");
}
}
***************
*** 201,207 ****
}
/* Nope. So pitch a fit */
else {
! INTERNAL_EXCEPTION(NO_REG_FRAMES,
"No more S register frames to pop!");
}
}
--- 201,207 ----
}
/* Nope. So pitch a fit */
else {
! internal_exception(NO_REG_FRAMES,
"No more S register frames to pop!");
}
}
***************
*** 301,307 ****
}
/* Nope. So pitch a fit */
else {
! INTERNAL_EXCEPTION(NO_REG_FRAMES,
"No more N register frames to pop!");
}
}
--- 301,307 ----
}
/* Nope. So pitch a fit */
else {
! internal_exception(NO_REG_FRAMES,
"No more N register frames to pop!");
}
}
***************
*** 405,411 ****
}
/* Nope. So pitch a fit */
else {
! INTERNAL_EXCEPTION(NO_REG_FRAMES,
"No more P register frames to pop!");
}
}
--- 405,411 ----
}
/* Nope. So pitch a fit */
else {
! internal_exception(NO_REG_FRAMES,
"No more P register frames to pop!");
}
}
Index: runops_cores.c
===================================================================
RCS file: /home/perlcvs/parrot/runops_cores.c,v
retrieving revision 1.9
diff -c -r1.9 runops_cores.c
*** runops_cores.c 14 Jan 2002 07:07:01 -0000 1.9
--- runops_cores.c 14 Jan 2002 16:40:53 -0000
***************
*** 44,51 ****
opcode_t * code_start;
INTVAL code_size;
opcode_t * code_end;
! opcode_t * lastpc;
! FLOATVAL time;
code_start = (opcode_t *)interpreter->code->byte_code;
code_size = interpreter->code->byte_code_size;
--- 44,51 ----
opcode_t * code_start;
INTVAL code_size;
opcode_t * code_end;
! opcode_t * lastpc = NULL;
! FLOATVAL time = 0;
code_start = (opcode_t *)interpreter->code->byte_code;
code_size = interpreter->code->byte_code_size;
Index: rx.ops
===================================================================
RCS file: /home/perlcvs/parrot/rx.ops,v
retrieving revision 1.5
diff -c -r1.5 rx.ops
*** rx.ops 12 Jan 2002 15:18:01 -0000 1.5
--- rx.ops 14 Jan 2002 16:40:54 -0000
***************
*** 235,241 ****
=cut
op rx_cloneinfo(inout pmc) {
! RX_dUNPACK($1);
goto NEXT();
}
--- 235,241 ----
=cut
op rx_cloneinfo(inout pmc) {
! /* RX_dUNPACK($1); */
goto NEXT();
}
***************
*** 545,551 ****
=cut
op rx_setprops(in pmc, in str, in int) {
! int i;
RX_dUNPACK($1);
rx->minlength=$3;
--- 545,551 ----
=cut
op rx_setprops(in pmc, in str, in int) {
! UINTVAL i;
RX_dUNPACK($1);
rx->minlength=$3;
***************
*** 663,675 ****
########################################
! =item C<rx_is_n>(in pmc, in int)
! Matches a number character (usually C<\n>).
=cut
! op rx_is_n(in pmc, in int) {
RX_dUNPACK($1);
RxAssertMore(rx, $2);
--- 663,675 ----
########################################
! =item C<rx_is_d>(in pmc, in int)
! Matches a number character (usually C<\d>).
=cut
! op rx_is_d(in pmc, in int) {
RX_dUNPACK($1);
RxAssertMore(rx, $2);
***************
*** 724,730 ****
RX_dUNPACK($1);
STRING *ch1;
STRING *ch2;
! INTVAL i;
/* XXX In the future, this ought to use bitmaps. */
--- 724,730 ----
RX_dUNPACK($1);
STRING *ch1;
STRING *ch2;
! UINTVAL i;
/* XXX In the future, this ought to use bitmaps. */
***************
*** 748,760 ****
}
else {
/* binary search--fast but complicated */
! INTVAL upper, lower=0, index=0, lastindex=-1, cmp;
upper=string_length($2);
while(upper > lower) {
index=(upper+lower)/2;
if(index==lastindex) {
goto OFFSET($3);
}
--- 748,763 ----
}
else {
/* binary search--fast but complicated */
! UINTVAL upper, lower=0, index=0, lastindex=0, cmp;
upper=string_length($2);
while(upper > lower) {
index=(upper+lower)/2;
+ /* lastindex should not be able to equal index on the first
+pass.
+ this could only happen if string_length($2) is 0, so I
+believe this is safe
+ */
if(index==lastindex) {
goto OFFSET($3);
}
Index: stacks.c
===================================================================
RCS file: /home/perlcvs/parrot/stacks.c,v
retrieving revision 1.16
diff -c -r1.16 stacks.c
*** stacks.c 10 Jan 2002 23:14:56 -0000 1.16
--- stacks.c 14 Jan 2002 16:40:54 -0000
***************
*** 69,75 ****
}
if (stack_depth(interpreter, stack) < depth) {
! INTERNAL_EXCEPTION(ERROR_STACK_SHALLOW, "Stack too shallow!\n");
}
if (depth == 1) {
--- 69,75 ----
}
if (stack_depth(interpreter, stack) < depth) {
! internal_exception(ERROR_STACK_SHALLOW, "Stack too shallow!\n");
}
if (depth == 1) {
***************
*** 165,178 ****
/* Quick sanity check */
if (chunk->used == 0) {
! INTERNAL_EXCEPTION(ERROR_STACK_EMPTY, "No entries on stack!\n");
}
entry = &chunk->entry[chunk->used - 1];
/* Types of 0 mean we don't care */
if (type && entry->entry_type != type) {
! INTERNAL_EXCEPTION(ERROR_BAD_STACK_TYPE,
"Wrong type on top of stack!\n");
}
--- 165,178 ----
/* Quick sanity check */
if (chunk->used == 0) {
! internal_exception(ERROR_STACK_EMPTY, "No entries on stack!\n");
}
entry = &chunk->entry[chunk->used - 1];
/* Types of 0 mean we don't care */
if (type && entry->entry_type != type) {
! internal_exception(ERROR_BAD_STACK_TYPE,
"Wrong type on top of stack!\n");
}
Index: string.c
===================================================================
RCS file: /home/perlcvs/parrot/string.c,v
retrieving revision 1.42
diff -c -r1.42 string.c
*** string.c 12 Jan 2002 15:33:08 -0000 1.42
--- string.c 14 Jan 2002 16:40:54 -0000
***************
*** 106,112 ****
}
if((s == NULL) || (len == 0)) {
! INTERNAL_EXCEPTION(ORD_OUT_OF_STRING,
"Cannot get character of empty string");
}
else {
--- 106,112 ----
}
if((s == NULL) || (len == 0)) {
! internal_exception(ORD_OUT_OF_STRING,
"Cannot get character of empty string");
}
else {
***************
*** 115,136 ****
if (idx < 0) {
if ((INTVAL)(idx + len) < 0) {
! INTERNAL_EXCEPTION(ORD_OUT_OF_STRING,
"Cannot get character before beginning of
string");
- }
- else {
- true_index = (UINTVAL)(len + idx);
}
}
! if (true_index > (len - 1)) {
! INTERNAL_EXCEPTION(ORD_OUT_OF_STRING,
"Cannot get character past end of string");
}
return string_index(s, true_index);
}
! return -1;
}
/*=for api string string_copy
--- 115,136 ----
if (idx < 0) {
if ((INTVAL)(idx + len) < 0) {
! internal_exception(ORD_OUT_OF_STRING,
"Cannot get character before beginning of
string");
}
+ else {
+ true_index = (UINTVAL)(len + idx);
}
+ }
! if (true_index > (len - 1)) {
! internal_exception(ORD_OUT_OF_STRING,
"Cannot get character past end of string");
}
return string_index(s, true_index);
}
! return -1;
}
/*=for api string string_copy
***************
*** 301,307 ****
true_offset = (UINTVAL)offset;
/* Allow regexes to return $' easily for "aaa" =~ /aaa/ */
! if (offset == string_length(src) || length < 1) {
return NULL;
}
--- 301,307 ----
true_offset = (UINTVAL)offset;
/* Allow regexes to return $' easily for "aaa" =~ /aaa/ */
! if (offset == (INTVAL)string_length(src) || length < 1) {
return NULL;
}
***************
*** 310,317 ****
}
if (true_offset > src->strlen-1) { /* 0 based... */
! INTERNAL_EXCEPTION(SUBSTR_OUT_OF_STRING,
! "Cannot take substr outside string")
}
true_length = (UINTVAL) length;
if (length < 0) {
--- 310,317 ----
}
if (true_offset > src->strlen-1) { /* 0 based... */
! internal_exception(SUBSTR_OUT_OF_STRING,
! "Cannot take substr outside string");
}
true_length = (UINTVAL) length;
if (length < 0) {
***************
*** 326,332 ****
subend = src->encoding->skip_forward(substart, true_length);
if (subend < substart) {
! INTERNAL_EXCEPTION(SUBSTR_OUT_OF_STRING,
"subend somehow is less than substart");
}
--- 326,332 ----
subend = src->encoding->skip_forward(substart, true_length);
if (subend < substart) {
! internal_exception(SUBSTR_OUT_OF_STRING,
"subend somehow is less than substart");
}
Index: test_main.c
===================================================================
RCS file: /home/perlcvs/parrot/test_main.c,v
retrieving revision 1.34
diff -c -r1.34 test_main.c
*** test_main.c 14 Jan 2002 07:07:01 -0000 1.34
--- test_main.c 14 Jan 2002 16:40:54 -0000
***************
*** 112,119 ****
argc -= 2;
}
else {
! fprintf(stderr, "%s: Invalid switch: %s\n", argv[0], argv[1]);
! exit(1);
}
}
--- 112,118 ----
argc -= 2;
}
else {
! internal_exception(PARROT_USAGE_ERROR, "%s: Invalid switch: %s\n",
argv[0], argv[1]);
}
}
***************
*** 128,139 ****
}
if (jit) {
! if (!JIT_CAPABLE) {
! fprintf(stderr, "%s: Cannot use the '-j' JIT-enabling flag on this
architecture: %s\n",
! argv[0], JIT_ARCHNAME);
! exit(1);
! }
flags |= PARROT_JIT_FLAG;
}
if (profiling) {
--- 127,137 ----
}
if (jit) {
! #if !JIT_CAPABLE
! internal_exception( JIT_UNAVAILABLE, "%s: Cannot use the '-j'
JIT-enabling flag on this architecture: " JIT_ARCHNAME "\n", argv[0]);
! #else
flags |= PARROT_JIT_FLAG;
+ #endif
}
if (profiling) {
***************
*** 153,160 ****
/* If we got only the program name, complain */
if (argc == 1 && !filename && !from_stdin) {
! fprintf(stderr, "%s: usage: %s prog\n", argv[0], argv[0]);
! exit(1);
}
/* Otherwise load in the program they gave and try that, or - */
else {
--- 151,157 ----
/* If we got only the program name, complain */
if (argc == 1 && !filename && !from_stdin) {
! internal_exception(PARROT_USAGE_ERROR, "%s: usage: %s prog\n", argv[0],
argv[0]);
}
/* Otherwise load in the program they gave and try that, or - */
else {
***************
*** 172,204 ****
if (from_stdin) {
char *cursor;
INTVAL read_result;
- INTVAL read_last;
! program_size = 1024;
! program_code = (opcode_t*)malloc(1024);
if (NULL == program_code) {
fprintf(stderr, "Could not allocate buffer to read stdin\n");
}
cursor = (char*)program_code;
while ((read_result = read(0, cursor, 1024)) > 0) {
! read_last = read_result;
! program_size += 1024;
! program_code = realloc(program_code, program_size);
if (NULL == program_code) {
fprintf(stderr,
"Could not reallocate buffer to read stdin\n");
}
! cursor = (char*)program_code + program_size - 1024;
}
! if (read_result == 0) {
! program_size = program_size - 2048 + read_last;
! }
! else if (read_result < 0) {
! fprintf(stderr, "Problem reading from stdin\n");
! exit(1);
}
}
else { /* read from file */
--- 169,195 ----
if (from_stdin) {
char *cursor;
INTVAL read_result;
! program_size = 0;
! program_code = (opcode_t*)malloc(program_size + 1024);
if (NULL == program_code) {
fprintf(stderr, "Could not allocate buffer to read stdin\n");
}
cursor = (char*)program_code;
while ((read_result = read(0, cursor, 1024)) > 0) {
! program_size += read_result;
! program_code = realloc(program_code, program_size + 1024);
if (NULL == program_code) {
fprintf(stderr,
"Could not reallocate buffer to read stdin\n");
}
! cursor = (char*)program_code + program_size;
}
! if (read_result < 0) {
! internal_exception(IO_ERROR,"Problem reading from stdin\n");
}
}
else { /* read from file */
Index: trace.c
===================================================================
RCS file: /home/perlcvs/parrot/trace.c,v
retrieving revision 1.7
diff -c -r1.7 trace.c
*** trace.c 1 Jan 2002 18:25:05 -0000 1.7
--- trace.c 14 Jan 2002 16:40:54 -0000
***************
*** 71,77 ****
case PARROT_ARG_OP:
/* this isn't handled, so at least report the error
instead of silently ignoring the problem */
! INTERNAL_EXCEPTION(ARG_OP_NOT_HANDLED,
"PARROT_ARG_OP in enumeration not handled in
switch");
break;
default:
--- 71,77 ----
case PARROT_ARG_OP:
/* this isn't handled, so at least report the error
instead of silently ignoring the problem */
! internal_exception(ARG_OP_NOT_HANDLED,
"PARROT_ARG_OP in enumeration not handled in
switch");
break;
default:
Index: chartypes/unicode.c
===================================================================
RCS file: /home/perlcvs/parrot/chartypes/unicode.c,v
retrieving revision 1.5
diff -c -r1.5 unicode.c
*** chartypes/unicode.c 4 Jan 2002 16:17:46 -0000 1.5
--- chartypes/unicode.c 14 Jan 2002 16:40:54 -0000
***************
*** 24,30 ****
static BOOLVAL
unicode_is_digit(INTVAL c) {
! return isdigit(c) ? 1 : 0; /* FIXME - Other code points are also digits */
}
static INTVAL
--- 24,30 ----
static BOOLVAL
unicode_is_digit(INTVAL c) {
! return (BOOLVAL)(isdigit(c)); /* FIXME - Other code points are also digits */
}
static INTVAL
Index: chartypes/usascii.c
===================================================================
RCS file: /home/perlcvs/parrot/chartypes/usascii.c,v
retrieving revision 1.3
diff -c -r1.3 usascii.c
*** chartypes/usascii.c 27 Dec 2001 18:50:27 -0000 1.3
--- chartypes/usascii.c 14 Jan 2002 16:40:54 -0000
***************
*** 15,21 ****
static INTVAL
usascii_transcode_from_unicode(INTVAL c) {
if (c < 0 || c > 127) {
! INTERNAL_EXCEPTION(INVALID_CHARACTER, "Invalid character for US-ASCII");
}
return c;
}
--- 15,21 ----
static INTVAL
usascii_transcode_from_unicode(INTVAL c) {
if (c < 0 || c > 127) {
! internal_exception(INVALID_CHARACTER, "Invalid character for US-ASCII");
}
return c;
}
***************
*** 23,29 ****
static CHARTYPE_TRANSCODER
usascii_transcode_from(const char *from) {
if (strcmp(from, "unicode") == 0) {
! return usascii_transcode_from_unicode;
}
else {
return NULL;
--- 23,29 ----
static CHARTYPE_TRANSCODER
usascii_transcode_from(const char *from) {
if (strcmp(from, "unicode") == 0) {
! return &usascii_transcode_from_unicode;
}
else {
return NULL;
***************
*** 38,44 ****
static CHARTYPE_TRANSCODER
usascii_transcode_to(const char *to) {
if (strcmp(to, "unicode") == 0) {
! return usascii_transcode_to_unicode;
}
else {
return NULL;
--- 38,44 ----
static CHARTYPE_TRANSCODER
usascii_transcode_to(const char *to) {
if (strcmp(to, "unicode") == 0) {
! return &usascii_transcode_to_unicode;
}
else {
return NULL;
***************
*** 47,53 ****
static BOOLVAL
usascii_is_digit(INTVAL c) {
! return isdigit(c) ? 1 : 0;
}
static INTVAL
--- 47,53 ----
static BOOLVAL
usascii_is_digit(INTVAL c) {
! return (BOOLVAL)(isdigit(c));
}
static INTVAL
Index: classes/default.pmc
===================================================================
RCS file: /home/perlcvs/parrot/classes/default.pmc,v
retrieving revision 1.7
diff -c -r1.7 default.pmc
*** classes/default.pmc 10 Jan 2002 22:30:13 -0000 1.7
--- classes/default.pmc 14 Jan 2002 16:40:54 -0000
***************
*** 88,94 ****
/* I think this should cover this correctly, is_same implies that
same B<data> used by each, but as meaning of data is a little
vtable reliant, I include that test as well */
! return SELF->vtable == pmc2->vtable && &SELF->cache == &pmc2->cache;
}
/* The set methods merely make the appropriate part of the cache
--- 88,94 ----
/* I think this should cover this correctly, is_same implies that
same B<data> used by each, but as meaning of data is a little
vtable reliant, I include that test as well */
! return (BOOLVAL)(SELF->vtable == pmc2->vtable && &SELF->cache == &pmc2->cache);
}
/* The set methods merely make the appropriate part of the cache
***************
*** 408,414 ****
/* lala, I can't hear you */
}
! void modulus_float (INTVAL value, PMC* dest) {
/* XXX: makes all arguments integers...*/
INTVAL result;
--- 408,414 ----
/* lala, I can't hear you */
}
! void modulus_float (FLOATVAL value, PMC* dest) {
/* XXX: makes all arguments integers...*/
INTVAL result;
Index: classes/parrotpointer.pmc
===================================================================
RCS file: /home/perlcvs/parrot/classes/parrotpointer.pmc,v
retrieving revision 1.4
diff -c -r1.4 parrotpointer.pmc
*** classes/parrotpointer.pmc 12 Jan 2002 15:13:33 -0000 1.4
--- classes/parrotpointer.pmc 14 Jan 2002 16:40:54 -0000
***************
*** 11,17 ****
*/
#include "parrot/parrot.h"
! #define ERROR fprintf(stderr, "An illegal operation was performed on a ParrotPointer
(vtable function at %s line %d).\n", __FILE__, __LINE__); exit(1); return;
pmclass ParrotPointer {
INTVAL type () {
--- 11,17 ----
*/
#include "parrot/parrot.h"
! #define POINTER_ERROR internal_exception(PARROT_POINTER_ERROR, "An illegal operation
was performed on a ParrotPointer (vtable function at %s line %d).\n", __FILE__,
__LINE__);
pmclass ParrotPointer {
INTVAL type () {
***************
*** 72,78 ****
}
BOOLVAL get_bool () {
! return (BOOLVAL)SELF->data;
}
void* get_value () {
--- 72,78 ----
}
BOOLVAL get_bool () {
! return (BOOLVAL)(SELF->data != NULL);
}
void* get_value () {
***************
*** 80,150 ****
}
BOOLVAL is_same (PMC* pmc2) {
! return SELF->vtable == pmc2->vtable && SELF->data == pmc2->data;
}
void set_integer (PMC * value) {
! ERROR;
}
void set_integer_native (INTVAL value) {
! ERROR;
}
void set_integer_bigint (BIGINT value) {
! ERROR;
}
void set_integer_same (PMC * value) {
! ERROR;
}
void set_integer_index (INTVAL value, INTVAL index) {
! ERROR;
}
void set_number (PMC * value) {
! ERROR;
}
void set_number_native (FLOATVAL value) {
! ERROR;
}
void set_number_bigfloat (BIGFLOAT value) {
! ERROR;
}
void set_number_same (PMC * value) {
! ERROR;
}
void set_number_index (FLOATVAL value, INTVAL index) {
! ERROR;
}
void set_string (PMC * value) {
! ERROR;
}
void set_string_native (STRING * value) {
! ERROR;
}
void set_string_unicode (STRING * value) {
! ERROR;
}
void set_string_other (STRING * value) {
! ERROR;
}
void set_string_same (PMC * value) {
! ERROR;
}
void set_string_index (STRING* value, INTVAL index) {
! ERROR;
}
void set_value (void * value) {
--- 80,150 ----
}
BOOLVAL is_same (PMC* pmc2) {
! return (BOOLVAL)(SELF->vtable == pmc2->vtable && SELF->data == pmc2->data);
}
void set_integer (PMC * value) {
! POINTER_ERROR;
}
void set_integer_native (INTVAL value) {
! POINTER_ERROR;
}
void set_integer_bigint (BIGINT value) {
! POINTER_ERROR;
}
void set_integer_same (PMC * value) {
! POINTER_ERROR;
}
void set_integer_index (INTVAL value, INTVAL index) {
! POINTER_ERROR;
}
void set_number (PMC * value) {
! POINTER_ERROR;
}
void set_number_native (FLOATVAL value) {
! POINTER_ERROR;
}
void set_number_bigfloat (BIGFLOAT value) {
! POINTER_ERROR;
}
void set_number_same (PMC * value) {
! POINTER_ERROR;
}
void set_number_index (FLOATVAL value, INTVAL index) {
! POINTER_ERROR;
}
void set_string (PMC * value) {
! POINTER_ERROR;
}
void set_string_native (STRING * value) {
! POINTER_ERROR;
}
void set_string_unicode (STRING * value) {
! POINTER_ERROR;
}
void set_string_other (STRING * value) {
! POINTER_ERROR;
}
void set_string_same (PMC * value) {
! POINTER_ERROR;
}
void set_string_index (STRING* value, INTVAL index) {
! POINTER_ERROR;
}
void set_value (void * value) {
Index: classes/perlarray.pmc
===================================================================
RCS file: /home/perlcvs/parrot/classes/perlarray.pmc,v
retrieving revision 1.6
diff -c -r1.6 perlarray.pmc
*** classes/perlarray.pmc 13 Jan 2002 19:40:02 -0000 1.6
--- classes/perlarray.pmc 14 Jan 2002 16:40:55 -0000
***************
*** 89,95 ****
BOOLVAL get_bool () {
KEY* key = SELF->cache.struct_val;
INTVAL size = key_size(INTERP,key);
! return (size != 0);
}
void* get_value () {
--- 89,95 ----
BOOLVAL get_bool () {
KEY* key = SELF->cache.struct_val;
INTVAL size = key_size(INTERP,key);
! return (BOOLVAL)(size != 0);
}
void* get_value () {
***************
*** 99,106 ****
BOOLVAL is_same (PMC* other) {
STRING* s1 = (STRING*)SELF->cache.struct_val;
STRING* s2 = (STRING*)other->cache.struct_val;
! return other->vtable == SELF->vtable
! && (strcmp(s1->bufstart,s2->bufstart)==0);
}
void set_integer (PMC* value) {
--- 99,106 ----
BOOLVAL is_same (PMC* other) {
STRING* s1 = (STRING*)SELF->cache.struct_val;
STRING* s2 = (STRING*)other->cache.struct_val;
! return (BOOLVAL)( other->vtable == SELF->vtable
! && (strcmp(s1->bufstart,s2->bufstart)==0) );
}
void set_integer (PMC* value) {
Index: classes/perlhash.pmc
===================================================================
RCS file: /home/perlcvs/parrot/classes/perlhash.pmc,v
retrieving revision 1.4
diff -c -r1.4 perlhash.pmc
*** classes/perlhash.pmc 10 Jan 2002 22:46:02 -0000 1.4
--- classes/perlhash.pmc 14 Jan 2002 16:40:55 -0000
***************
*** 107,114 ****
BOOLVAL is_same (PMC* other) {
STRING* s1 = (STRING*)SELF->cache.struct_val;
STRING* s2 = (STRING*)other->cache.struct_val;
! return other->vtable == SELF->vtable
! && (strcmp(s1->bufstart,s2->bufstart)==0);
}
void set_integer (PMC* value) {
--- 107,114 ----
BOOLVAL is_same (PMC* other) {
STRING* s1 = (STRING*)SELF->cache.struct_val;
STRING* s2 = (STRING*)other->cache.struct_val;
! return (BOOLVAL)( other->vtable == SELF->vtable
! && (strcmp(s1->bufstart,s2->bufstart)==0) );
}
void set_integer (PMC* value) {
Index: classes/perlint.pmc
===================================================================
RCS file: /home/perlcvs/parrot/classes/perlint.pmc,v
retrieving revision 1.13
diff -c -r1.13 perlint.pmc
*** classes/perlint.pmc 9 Jan 2002 17:24:15 -0000 1.13
--- classes/perlint.pmc 14 Jan 2002 16:40:55 -0000
***************
*** 77,83 ****
}
BOOLVAL get_bool () {
! return pmc->cache.int_val != 0;
}
void* get_value () {
--- 77,83 ----
}
BOOLVAL get_bool () {
! return (BOOLVAL)(pmc->cache.int_val != 0);
}
void* get_value () {
***************
*** 86,93 ****
BOOLVAL is_same (PMC* other) {
/* Do you refer to exactly the same data that I do? */
! return other->vtable == SELF->vtable /* You never know if you've been
inherited...*/
! && SELF->cache.int_val == other->cache.int_val;
}
void set_integer (PMC* value) {
--- 86,93 ----
BOOLVAL is_same (PMC* other) {
/* Do you refer to exactly the same data that I do? */
! return (BOOLVAL)( other->vtable == SELF->vtable /* You never know if you've
been inherited...*/
! && SELF->cache.int_val == other->cache.int_val );
}
void set_integer (PMC* value) {
***************
*** 479,485 ****
/* == operation */
BOOLVAL is_equal (PMC* value) {
! return SELF->cache.int_val == value->vtable->get_integer(INTERP, value);
}
void logical_or (PMC* value, PMC* dest) {
--- 479,485 ----
/* == operation */
BOOLVAL is_equal (PMC* value) {
! return (BOOLVAL)(SELF->cache.int_val == value->vtable->get_integer(INTERP,
value));
}
void logical_or (PMC* value, PMC* dest) {
Index: classes/perlnum.pmc
===================================================================
RCS file: /home/perlcvs/parrot/classes/perlnum.pmc,v
retrieving revision 1.15
diff -c -r1.15 perlnum.pmc
*** classes/perlnum.pmc 13 Jan 2002 19:23:42 -0000 1.15
--- classes/perlnum.pmc 14 Jan 2002 16:40:55 -0000
***************
*** 77,83 ****
}
BOOLVAL get_bool () {
! return pmc->cache.num_val != 0.0;
}
void* get_value () {
--- 77,83 ----
}
BOOLVAL get_bool () {
! return (BOOLVAL)(pmc->cache.num_val != 0.0);
}
void* get_value () {
***************
*** 86,93 ****
BOOLVAL is_same (PMC* other) {
/* Do you refer to exactly the same data that I do? */
! return other->vtable == SELF->vtable /* You never know if you've been
inherited...*/
! && SELF->cache.num_val == other->cache.num_val;
}
void set_integer (PMC* value) {
--- 86,93 ----
BOOLVAL is_same (PMC* other) {
/* Do you refer to exactly the same data that I do? */
! return (BOOLVAL)( other->vtable == SELF->vtable /* You never know if you've
been inherited...*/
! && SELF->cache.num_val == other->cache.num_val );
}
void set_integer (PMC* value) {
***************
*** 410,416 ****
/* == operation */
BOOLVAL is_equal (PMC* value) {
! return SELF->cache.num_val == value->vtable->get_number(INTERP, value);
}
void logical_or (PMC* value, PMC* dest) = default;
--- 410,416 ----
/* == operation */
BOOLVAL is_equal (PMC* value) {
! return (BOOLVAL)(SELF->cache.num_val == value->vtable->get_number(INTERP,
value));
}
void logical_or (PMC* value, PMC* dest) = default;
Index: classes/perlstring.pmc
===================================================================
RCS file: /home/perlcvs/parrot/classes/perlstring.pmc,v
retrieving revision 1.13
diff -c -r1.13 perlstring.pmc
*** classes/perlstring.pmc 4 Jan 2002 16:09:01 -0000 1.13
--- classes/perlstring.pmc 14 Jan 2002 16:40:55 -0000
***************
*** 80,87 ****
BOOLVAL is_same (PMC* other) {
STRING* s1 = (STRING*)SELF->cache.struct_val;
STRING* s2 = (STRING*)other->cache.struct_val;
! return other->vtable == SELF->vtable
! && (strcmp(s1->bufstart,s2->bufstart)==0);
}
void set_integer (PMC* value) {
--- 80,87 ----
BOOLVAL is_same (PMC* other) {
STRING* s1 = (STRING*)SELF->cache.struct_val;
STRING* s2 = (STRING*)other->cache.struct_val;
! return (BOOLVAL)( other->vtable == SELF->vtable
! && (strcmp(s1->bufstart,s2->bufstart)==0) );
}
void set_integer (PMC* value) {
***************
*** 389,395 ****
STRING* s = string_copy(INTERP, (STRING*)SELF->cache.struct_val);
dest->cache.struct_val =
string_concat(INTERP,
! s,
value,
0
);
--- 389,395 ----
STRING* s = string_copy(INTERP, (STRING*)SELF->cache.struct_val);
dest->cache.struct_val =
string_concat(INTERP,
! s,
value,
0
);
***************
*** 400,406 ****
STRING* s = string_copy(INTERP, (STRING*)SELF->cache.struct_val);
dest->cache.struct_val =
string_concat(INTERP,
! SELF->cache.struct_val,
value,
0
);
--- 400,406 ----
STRING* s = string_copy(INTERP, (STRING*)SELF->cache.struct_val);
dest->cache.struct_val =
string_concat(INTERP,
! s,
value,
0
);
***************
*** 418,423 ****
--- 418,427 ----
/* == operation */
BOOLVAL is_equal (PMC* value) {
+ return (BOOLVAL)( 0 == string_compare(INTERP,
+ SELF->cache.struct_val,
+ value->vtable->get_string(INTERP,
+value)
+ ));
}
void logical_or (PMC* value, PMC* dest) = default;
Index: classes/perlundef.pmc
===================================================================
RCS file: /home/perlcvs/parrot/classes/perlundef.pmc,v
retrieving revision 1.4
diff -c -r1.4 perlundef.pmc
*** classes/perlundef.pmc 5 Jan 2002 12:35:27 -0000 1.4
--- classes/perlundef.pmc 14 Jan 2002 16:40:56 -0000
***************
*** 76,82 ****
}
BOOLVAL is_same (PMC* pmc2) {
! return pmc2->vtable == pmc->vtable;
}
void set_integer (PMC * value) {
--- 76,82 ----
}
BOOLVAL is_same (PMC* pmc2) {
! return (BOOLVAL)(pmc2->vtable == pmc->vtable);
}
void set_integer (PMC * value) {
***************
*** 242,259 ****
void divide (PMC * value, PMC* dest) {
if(value->vtable == &Parrot_base_vtables[enum_class_PerlUndef]) {
! fprintf(stderr, "division by zero!\n");
! exit(1);
}
else if(value->vtable == &Parrot_base_vtables[enum_class_PerlInt]) {
if(value->vtable->get_integer(INTERP, value) == 0) {
! fprintf(stderr, "division by zero!\n");
! exit(1);
}
}
else if(value->vtable->get_number(INTERP, value) == 0) {
! fprintf(stderr, "division by zero!\n");
! exit(1);
}
dest->vtable->set_integer_native(INTERP, dest, 0);
--- 242,256 ----
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);
***************
*** 261,268 ****
void divide_int (INTVAL value, PMC* dest) {
if(value == 0) {
! fprintf(stderr, "division by zero!\n");
! exit(1);
}
dest->vtable->set_integer_native(INTERP, dest, 0);
}
--- 258,264 ----
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);
}
***************
*** 274,281 ****
void divide_float (FLOATVAL value, PMC* dest) {
if(value == 0) {
! fprintf(stderr, "division by zero!\n");
! exit(1);
}
dest->vtable->set_integer_native(INTERP, dest, 0);
}
--- 270,276 ----
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);
}
***************
*** 286,293 ****
}
void divide_same (PMC * value, PMC* dest) {
! fprintf(stderr, "division by zero!\n");
! exit(1);
}
void modulus (PMC * value, PMC* dest) {
--- 281,287 ----
}
void divide_same (PMC * value, PMC* dest) {
! internal_exception(DIV_BY_ZERO, "division by zero!\n");
}
void modulus (PMC * value, PMC* dest) {
Index: encodings/singlebyte.c
===================================================================
RCS file: /home/perlcvs/parrot/encodings/singlebyte.c,v
retrieving revision 1.11
diff -c -r1.11 singlebyte.c
*** encodings/singlebyte.c 12 Jan 2002 15:33:35 -0000 1.11
--- encodings/singlebyte.c 14 Jan 2002 16:40:56 -0000
***************
*** 31,41 ****
byte_t *bptr = (byte_t*)ptr;
if (c > 255) {
! INTERNAL_EXCEPTION(INVALID_CHARACTER,
"Invalid character for single byte encoding\n");
}
! *bptr = c;
return bptr + 1;
}
--- 31,41 ----
byte_t *bptr = (byte_t*)ptr;
if (c > 255) {
! internal_exception(INVALID_CHARACTER,
"Invalid character for single byte encoding\n");
}
! *bptr = (byte_t)c;
return bptr + 1;
}
Index: encodings/utf16.c
===================================================================
RCS file: /home/perlcvs/parrot/encodings/utf16.c,v
retrieving revision 1.8
diff -c -r1.8 utf16.c
*** encodings/utf16.c 1 Jan 2002 20:23:46 -0000 1.8
--- encodings/utf16.c 14 Jan 2002 16:40:56 -0000
***************
*** 29,35 ****
}
if (u16ptr > u16end) {
! INTERNAL_EXCEPTION(MALFORMED_UTF16, "Unaligned end in UTF-16 string\n");
}
return characters;
--- 29,35 ----
}
if (u16ptr > u16end) {
! internal_exception(MALFORMED_UTF16, "Unaligned end in UTF-16 string\n");
}
return characters;
***************
*** 44,56 ****
utf16_t low = *u16ptr++;
if (!UNICODE_IS_LOW_SURROGATE(low)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF16, "Malformed UTF-16 surrogate\n");
}
c = UNICODE_DECODE_SURROGATE(c, low);
}
else if (UNICODE_IS_LOW_SURROGATE(c)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF16, "Malformed UTF-16 surrogate\n");
}
return c;
--- 44,56 ----
utf16_t low = *u16ptr++;
if (!UNICODE_IS_LOW_SURROGATE(low)) {
! internal_exception(MALFORMED_UTF16, "Malformed UTF-16 surrogate\n");
}
c = UNICODE_DECODE_SURROGATE(c, low);
}
else if (UNICODE_IS_LOW_SURROGATE(c)) {
! internal_exception(MALFORMED_UTF16, "Malformed UTF-16 surrogate\n");
}
return c;
***************
*** 61,76 ****
utf16_t *u16ptr = (utf16_t*)ptr;
if (c > 0x10FFFF || UNICODE_IS_SURROGATE(c)) {
! INTERNAL_EXCEPTION(INVALID_CHARACTER,
"Invalid character for UTF-16 encoding\n");
}
if (c < 0x10000u) {
! *u16ptr++ = c;
}
else {
! *u16ptr++ = UNICODE_HIGH_SURROGATE(c);
! *u16ptr++ = UNICODE_LOW_SURROGATE(c);
}
return u16ptr;
--- 61,76 ----
utf16_t *u16ptr = (utf16_t*)ptr;
if (c > 0x10FFFF || UNICODE_IS_SURROGATE(c)) {
! internal_exception(INVALID_CHARACTER,
"Invalid character for UTF-16 encoding\n");
}
if (c < 0x10000u) {
! *u16ptr++ = (utf16_t)c;
}
else {
! *u16ptr++ = (utf16_t)UNICODE_HIGH_SURROGATE(c);
! *u16ptr++ = (utf16_t)UNICODE_LOW_SURROGATE(c);
}
return u16ptr;
***************
*** 85,96 ****
u16ptr++;
if (!UNICODE_IS_LOW_SURROGATE(*u16ptr)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF16,
"Malformed UTF-16 surrogate\n");
}
}
else if (UNICODE_IS_LOW_SURROGATE(*u16ptr)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF16, "Malformed UTF-16 surrogate\n");
}
u16ptr++;
--- 85,96 ----
u16ptr++;
if (!UNICODE_IS_LOW_SURROGATE(*u16ptr)) {
! internal_exception(MALFORMED_UTF16,
"Malformed UTF-16 surrogate\n");
}
}
else if (UNICODE_IS_LOW_SURROGATE(*u16ptr)) {
! internal_exception(MALFORMED_UTF16, "Malformed UTF-16 surrogate\n");
}
u16ptr++;
***************
*** 110,121 ****
u16ptr--;
if (!UNICODE_IS_HIGH_SURROGATE(*u16ptr)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF16,
"Malformed UTF-16 surrogate\n");
}
}
else if (UNICODE_IS_HIGH_SURROGATE(*u16ptr)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF16, "Malformed UTF-16 surrogate\n");
}
}
--- 110,121 ----
u16ptr--;
if (!UNICODE_IS_HIGH_SURROGATE(*u16ptr)) {
! internal_exception(MALFORMED_UTF16,
"Malformed UTF-16 surrogate\n");
}
}
else if (UNICODE_IS_HIGH_SURROGATE(*u16ptr)) {
! internal_exception(MALFORMED_UTF16, "Malformed UTF-16 surrogate\n");
}
}
Index: encodings/utf32.c
===================================================================
RCS file: /home/perlcvs/parrot/encodings/utf32.c,v
retrieving revision 1.6
diff -c -r1.6 utf32.c
*** encodings/utf32.c 12 Jan 2002 15:33:35 -0000 1.6
--- encodings/utf32.c 14 Jan 2002 16:40:56 -0000
***************
*** 36,42 ****
utf32_t *u32ptr = (utf32_t*)ptr;
if (c > 0x10FFFF || UNICODE_IS_SURROGATE(c)) {
! INTERNAL_EXCEPTION(INVALID_CHARACTER,
"Invalid character for UTF-32 encoding\n");
}
--- 36,42 ----
utf32_t *u32ptr = (utf32_t*)ptr;
if (c > 0x10FFFF || UNICODE_IS_SURROGATE(c)) {
! internal_exception(INVALID_CHARACTER,
"Invalid character for UTF-32 encoding\n");
}
Index: encodings/utf8.c
===================================================================
RCS file: /home/perlcvs/parrot/encodings/utf8.c,v
retrieving revision 1.9
diff -c -r1.9 utf8.c
*** encodings/utf8.c 1 Jan 2002 20:23:46 -0000 1.9
--- encodings/utf8.c 14 Jan 2002 16:40:56 -0000
***************
*** 40,46 ****
}
if (u8ptr > u8end) {
! INTERNAL_EXCEPTION(MALFORMED_UTF8, "Unaligned end in UTF-8 string\n");
}
return characters;
--- 40,46 ----
}
if (u8ptr > u8end) {
! internal_exception(MALFORMED_UTF8, "Unaligned end in UTF-8 string\n");
}
return characters;
***************
*** 59,76 ****
for (count = 1; count < len; count++) {
u8ptr++;
if (!UTF8_IS_CONTINUATION(*u8ptr)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF8,
"Malformed UTF-8 string\n");
}
c = UTF8_ACCUMULATE(c, *u8ptr);
}
if (UNICODE_IS_SURROGATE(c)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF8, "Surrogate in UTF-8 string\n");
}
}
else if (!UNICODE_IS_INVARIANT(c)) {
! INTERNAL_EXCEPTION(MALFORMED_UTF8, "Malformed UTF-8 string\n");
}
return c;
--- 59,76 ----
for (count = 1; count < len; count++) {
u8ptr++;
if (!UTF8_IS_CONTINUATION(*u8ptr)) {
! internal_exception(MALFORMED_UTF8,
"Malformed UTF-8 string\n");
}
c = UTF8_ACCUMULATE(c, *u8ptr);
}
if (UNICODE_IS_SURROGATE(c)) {
! internal_exception(MALFORMED_UTF8, "Surrogate in UTF-8 string\n");
}
}
else if (!UNICODE_IS_INVARIANT(c)) {
! internal_exception(MALFORMED_UTF8, "Malformed UTF-8 string\n");
}
return c;
***************
*** 83,97 ****
utf8_t *u8end = u8ptr + len - 1;
if (c > 0x10FFFF || UNICODE_IS_SURROGATE(c)) {
! INTERNAL_EXCEPTION(INVALID_CHARACTER,
"Invalid character for UTF-8 encoding\n");
}
while (u8end > u8ptr) {
! *u8end-- = (c & UTF8_CONTINUATION_MASK) | UTF8_CONTINUATION_MARK;
c >>= UTF8_ACCUMULATION_SHIFT;
}
! *u8end = (c & UTF8_START_MASK(len)) | UTF8_START_MARK(len);
return u8ptr + len;
}
--- 83,97 ----
utf8_t *u8end = u8ptr + len - 1;
if (c > 0x10FFFF || UNICODE_IS_SURROGATE(c)) {
! internal_exception(INVALID_CHARACTER,
"Invalid character for UTF-8 encoding\n");
}
while (u8end > u8ptr) {
! *u8end-- = (utf8_t)( (c & UTF8_CONTINUATION_MASK) | UTF8_CONTINUATION_MARK );
c >>= UTF8_ACCUMULATION_SHIFT;
}
! *u8end = (utf8_t)( (c & UTF8_START_MASK(len)) | UTF8_START_MARK(len) );
return u8ptr + len;
}
Index: include/parrot/exceptions.h
===================================================================
RCS file: /home/perlcvs/parrot/include/parrot/exceptions.h,v
retrieving revision 1.7
diff -c -r1.7 exceptions.h
*** include/parrot/exceptions.h 1 Jan 2002 17:22:55 -0000 1.7
--- include/parrot/exceptions.h 14 Jan 2002 16:40:56 -0000
***************
*** 13,20 ****
#if !defined(PARROT_EXCEPTIONS_H_GUARD)
#define PARROT_EXCEPTIONS_H_GUARD
- #define INTERNAL_EXCEPTION(x,y) {fprintf(stderr, y); exit(x);}
#define NO_REG_FRAMES 1
#define SUBSTR_OUT_OF_STRING 1
#define ORD_OUT_OF_STRING 1
--- 13,23 ----
#if !defined(PARROT_EXCEPTIONS_H_GUARD)
#define PARROT_EXCEPTIONS_H_GUARD
+ /* Prototypes */
+ void internal_exception(int exitcode, const char * format, ... );
+
+ /* Exception Types */
#define NO_REG_FRAMES 1
#define SUBSTR_OUT_OF_STRING 1
#define ORD_OUT_OF_STRING 1
***************
*** 27,32 ****
--- 30,44 ----
#define NEG_SLEEP 1
#define NEG_CHOP 1
#define ARG_OP_NOT_HANDLED 1
+ #define KEY_NOT_FOUND 1
+ #define JIT_UNAVAILABLE 1
+ #define INTERP_ERROR 1
+ #define PREDEREF_LOAD_ERROR 1
+ #define PARROT_USAGE_ERROR 1
+ #define IO_ERROR 1
+ #define PARROT_POINTER_ERROR 1
+ #define DIV_BY_ZERO 1
+ #define IO_NOT_IMPLEMENTED 1
#endif
Index: include/parrot/io.h
===================================================================
RCS file: /home/perlcvs/parrot/include/parrot/io.h,v
retrieving revision 1.5
diff -c -r1.5 io.h
*** include/parrot/io.h 12 Jan 2002 15:14:29 -0000 1.5
--- include/parrot/io.h 14 Jan 2002 16:40:56 -0000
***************
*** 97,103 ****
typedef int PIOHANDLE;
#endif
!
struct _ParrotIO {
PIOHANDLE fd; /* Low level OS descriptor */
UINTVAL mode; /* Read/Write/etc. */
--- 97,103 ----
typedef int PIOHANDLE;
#endif
!
struct _ParrotIO {
PIOHANDLE fd; /* Low level OS descriptor */
UINTVAL mode; /* Read/Write/etc. */
Index: include/parrot/parrot.h
===================================================================
RCS file: /home/perlcvs/parrot/include/parrot/parrot.h,v
retrieving revision 1.17
diff -c -r1.17 parrot.h
*** include/parrot/parrot.h 12 Jan 2002 15:34:01 -0000 1.17
--- include/parrot/parrot.h 14 Jan 2002 16:40:56 -0000
***************
*** 71,77 ****
/* define a macro to acknowledge an unused argument, and silence a "helpful"
compiler warning. gcc will emit a warning on an empty if body unless {} is
used to make an empty block. */
! #define UNUSED(a) if (0 || a) {}
#include "parrot/global_setup.h"
#include "parrot/interpreter.h"
--- 71,77 ----
/* define a macro to acknowledge an unused argument, and silence a "helpful"
compiler warning. gcc will emit a warning on an empty if body unless {} is
used to make an empty block. */
! #define UNUSED(a) if (a) {}
#include "parrot/global_setup.h"
#include "parrot/interpreter.h"
Index: include/parrot/rx.h
===================================================================
RCS file: /home/perlcvs/parrot/include/parrot/rx.h,v
retrieving revision 1.3
diff -c -r1.3 rx.h
*** include/parrot/rx.h 11 Jan 2002 04:19:43 -0000 1.3
--- include/parrot/rx.h 14 Jan 2002 16:40:56 -0000
***************
*** 34,45 ****
typedef struct rxinfo {
STRING *string;
! INTVAL index;
! INTVAL startindex;
BOOLVAL success;
rxflags flags;
! INTVAL minlength;
rxdirection whichway;
PMC *groupstart;
--- 34,45 ----
typedef struct rxinfo {
STRING *string;
! UINTVAL index;
! UINTVAL startindex;
BOOLVAL success;
rxflags flags;
! UINTVAL minlength;
rxdirection whichway;
PMC *groupstart;
Index: io/io_stdio.c
===================================================================
RCS file: /home/perlcvs/parrot/io/io_stdio.c,v
retrieving revision 1.5
diff -c -r1.5 io_stdio.c
*** io/io_stdio.c 12 Jan 2002 15:34:27 -0000 1.5
--- io/io_stdio.c 14 Jan 2002 16:40:57 -0000
***************
*** 84,93 ****
*/
INTVAL PIO_stdio_setbuf(theINTERP, ParrotIOLayer * layer, ParrotIO * io,
size_t bufsize) {
- size_t size;
ParrotIOLayer * l = layer;
ParrotIOBuf * b = &io->b;
- UNUSED (size);
/* If there is a buffer, make sure we flush before
* dinking around with the buffer.
*/
--- 84,91 ----
***************
*** 142,148 ****
while(l) {
if(l->api->FDOpen) {
io = (*l->api->FDOpen)(interpreter, l, fd, flags);
! if(isatty(fd))
PIO_stdio_setlinebuf(interpreter, l, io);
else
PIO_stdio_setbuf(interpreter, l, io,
--- 140,146 ----
while(l) {
if(l->api->FDOpen) {
io = (*l->api->FDOpen)(interpreter, l, fd, flags);
! if(PIO_isatty(fd))
PIO_stdio_setlinebuf(interpreter, l, io);
else
PIO_stdio_setbuf(interpreter, l, io,
***************
*** 278,285 ****
NULL,
NULL,
NULL,
! PIO_setbuf,
! PIO_setlinebuf,
NULL,
NULL,
PIO_stdio_puts,
--- 276,283 ----
NULL,
NULL,
NULL,
! PIO_stdio_setbuf,
! PIO_stdio_setlinebuf,
NULL,
NULL,
PIO_stdio_puts,
Index: io/io_win32.c
===================================================================
RCS file: /home/perlcvs/parrot/io/io_win32.c,v
retrieving revision 1.3
diff -c -r1.3 io_win32.c
*** io/io_win32.c 13 Jan 2002 19:36:45 -0000 1.3
--- io/io_win32.c 14 Jan 2002 16:40:57 -0000
***************
*** 38,44 ****
ParrotIO * PIO_win32_open(theINTERP, ParrotIOLayer * layer,
const char * spath, UINTVAL flags);
ParrotIO * PIO_win32_fdopen(theINTERP, ParrotIOLayer * layer,
! PIOHANDLE fd, const char * smode);
INTVAL PIO_win32_close(theINTERP, ParrotIOLayer * layer,
ParrotIO * io);
void PIO_win32_flush(theINTERP, ParrotIOLayer * layer,
--- 38,44 ----
ParrotIO * PIO_win32_open(theINTERP, ParrotIOLayer * layer,
const char * spath, UINTVAL flags);
ParrotIO * PIO_win32_fdopen(theINTERP, ParrotIOLayer * layer,
! PIOHANDLE fd, UINTVAL flags);
INTVAL PIO_win32_close(theINTERP, ParrotIOLayer * layer,
ParrotIO * io);
void PIO_win32_flush(theINTERP, ParrotIOLayer * layer,
***************
*** 89,115 ****
INTVAL PIO_win32_init(theINTERP, ParrotIOLayer * layer) {
HANDLE h;
if((h = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE) {
! pio_stdin = PIO_win32_fdopen(interpreter, layer, h, "<");
}
if((h = GetStdHandle(STD_OUTPUT_HANDLE))
!= INVALID_HANDLE_VALUE){
! pio_stdout = PIO_win32_fdopen(interpreter, layer, h, ">");
}
if((h = GetStdHandle(STD_ERROR_HANDLE)) != INVALID_HANDLE_VALUE) {
! pio_stderr = PIO_win32_fdopen(interpreter, layer, h, ">");
}
!
if(pio_stdin && pio_stdout && pio_stderr)
! return 0;
return -1;
}
ParrotIO * PIO_win32_open(theINTERP, ParrotIOLayer * layer,
const char * spath, UINTVAL flags) {
- ParrotIO * io;
int type;
- PIOHANDLE fd;
DWORD fAcc, fShare, fCreat;
type = PIO_TYPE_FILE;
#if 0
--- 89,113 ----
INTVAL PIO_win32_init(theINTERP, ParrotIOLayer * layer) {
HANDLE h;
if((h = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE) {
! pio_stdin = PIO_fdopen(interpreter, h, "<");
}
if((h = GetStdHandle(STD_OUTPUT_HANDLE))
!= INVALID_HANDLE_VALUE){
! pio_stdout = PIO_fdopen(interpreter, h, ">");
}
if((h = GetStdHandle(STD_ERROR_HANDLE)) != INVALID_HANDLE_VALUE) {
! pio_stderr = PIO_fdopen(interpreter, h, ">");
}
!
if(pio_stdin && pio_stdout && pio_stderr)
! return 0;
return -1;
}
ParrotIO * PIO_win32_open(theINTERP, ParrotIOLayer * layer,
const char * spath, UINTVAL flags) {
int type;
DWORD fAcc, fShare, fCreat;
type = PIO_TYPE_FILE;
#if 0
***************
*** 123,129 ****
/* Set open flags - <, >, >>, +<, +> */
/* add ? and ! for block/non-block */
! if( flags_to_win32(flags, &fAcc, fShare, fCreat) < 0 )
return (ParrotIO *)NULL;
/* Only files for now */
--- 121,127 ----
/* Set open flags - <, >, >>, +<, +> */
/* add ? and ! for block/non-block */
! if( flags_to_win32(flags, &fAcc, &fShare, &fCreat) < 0 )
return (ParrotIO *)NULL;
/* Only files for now */
***************
*** 137,146 ****
ParrotIO * PIO_win32_fdopen(theINTERP, ParrotIOLayer * layer,
! PIOHANDLE fd, const char * smode) {
ParrotIO * io;
! INTVAL flags, mode;
! flags = 0;
mode = 0;
/* FIXME - Check file handle specifics, validity */
--- 135,143 ----
ParrotIO * PIO_win32_fdopen(theINTERP, ParrotIOLayer * layer,
! PIOHANDLE fd, UINTVAL flags) {
ParrotIO * io;
! UINTVAL mode;
mode = 0;
/* FIXME - Check file handle specifics, validity */
***************
*** 206,212 ****
&wrote, NULL))
return -1;
return wrote;
-
}
return -1;
}
--- 203,208 ----
***************
*** 217,231 ****
*/
INTVAL PIO_win32_seek(theINTERP, ParrotIOLayer * l, ParrotIO * io,
off_t offset, INTVAL whence) {
! io->fpos = lseek(io->fd, offset, whence);
return io->fpos;
}
off_t PIO_win32_tell(theINTERP, ParrotIOLayer * l, ParrotIO * io) {
! off_t p;
p = lseek(io->fd, (off_t)0, SEEK_CUR);
return p;
}
--- 213,233 ----
*/
INTVAL PIO_win32_seek(theINTERP, ParrotIOLayer * l, ParrotIO * io,
off_t offset, INTVAL whence) {
! /* io->fpos = lseek(io->fd, offset, whence);
return io->fpos;
+ */
+ internal_exception( IO_NOT_IMPLEMENTED, "Seek not yet implemented on
+HANDLEs");
+ return 0;
}
off_t PIO_win32_tell(theINTERP, ParrotIOLayer * l, ParrotIO * io) {
! /* off_t p;
p = lseek(io->fd, (off_t)0, SEEK_CUR);
return p;
+ */
+ internal_exception( IO_NOT_IMPLEMENTED, "Seek not yet implemented on
+HANDLEs");
+ return 0;
}
Index: platforms/win32.c
===================================================================
RCS file: /home/perlcvs/parrot/platforms/win32.c,v
retrieving revision 1.4
diff -c -r1.4 win32.c
*** platforms/win32.c 27 Dec 2001 17:08:48 -0000 1.4
--- platforms/win32.c 14 Jan 2002 16:40:57 -0000
***************
*** 3,8 ****
--- 3,9 ----
**
*/
+ #include <time.h>
#include "parrot/parrot.h"
***************
*** 81,87 ****
void * Parrot_dlsym(void * handle, char * symbol)
{
! return GetProcAddress(handle, symbol);
}
--- 82,88 ----
void * Parrot_dlsym(void * handle, char * symbol)
{
! return (void *)(ptrcast_t)GetProcAddress(handle, symbol);
}
Index: platforms/win32.h
===================================================================
RCS file: /home/perlcvs/parrot/platforms/win32.h,v
retrieving revision 1.4
diff -c -r1.4 win32.h
*** platforms/win32.h 27 Dec 2001 17:08:48 -0000 1.4
--- platforms/win32.h 14 Jan 2002 16:40:57 -0000
***************
*** 9,14 ****
--- 9,17 ----
#define DEFAULT_OPEN_MODE 0
+ /* These disable certain Level 4 Warnings */
+ #pragma warning( disable: 4100 ) /* disables 'unreferenced formal parameter'
+warnings */
+ #pragma warning( disable: 4115 ) /* disables 'named type definition in parentheses'
+warnings triggered in VC98 include files */
/*
** Miscellaneous:
Index: t/op/pmc.t
===================================================================
RCS file: /home/perlcvs/parrot/t/op/pmc.t,v
retrieving revision 1.21
diff -c -r1.21 pmc.t
*** t/op/pmc.t 13 Jan 2002 17:46:51 -0000 1.21
--- t/op/pmc.t 14 Jan 2002 16:40:57 -0000
***************
*** 1254,1285 ****
0
OUTPUT
! output_is(<<CODE, <<OUTPUT, "Initial PerlHash tests");
! new P0, PerlHash
! set P0, -7,"foo"
! set P0, 3.5,"bar"
! set P0, "value","baz"
! set I0, P0, "foo"
! set N0, P0, "bar"
! set S0, P0, "baz"
! eq I0,-7,OK_1
! print "not "
! OK_1: print "ok 1\\n"
! eq N0,3.500000,OK_2
! print N0
! OK_2: print "ok 2\\n"
! eq S0,"value",OK_3
! print S0
! OK_3: print "ok 3\\n"
end
CODE
ok 1
ok 2
ok 3
OUTPUT
output_is(<<CODE, <<OUTPUT, "IntQueue test");
--- 1254,1290 ----
0
OUTPUT
! output_is(<<CODE, <<OUTPUT, "IntQueue test");
! new P0,IntQueue
! set P0,32
! set P0,-7
! set I0,P0
! eq I0,32,OK_1
! print "not "
! OK_1: print "ok 1\\n"
! if P0,OK_2
! print "not "
! OK_2: print "ok 2\\n"
! set I0,P0
! eq I0,-7,OK_3
! print "not "
! OK_3: print "ok 3\\n"
!
! if P0,NOT_OK_4
! print "ok 4\\n"
! branch DONE
! NOT_OK_4: print "not ok 4\\n"
! DONE:
end
CODE
ok 1
ok 2
ok 3
+ ok 4
OUTPUT
output_is(<<CODE, <<OUTPUT, "IntQueue test");
Index: t/op/pmc_perlhash.t
===================================================================
RCS file: /home/perlcvs/parrot/t/op/pmc_perlhash.t,v
retrieving revision 1.5
diff -c -r1.5 pmc_perlhash.t
*** t/op/pmc_perlhash.t 10 Jan 2002 22:46:03 -0000 1.5
--- t/op/pmc_perlhash.t 14 Jan 2002 16:40:57 -0000
***************
*** 1,6 ****
#! perl
! use Parrot::Test tests => 7;
output_is(<<'CODE', <<OUTPUT, "simple set / get");
new P0, PerlHash
--- 1,6 ----
#! perl
! use Parrot::Test tests => 8;
output_is(<<'CODE', <<OUTPUT, "simple set / get");
new P0, PerlHash
***************
*** 149,154 ****
--- 149,182 ----
end
CODE
1
+ OUTPUT
+
+ output_is(<<CODE, <<OUTPUT, "Initial PerlHash tests");
+ new P0, PerlHash
+
+ set P0, -7,"foo"
+ set P0, 3.5,"bar"
+ set P0, "value","baz"
+
+ set I0, P0, "foo"
+ set N0, P0, "bar"
+ set S0, P0, "baz"
+
+ eq I0,-7,OK_1
+ print "not "
+ OK_1: print "ok 1\\n"
+ eq N0,3.500000,OK_2
+ print N0
+ OK_2: print "ok 2\\n"
+ eq S0,"value",OK_3
+ print S0
+ OK_3: print "ok 3\\n"
+
+ end
+ CODE
+ ok 1
+ ok 2
+ ok 3
OUTPUT
/* exceptions.h
* Copyright: (When this is determined...it will go here)
* CVS Info
* $Id: exceptions.c,v 1.0 2002/01/01 17:22:55 dan Exp $
* Overview:
* define the internal interpreter exceptions
* Data Structure and Algorithms:
* History:
* Notes:
* References:
*/
#include "parrot/parrot.h"
#ifdef HAS_HEADER_STDARG
#include <stdarg.h>
/* Exception Handler */
void internal_exception(int exitcode, const char * format, ... ) {
va_list arglist;
va_start(arglist, format);
vfprintf(stderr,format,arglist);
va_end(arglist);
exit(exitcode);
}
#else
void internal_exception(int exitcode, const char * format, ... ) {
fprintf(stderr, format);
exit(exitcode);
}
#endif
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
* indent-tabs-mode: nil
* End:
*
* vim: expandtab shiftwidth=4:
*/
