Hello,
This weekend I played a little bit with Parrot, and in order to learn
more about vtables I just implemented Scheme Pairs
Here are the changes:
* MANIFEST, Makefile.in, global_setup.c, classes/Makefile.in
include/parrot/pmc.h:
Added SchemePair as described in vtable.pod
* core.ops:
* added new operation set_p_p for copying the pmc-pointer
* added new operations set_p_i_p and set_p_p_i for indirect
setting and getting of pmc values
* added new operation get_type_s_p and get_type_i_p
to get the type-information at runtime and not only at
compiletime
* vtable.tbl:
Added new methods for indirect setting and getting of
pmc-values
* classes/default.pmc
default (non-)implementations of the above methods
* classes/schemepair.pmc:
New File. Implementation of the new indirect PMC get and set
methods. Implementation of a stringfication method.
* classes/perlint.pmc, classes/perlnum.pmc,
classes/perlstring.pmc, classes/perlundef.pmc:
type () returns the korrekt type and not 0
* languages/scheme/Scheme/Generator.pm
Implementation of the following methods:
cons, car, cdr, set-car!, set-cdr!, pair?, null?, list,
length
* languages/scheme/Scheme/Tokenizer.pm
Exclamation marks are valid identifiers
* languages/scheme/t/harness
use directory lists
* languages/scheme/t/lists/basic.t
Some basic list tests
Have fun,
Jürgen
Index: classes/schemepair.pmc
===================================================================
diff -u /dev/null classes/schemepair.pmc
--- /dev/null Fri Nov 12 22:31:31 1999
+++ classes/schemepair.pmc Sun Jan 6 17:41:15 2002
@@ -0,0 +1,473 @@
+/* SchemePair.pmc -*- C -*-
+ * Copyright: (When this is determined...it will go here)
+ * CVS Info
+ * $Id: not yet $
+ * Overview:
+ * These are the vtable functions for the SchemePair base class
+ * Data Structure and Algorithms:
+ * History:
+ * Notes:
+ * References:
+ */
+
+#include "parrot/parrot.h"
+
+static STRING*
+_stringify_key_pair (struct Parrot_Interp* INTERP, KEY_PAIR* key_pair) {
+ STRING* s;
+
+ s = string_make (INTERP, NULL, 80, NULL, 0, NULL);
+
+ switch (key_pair->type) {
+ case enum_key_int:
+ s->bufused = sprintf (s->bufstart, "%ld", key_pair->cache.int_val);
+ string_compute_strlen(s);
+ break;
+ case enum_key_num:
+ s->bufused = sprintf (s->bufstart, "%g", key_pair->cache.struct_val);
+ string_compute_strlen(s);
+ break;
+ case enum_key_string:
+ string_destroy (s);
+ s = key_pair->cache.struct_val;
+ break;
+ default:
+ fprintf (stderr, "*** unknown key_type(%d)\n", key_pair->type);
+ }
+
+ return s;
+}
+
+pmclass SchemePair {
+
+ INTVAL type () {
+ return enum_class_SchemePair;
+ }
+
+ STRING* name () {
+ return whoami;
+ }
+
+ void init () {
+ KEY *key;
+
+ key = key_new (INTERP);
+ key_set_size (INTERP, key, 2);
+ SELF->cache.struct_val = key;
+ }
+
+ void clone (PMC* dest) {
+ KEY *key;
+ KEY *old = SELF->cache.struct_val;
+
+ dest->vtable = SELF->vtable;
+ key = key_new (INTERP);
+ key_set_size (INTERP, key, 2);
+ memcpy (key->keys, old->keys, 2*sizeof(KEY_PAIR));
+ dest->cache.struct_val = key;
+ }
+
+ void morph (INTVAL type) {
+ }
+
+ BOOLVAL move_to (void * destination) {
+ return 0; /* You can't move me, I don't have anything to move! */
+ }
+
+ INTVAL real_size () {
+ return 0; /* ->data is unused */
+ }
+
+ void destroy () {
+ key_destroy(INTERP,SELF->cache.struct_val);
+ }
+
+ INTVAL get_integer () {
+ }
+
+ INTVAL get_integer_index (INTVAL index) {
+ }
+
+ FLOATVAL get_number () {
+ }
+
+ FLOATVAL get_number_index (INTVAL index) {
+ }
+
+ STRING* get_string () {
+ KEY *key = SELF->cache.struct_val;
+ KEY_PAIR *car, *cdr;
+
+ STRING *ret = string_make (INTERP, "(", 1, NULL, 0, NULL);
+
+ do {
+ car = key_element_value_i (INTERP, key, 0);
+ cdr = key_element_value_i (INTERP, key, 1);
+
+ if (car->type == enum_key_pmc) {
+ PMC *pmc = car->cache.pmc_val;
+ VTABLE *vtable = pmc->vtable;
+ INTVAL type = vtable->type (INTERP, pmc);
+
+ if (type == enum_class_PerlUndef) {
+ /* empty list */
+ ret = string_concat (INTERP, ret,
+ string_make (INTERP, "()", 2, NULL, 0, NULL),
+ 0);
+ }
+ else {
+ ret = string_concat (INTERP, ret,
+ vtable->get_string (INTERP, pmc),
+ 0);
+ }
+ }
+ else {
+ ret = string_concat (INTERP, ret,
+ _stringify_key_pair (INTERP, car),
+ 0);
+ }
+
+ if (cdr->type == enum_key_pmc) {
+ PMC *pmc = cdr->cache.pmc_val;
+ VTABLE *vtable = pmc->vtable;
+ INTVAL type = vtable->type (INTERP, pmc);
+
+ if (type == enum_class_PerlUndef) {
+ /* end of list */
+ break;
+ }
+ else if (type == enum_class_SchemePair) {
+ /* next element of list */
+ ret = string_concat (INTERP, ret,
+ string_make (INTERP, " ", 1, NULL, 0, NULL),
+ 0);
+ key = pmc->cache.struct_val;
+ }
+ else {
+ /* improper lists */
+ ret = string_concat (INTERP, ret,
+ string_make (INTERP, " . ", 3, NULL, 0, NULL),
+ 0);
+ ret = string_concat (INTERP, ret,
+ vtable->get_string (INTERP, pmc),
+ 0);
+ break;
+ }
+ }
+ else {
+ ret = string_concat (INTERP, ret,
+ string_make (INTERP, " . ", 3, NULL, 0, NULL),
+ 0);
+ ret = string_concat (INTERP, ret,
+ _stringify_key_pair (INTERP, cdr),
+ 0);
+ break;
+ }
+ } while (1);
+
+ ret = string_concat (INTERP, ret,
+ string_make (INTERP, ")", 1, NULL, 0, NULL),
+ 0);
+
+ return ret;
+ }
+
+ STRING* get_string_index (INTVAL index) {
+ }
+
+ BOOLVAL get_bool () {
+ }
+
+ void* get_value () {
+ }
+
+ BOOLVAL is_same (PMC* pmc2) {
+ }
+
+ void set_integer (PMC * value) {
+ }
+
+ void set_integer_native (INTVAL value) {
+ }
+
+ void set_integer_bigint (BIGINT value) {
+ }
+
+ void set_integer_same (PMC * value) {
+ }
+
+ void set_integer_index (INTVAL value, INTVAL index) {
+ if (index >= 0 && index < 2) {
+ KEY *key = SELF->cache.struct_val;
+ KEY_PAIR key_pair;
+
+ key_pair.type = enum_key_int;
+ key_pair.cache.int_val = value;
+ key_set_element_value_i (INTERP, key, index, &key_pair);
+ }
+ else {
+ fprintf (stderr, "*** set_integer_index index(%d) out of range\n",
+ index);
+ }
+ }
+
+
+ void set_number (PMC * value) {
+ }
+
+ void set_number_native (FLOATVAL value) {
+ }
+
+ void set_number_bigfloat (BIGFLOAT value) {
+ }
+
+ void set_number_same (PMC * value) {
+ }
+
+ void set_number_index (FLOATVAL value, INTVAL index) {
+ if (index >= 0 && index < 2) {
+ KEY *key = SELF->cache.struct_val;
+ KEY_PAIR key_pair;
+
+ key_pair.type = enum_key_num;
+ key_pair.cache.num_val = value;
+ key_set_element_value_i (INTERP, key, index, &key_pair);
+ }
+ else {
+ fprintf (stderr, "*** set_pmc_index index(%d) out of range\n",
+ index);
+ }
+ }
+
+ void set_string (PMC * value) {
+ }
+
+ void set_string_native (STRING * value) {
+ }
+
+ void set_string_unicode (STRING * value) {
+ }
+
+ void set_string_other (STRING * value) {
+ }
+
+ void set_string_same (PMC * value) {
+ }
+
+ void set_string_index (STRING* value, INTVAL index) {
+ }
+
+ void set_value (void* value) {
+ }
+
+ void add (PMC * value, PMC* dest) {
+ }
+
+ void add_int (INTVAL value, PMC* dest) {
+ }
+
+ void add_bigint (BIGINT value, PMC* dest) {
+ }
+
+ void add_float (FLOATVAL value, PMC* dest) {
+ }
+
+ void add_bigfloat (BIGFLOAT value, PMC* dest) {
+ }
+
+ void add_same (PMC * value, PMC* dest) {
+ }
+
+ void subtract (PMC * value, PMC* dest) {
+ }
+
+ void subtract_int (INTVAL value, PMC* dest) {
+ }
+
+ void subtract_bigint (BIGINT value, PMC* dest) {
+ }
+
+ void subtract_float (FLOATVAL value, PMC* dest) {
+ }
+
+ void subtract_bigfloat (BIGFLOAT value, PMC* dest) {
+ }
+
+ void subtract_same (PMC * value, PMC* dest) {
+ }
+
+ void multiply (PMC * value, PMC* dest) {
+ }
+
+ void multiply_int (INTVAL value, PMC* dest) {
+ }
+
+ void multiply_bigint (BIGINT value, PMC* dest) {
+ }
+
+ void multiply_float (FLOATVAL value, PMC* dest) {
+ }
+
+ void multiply_bigfloat (BIGFLOAT value, PMC* dest) {
+ }
+
+ void multiply_same (PMC * value, PMC* dest) {
+ }
+
+ void divide (PMC * value, PMC* dest) {
+ }
+
+ void divide_int (INTVAL value, PMC* dest) {
+ }
+
+ void divide_bigint (BIGINT value, PMC* dest) {
+ }
+
+ void divide_float (FLOATVAL value, PMC* dest) {
+ }
+
+ void divide_bigfloat (BIGFLOAT value, PMC* dest) {
+ }
+
+ void divide_same (PMC * value, PMC* dest) {
+ }
+
+ void modulus (PMC * value, PMC* dest) {
+ }
+
+ void modulus_int (INTVAL value, PMC* dest) {
+ }
+
+ void modulus_bigint (BIGINT value, PMC* dest) {
+ }
+
+ void modulus_float (FLOATVAL value, PMC* dest) {
+ }
+
+ void modulus_bigfloat (BIGFLOAT value, PMC* dest) {
+ }
+
+ void modulus_same (PMC * value, PMC* dest) {
+ }
+
+ void concatenate (PMC * value, PMC* dest) {
+ }
+
+ void concatenate_native (STRING * value, PMC* dest) {
+ }
+
+ void concatenate_unicode (STRING * value, PMC* dest) {
+ }
+
+ void concatenate_other (STRING * value, PMC* dest) {
+ }
+
+ void concatenate_same (PMC * value, PMC* dest) {
+ }
+
+ BOOLVAL is_equal (PMC* value) {
+ }
+
+ void logical_or (PMC* value, PMC* dest) {
+ }
+
+ void logical_and (PMC* value, PMC* dest) {
+ }
+
+ void logical_not (PMC* value) {
+ }
+
+ void match (PMC * value, REGEX* re) {
+ }
+
+ void match_native (STRING * value, REGEX* re) {
+ }
+
+ void match_unicode (STRING * value, REGEX* re) {
+ }
+
+ void match_other (STRING * value, REGEX* re) {
+ }
+
+ void match_same (PMC * value, REGEX* re) {
+ }
+
+ void repeat (PMC * value, PMC* dest) {
+ }
+
+ void repeat_native (STRING * value, PMC* dest) {
+ }
+
+ void repeat_unicode (STRING * value, PMC* dest) {
+ }
+
+ void repeat_other (STRING * value, PMC* dest) {
+ }
+
+ void repeat_same (PMC * value, PMC* dest) {
+ }
+
+ void set_pmc_index (PMC *value, INTVAL index) {
+ if (index >= 0 && index < 2) {
+ KEY *key = SELF->cache.struct_val;
+ KEY_PAIR key_pair;
+
+ key_pair.type = enum_key_pmc;
+ key_pair.cache.pmc_val = value;
+ key_set_element_value_i (INTERP, key, index, &key_pair);
+ }
+ else {
+ fprintf (stderr, "*** set_pmc_index index(%d) out of range\n",
+ index);
+ }
+ }
+
+ PMC* get_pmc_index (INTVAL index) {
+ if (index >= 0 && index < 2) {
+ KEY *key = SELF->cache.struct_val;
+ KEY_PAIR *key_pair = key_element_value_i (INTERP, key, index);
+
+ if (key_pair->type == enum_key_pmc) {
+ return key_pair->cache.pmc_val;
+ }
+ else {
+ PMC* new_pmc = NULL;
+ switch (key_pair->type) {
+ case enum_key_int:
+ new_pmc = pmc_new (INTERP, enum_class_PerlInt);
+ Parrot_PerlInt_set_integer_native (INTERP, new_pmc,
+ key_pair->cache.int_val);
+ break;
+ case enum_key_num:
+ new_pmc = pmc_new (INTERP, enum_class_PerlNum);
+ Parrot_PerlNum_set_number_native (INTERP, new_pmc,
+ key_pair->cache.num_val);
+ break;
+ case enum_key_string:
+ new_pmc = pmc_new (INTERP, enum_class_PerlString);
+ Parrot_PerlString_set_string_native (INTERP, new_pmc,
+ key_pair->cache.struct_val);
+ default:
+ fprintf (stderr, "*** get_pmc_index: unknown type (%d)\n",
+ key_pair->type);
+ }
+ return new_pmc;
+ }
+ }
+ else {
+ fprintf (stderr, "*** get_pmc_index index(%d) out of range\n",
+ index);
+ }
+ }
+ return NULL;
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: nil
+ * End:
+ *
+ * vim: expandtab shiftwidth=4:
+ */
Index: languages/scheme/t/lists/basic.t
===================================================================
diff -u /dev/null languages/scheme/t/lists/basic.t
--- /dev/null Fri Nov 12 22:31:31 1999
+++ languages/scheme/t/lists/basic.t Sun Jan 6 17:21:18 2002
@@ -0,0 +1,84 @@
+#! perl -w
+
+use Scheme::Test tests => 15;
+
+###
+### Add
+###
+
+output_is(<<'CODE', '(2 . 5)', 'cons');
+(write (cons 2 5))
+CODE
+
+output_is(<<'CODE', '((2 . 3) . 4)', 'cons car');
+(write (cons (cons 2 3) 4))
+CODE
+
+output_is(<<'CODE', '(2 3 . 4)', 'cons cdr');
+(write (cons 2 (cons 3 4)))
+CODE
+
+output_is(<<'CODE', '((1 . 2) 3 . 4)', 'complex cons');
+(write
+ (cons
+ (cons 1 2)
+ (cons 3 4)))
+CODE
+
+output_is(<<'CODE', '1', 'pair?');
+(write
+ (pair? (cons 1 3)))
+CODE
+
+output_is(<<'CODE', '0', 'false pair?');
+(write
+ (pair? 12))
+CODE
+
+output_is(<<'CODE', '(3 2 1 0)', 'list');
+(write
+ (list 3 2 1 0))
+CODE
+
+output_is(<<'CODE', '1', 'pair? list');
+(write
+ (pair? (list 3 2 1)))
+CODE
+
+output_is(<<'CODE', '(1 2 3)', 'lists the hard way');
+(write
+ (cons 1
+ (cons 2
+ (cons 3
+ (list)))))
+CODE
+
+output_is(<<'CODE', '4', 'length');
+(write
+ (length (list 3 2 1 0)))
+CODE
+
+output_is(<<'CODE', '2', 'car');
+(write
+ (car (list 2 1 0)))
+CODE
+
+output_is(<<'CODE', '(1 0)', 'cdr');
+(write
+ (cdr (list 2 1 0)))
+CODE
+
+output_is(<<'CODE', '(4 2 3)', 'set-car!');
+(write
+ (set-car! (list 1 2 3) 4))
+CODE
+
+output_is(<<'CODE', '((4 . 2) 2 3)', 'set-car! II');
+(write
+ (set-car! (list 1 2 3) (cons 4 2)))
+CODE
+
+output_is(<<'CODE', '(1 4 2)', 'set-cdr!');
+(write
+ (set-cdr! (list 1 2 3) (list 4 2)))
+CODE
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.84
diff -u -r1.84 MANIFEST
--- MANIFEST 4 Jan 2002 03:57:37 -0000 1.84
+++ MANIFEST 6 Jan 2002 19:17:54 -0000
@@ -43,6 +43,7 @@
classes/perlstring.pmc
classes/perlundef.pmc
classes/pmc2c.pl
+classes/schemepair.pmc
config_h.in
core.ops
disassemble.pl
@@ -161,6 +162,7 @@
languages/scheme/t/arith/nested.t
languages/scheme/t/harness
languages/scheme/t/io/basic.t
+languages/scheme/t/lists/basic.t
languages/scheme/t/logic/basic.t
make.pl
make_vtable_ops.pl
Index: Makefile.in
===================================================================
RCS file: /cvs/public/parrot/Makefile.in,v
retrieving revision 1.101
diff -u -r1.101 Makefile.in
--- Makefile.in 4 Jan 2002 16:44:44 -0000 1.101
+++ Makefile.in 6 Jan 2002 19:17:54 -0000
@@ -66,7 +66,8 @@
$(INC)/interp_guts.h ${jit_h} ${jit_struct_h}
CLASS_O_FILES = classes/default$(O) classes/perlint$(O) classes/perlstring$(O) \
-classes/perlnum$(O) classes/perlarray$(O) classes/perlundef$(O)
+classes/perlnum$(O) classes/perlarray$(O) classes/perlundef$(O) \
+classes/schemepair$(O)
ENCODING_O_FILES = encodings/singlebyte$(O) encodings/utf8$(O) encodings/utf16$(O) \
encodings/utf32$(O)
Index: core.ops
===================================================================
RCS file: /cvs/public/parrot/core.ops,v
retrieving revision 1.68
diff -u -r1.68 core.ops
--- core.ops 4 Jan 2002 02:36:25 -0000 1.68
+++ core.ops 6 Jan 2002 19:17:55 -0000
@@ -554,8 +554,15 @@
Set $1 to $2.
-=cut
+=item B<set>(p, i|ic, p)
+
+Set $1[$2] to $3
+=item B<set>(p, p, i|ic)
+
+Set $1 to $2[$3]
+
+=cut
inline op set(i, i|ic) {
$1 = $2;
@@ -614,6 +621,11 @@
goto NEXT();
}
+inline op set(p, p) {
+ $1 = $2;
+ goto NEXT();
+}
+
inline op set(p, i|ic, i|ic) {
$1->vtable->set_integer_index(interpreter, $1, $2, $3);
goto NEXT();
@@ -644,6 +656,16 @@
goto NEXT();
}
+inline op set(p, i|ic, p) { /* FIXME: Order of arguments diffrent from above */
+ $1->vtable->set_pmc_index (interpreter, $1, $3, $2);
+ goto NEXT();
+}
+
+inline op set(p, p, i|ic) {
+ $1 = $2->vtable->get_pmc_index (interpreter, $2, $3);
+ goto NEXT();
+}
+
=back
=cut
@@ -2581,6 +2603,28 @@
}
newpmc = pmc_new(interpreter, $2);
$1 = newpmc;
+ goto NEXT();
+}
+
+=item B<get_type>(i, p)
+
+get the type of the PMC C<p> and store it in C<i>
+
+=cut
+
+op get_type (i, p) {
+ $1 = $2->vtable->type(interpreter, $2);
+ goto NEXT();
+}
+
+=item B<get_type>(s, p)
+
+get the typename of the PMC C<p> and store it in C<s>
+
+=cut
+
+op get_type (s, p) {
+ $1 = $2->vtable->name(interpreter, $2);
goto NEXT();
}
Index: global_setup.c
===================================================================
RCS file: /cvs/public/parrot/global_setup.c,v
retrieving revision 1.12
diff -u -r1.12 global_setup.c
--- global_setup.c 1 Jan 2002 03:46:40 -0000 1.12
+++ global_setup.c 6 Jan 2002 19:17:55 -0000
@@ -15,20 +15,24 @@
#include "parrot/parrot.h"
/* Needed because this might get compiled before pmcs have been built */
+void Parrot_PerlUndef_class_init(void);
void Parrot_PerlInt_class_init(void);
void Parrot_PerlNum_class_init(void);
void Parrot_PerlString_class_init(void);
void Parrot_PerlArray_class_init(void);
+void Parrot_SchemePair_class_init(void);
void
init_world(void) {
string_init(); /* Set up the string subsystem */
/* Call base vtable class constructor methods! */
+ Parrot_PerlUndef_class_init();
Parrot_PerlInt_class_init();
Parrot_PerlNum_class_init();
Parrot_PerlString_class_init();
Parrot_PerlArray_class_init();
+ Parrot_SchemePair_class_init();
}
/*
Index: vtable.tbl
===================================================================
RCS file: /cvs/public/parrot/vtable.tbl,v
retrieving revision 1.10
diff -u -r1.10 vtable.tbl
--- vtable.tbl 18 Dec 2001 07:05:00 -0000 1.10
+++ vtable.tbl 6 Jan 2002 19:17:55 -0000
@@ -51,3 +51,7 @@
unique void logical_not PMC* value
str void match PMC* value REGEX* re
str void repeat PMC* value PMC* dest
+
+unique void set_pmc_index PMC* value INTVAL index
+unique PMC* get_pmc_index INTVAL index
+
Index: classes/.cvsignore
===================================================================
RCS file: /cvs/public/parrot/classes/.cvsignore,v
retrieving revision 1.2
diff -u -r1.2 .cvsignore
--- classes/.cvsignore 11 Dec 2001 12:03:23 -0000 1.2
+++ classes/.cvsignore 6 Jan 2002 19:17:55 -0000
@@ -1,3 +1,4 @@
Makefile
*.c
default.h
+*.h
Index: classes/Makefile.in
===================================================================
RCS file: /cvs/public/parrot/classes/Makefile.in,v
retrieving revision 1.12
diff -u -r1.12 Makefile.in
--- classes/Makefile.in 4 Jan 2002 02:29:18 -0000 1.12
+++ classes/Makefile.in 6 Jan 2002 19:17:55 -0000
@@ -5,7 +5,7 @@
H_FILES = $(INC)/parrot.h default.h
-O_FILES = default$(O) perlint$(O) perlstring$(O) perlnum$(O) perlarray$(O)
perlundef$(O)
+O_FILES = default$(O) perlint$(O) perlstring$(O) perlnum$(O) perlarray$(O)
+perlundef$(O) schemepair$(O)
#DO NOT ADD C COMPILER FLAGS HERE
#Add them in Configure.pl--look for the
@@ -52,6 +52,11 @@
$(PERL) pmc2c.pl perlundef.pmc
perlundef$(O): $(H_FILES)
+
+schemepair.c schemepair.h: schemepair.pmc
+ $(PERL) pmc2c.pl schemepair.pmc
+
+schemepair$(O): $(H_FILES)
clean:
$(RM_F) *.c *$(O) default.h
Index: classes/default.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/default.pmc,v
retrieving revision 1.5
diff -u -r1.5 default.pmc
--- classes/default.pmc 1 Jan 2002 22:55:47 -0000 1.5
+++ classes/default.pmc 6 Jan 2002 19:17:56 -0000
@@ -544,4 +544,10 @@
value->vtable->get_integer(INTERP, value), NULL) );
}
+ void set_pmc_index (PMC * value, INTVAL index) {
+ }
+
+ PMC* get_pmc_index (INTVAL index) {
+ }
+
}
Index: classes/perlarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlarray.pmc,v
retrieving revision 1.2
diff -u -r1.2 perlarray.pmc
--- classes/perlarray.pmc 4 Jan 2002 16:09:01 -0000 1.2
+++ classes/perlarray.pmc 6 Jan 2002 19:17:56 -0000
@@ -15,7 +15,7 @@
pmclass PerlArray {
INTVAL type () {
- return 0;
+ return enum_class_PerlArray;
}
STRING* name() {
Index: classes/perlint.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlint.pmc,v
retrieving revision 1.12
diff -u -r1.12 perlint.pmc
--- classes/perlint.pmc 4 Jan 2002 16:09:01 -0000 1.12
+++ classes/perlint.pmc 6 Jan 2002 19:17:56 -0000
@@ -15,7 +15,7 @@
pmclass PerlInt {
INTVAL type () {
- return 0;
+ return enum_class_PerlInt;
}
STRING* name() {
Index: classes/perlnum.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlnum.pmc,v
retrieving revision 1.13
diff -u -r1.13 perlnum.pmc
--- classes/perlnum.pmc 4 Jan 2002 16:09:01 -0000 1.13
+++ classes/perlnum.pmc 6 Jan 2002 19:17:56 -0000
@@ -15,7 +15,7 @@
pmclass PerlNum {
INTVAL type () {
- return 0;
+ return enum_class_PerlNum;
}
STRING* name() {
Index: classes/perlstring.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlstring.pmc,v
retrieving revision 1.13
diff -u -r1.13 perlstring.pmc
--- classes/perlstring.pmc 4 Jan 2002 16:09:01 -0000 1.13
+++ classes/perlstring.pmc 6 Jan 2002 19:17:56 -0000
@@ -15,7 +15,7 @@
pmclass PerlString {
INTVAL type () {
- return 0;
+ return enum_class_PerlString;
}
STRING* name() {
Index: classes/perlundef.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlundef.pmc,v
retrieving revision 1.3
diff -u -r1.3 perlundef.pmc
--- classes/perlundef.pmc 4 Jan 2002 16:09:01 -0000 1.3
+++ classes/perlundef.pmc 6 Jan 2002 19:17:57 -0000
@@ -15,6 +15,7 @@
pmclass PerlUndef {
INTVAL type () {
+ return enum_class_PerlUndef;
}
STRING* name () {
Index: include/parrot/pmc.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/pmc.h,v
retrieving revision 1.9
diff -u -r1.9 pmc.h
--- include/parrot/pmc.h 18 Dec 2001 07:05:01 -0000 1.9
+++ include/parrot/pmc.h 6 Jan 2002 19:17:57 -0000
@@ -19,6 +19,7 @@
enum_class_PerlNum,
enum_class_PerlString,
enum_class_PerlArray,
+ enum_class_SchemePair,
enum_class_max
};
VAR_SCOPE VTABLE Parrot_base_vtables[enum_class_max];
Index: languages/scheme/Scheme/Generator.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Generator.pm,v
retrieving revision 1.1
diff -u -r1.1 Generator.pm
--- languages/scheme/Scheme/Generator.pm 24 Oct 2001 19:27:20 -0000 1.1
+++ languages/scheme/Scheme/Generator.pm 6 Jan 2002 19:17:58 -0000
@@ -3,6 +3,9 @@
use strict;
use Data::Dumper;
+sub PerlUndef { 0 }
+sub SchemePair { 5 }
+
sub _gensym {
return sprintf "G%04d",shift->{gensym}++;
}
@@ -11,7 +14,6 @@
my $self = shift;
push @{$self->{instruction}},[@_];
}
-
#------------------------------------
my $regs = {
@@ -39,6 +41,12 @@
@temp;
}
+sub _save_1 {
+ my $type = shift || 'I';
+ my @temp = _save 1, $type;
+ $temp[0];
+}
+
sub _restore {
die "Nothing to restore"
unless defined @_;
@@ -92,7 +100,7 @@
my $return;
my $label = $self->_gensym();
- $return = "I"._save(1,'I');
+ $return = "I"._save(1,'I');
my $cond = $self->_generate($node->{children}[0]);
$self->_add_inst('','eq',[$cond,0,"FALSE_$label"]);
my $true = $self->_generate($node->{children}[1]);
@@ -194,34 +202,206 @@
sub _op_equal_p {
}
-sub _op_pair {
+sub _op_pair_p {
+ my ($self,$node) = @_;
+ my $return;
+
+ print STDERR "pair?: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ $return = $self->_constant(0);
+
+ my $temp = $self->_generate($node->{children}->[0]);
+ if ($temp =~ m/^P/) {
+ my $type = _save_1('I');
+ my $label = $self->_gensym();
+
+ $self->_add_inst ('', 'get_type', [$type,$temp]);
+ $self->_add_inst ('', 'ne', [SchemePair,$type,"DONE_$label"]);
+ $self->_add_inst ('', 'set', [$return,'1']);
+ $self->_add_inst("DONE_$label");
+ _restore ($type);
+ }
+
+ _restore($temp);
+ return $return;
}
sub _op_cons {
+ my ($self, $node) = @_;
+ my $return;
+
+ print STDERR "cons: wrong number of arguments\n"
+ unless $#{$node->{children}} == 1;
+
+ my $car = $self->_generate($node->{children}->[0]);
+ $return = _save_1('P');
+ $self->_add_inst ('', 'new', [$return,'SchemePair']);
+ if ($car =~ m/^P/) { # FIXME: This is for the strange order index in set
+ $self->_add_inst ('', 'set', [$return,'0',$car]);
+ }
+ else {
+ $self->_add_inst ('', 'set', [$return,$car,'0']);
+ }
+ _restore ($car);
+
+ my $cdr = $self->_generate($node->{children}->[1]);
+ if ($cdr =~ m/^P/) {
+ $self->_add_inst ('', 'set', [$return,'1',$cdr]);
+ }
+ else {
+ $self->_add_inst ('', 'set', [$return,$cdr,'1']);
+ }
+ _restore ($cdr);
+
+ return $return;
}
sub _op_car {
+ my ($self, $node) = @_;
+ my $return;
+
+ print STDERR "car: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ my $temp = $self->_generate($node->{children}->[0]);
+ $return = _save_1('P');
+ $self->_add_inst ('', 'set', [$return,$temp,'0']);
+ _restore ($temp);
+
+ return $return;
}
sub _op_cdr {
+ my ($self, $node) = @_;
+ my $return;
+
+ print STDERR "cdr: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ my $temp = $self->_generate($node->{children}->[0]);
+ $return = _save_1('P');
+ $self->_add_inst ('', 'set', [$return,$temp,'1']);
+ _restore ($temp);
+
+ return $return;
}
sub _op_set_car {
+ my ($self, $node) = @_;
+
+ print STDERR "set-cdr!: wrong number of arguments\n"
+ unless $#{$node->{children}} == 1;
+
+ my $pair = $self->_generate($node->{children}->[0]);
+ my $value = $self->_generate($node->{children}->[1]);
+
+ if ($value =~ m/^P/) {
+ $self->_add_inst ('', 'set', [$pair, '0', $value]);
+ }
+ else {
+ $self->_add_inst ('', 'set', [$pair, $value, '0']);
+ }
+ _restore ($value);
+
+ return $pair; # FIXME: This value should be unspecified
}
sub _op_set_cdr {
+ my ($self, $node) = @_;
+
+ print STDERR "set-cdr!: wrong number of arguments\n"
+ unless $#{$node->{children}} == 1;
+
+ my $pair = $self->_generate($node->{children}->[0]);
+ my $value = $self->_generate($node->{children}->[1]);
+
+ if ($value =~ m/^P/) {
+ $self->_add_inst ('', 'set', [$pair, '1', $value]);
+ }
+ else {
+ $self->_add_inst ('', 'set', [$pair, $value, '1']);
+ }
+ _restore ($value);
+
+ return $pair; # FIXME: This value should be unspecified
}
-sub _op_null {
+sub _op_null_p {
+ my ($self, $node) = @_;
+ my $return;
+
+ print STDERR "null?: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ my $temp = $self->_generate($self->{children}->[0]);
+ $return = $self->constant(0);
+ if ( $temp =~ m/^P/) {
+ my $label = $self->_gensym();
+ my $type = _save_1('1');
+
+ $self->_add_inst ('', 'get_type', [$type, $temp]);
+ $self->_add_inst ('', 'ne', [$type, PerlUndef, "DONE_$label"]);
+ $self->_add_inst ('', 'set', [$return, '1']);
+ _restore ($type);
+ }
+
+ _restore ($temp);
+
+ return $return;
}
sub _op_list_p {
}
sub _op_list {
+ my ($self, $node) = @_;
+ my $return = _save_1 ('P');
+
+ $self->_add_inst ('', 'new', [$return, 'PerlUndef']);
+
+ if ($node->{children}) {
+ my $item;
+ my $lastitem;
+ for (my $i = $#{$node->{children}}; $i >= 0; $i--) {
+ $item = $self->_generate ($node->{children}->[$i]);
+ $lastitem = _save_1 ('P');
+ $self->_add_inst ('', 'new', [$lastitem, 'SchemePair']);
+ $self->_add_inst ('', 'set', [$lastitem, '1', $return]);
+ if ($item =~ m/^P/) {
+ $self->_add_inst ('', 'set', [$lastitem, '0', $item]);
+ } else {
+ $self->_add_inst ('', 'set', [$lastitem, $item, '0']);
+ }
+ $self->_add_inst ('', 'set', [$return, $lastitem]);
+ _restore ($item, $lastitem);
+ }
+ }
+
+ return $return;
}
sub _op_length {
+ my ($self,$node) = @_;
+ my $return;
+ my $label = $self->_gensym();
+
+ print STDERR "length: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ $return = $self->_constant(0);
+
+ my $list = $self->_generate($node->{children}->[0]);
+ my $type = _save_1('I');
+ $self->_add_inst("LOOP_$label", 'get_type', [$type,$list]);
+ $self->_add_inst('', 'ne', [$type,SchemePair,"DONE_$label"]);
+ $self->_add_inst('', 'inc', [$return]);
+ $self->_add_inst('', 'set', [$list,$list,'1']);
+ $self->_add_inst('', 'branch', ["LOOP_$label"]);
+ $self->_add_inst("DONE_$label");
+ _restore ($list, $type);
+
+ return $return
}
sub _op_append {
@@ -1019,8 +1199,8 @@
'cons' => \&_op_cons,
'car' => \&_op_car,
'cdr' => \&_op_cdr,
- 'set-car!' => \&_op_set_car_bang,
- 'set-cdr!' => \&_op_set_cdr_bang,
+ 'set-car!' => \&_op_set_car,
+ 'set-cdr!' => \&_op_set_cdr,
# Not adding caar/cadr/cdar/whatever
'null?' => \&_op_null_p,
'list?' => \&_op_list_p,
@@ -1322,10 +1502,11 @@
sub generate {
my $self = shift;
my @temp = _save(1);
- $self->_generate($self->{tree},$temp[0]);
#die Dumper($self->{tree});
+ $self->_generate($self->{tree},$temp[0]);
_restore(@temp);
$self->_add_inst('',"end");
+# print STDERR Dumper $self->{instruction};
$self->_format_columns();
}
Index: languages/scheme/Scheme/Tokenizer.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Tokenizer.pm,v
retrieving revision 1.1
diff -u -r1.1 Tokenizer.pm
--- languages/scheme/Scheme/Tokenizer.pm 24 Oct 2001 19:27:20 -0000 1.1
+++ languages/scheme/Scheme/Tokenizer.pm 6 Jan 2002 19:17:58 -0000
@@ -34,6 +34,9 @@
} elsif($ch eq '?' and
$token =~ /^[a-z]/) { # Question marks can follow an identifier
$token .= $ch;
+ } elsif($ch eq '!' and
+ $token =~ /^[a-z]/) { # Exclamaition marks can follow an identifier
+ $token .= $ch;
} elsif($ch eq '=' and
$token =~ /^[<>]/) { # Equal sign can follow '<','>'
$token .= $ch;
Index: languages/scheme/t/harness
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/t/harness,v
retrieving revision 1.1
diff -u -r1.1 harness
--- languages/scheme/t/harness 24 Oct 2001 19:27:20 -0000 1.1
+++ languages/scheme/t/harness 6 Jan 2002 19:17:58 -0000
@@ -4,5 +4,5 @@
use Test::Harness qw(runtests);
use lib '../..';
-my @tests = map { glob( "t/$_/*.t" ) } ( qw(io arith logic) );
+my @tests = map { glob( "t/$_/*.t" ) } ( qw(io arith logic lists) );
runtests( @tests );
