Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.223
diff -u -r1.223 MANIFEST
--- MANIFEST 23 Sep 2002 00:11:18 -0000 1.223
+++ MANIFEST 23 Sep 2002 23:19:34 -0000
@@ -35,6 +35,7 @@
classes/perlundef.pmc
classes/pmc2c.pl
classes/pointer.pmc
+classes/scratchpad.pmc
classes/sub.pmc
config/auto/alignptrs.pl
config/auto/alignptrs/test_c.in
@@ -516,6 +517,7 @@
languages/scheme/t/harness
languages/scheme/t/io/basic.t
languages/scheme/t/logic/basic.t
+languages/scheme/t/logic/defines.t
languages/scheme/t/logic/lists.t
lib/Class/Struct.pm
lib/Make.pm
Index: classes/scratchpad.pmc
===================================================================
RCS file: classes/scratchpad.pmc
diff -N classes/scratchpad.pmc
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ classes/scratchpad.pmc 23 Sep 2002 23:19:34 -0000
@@ -0,0 +1,475 @@
+
+/* Scratchpad.pmc
+ * Copyright: (When this is determined...it will go here)
+ * CVS Info
+ * $Id$
+ * Overview:
+ * These are the vtable functions for the Scratchpad base class.
+ * It implements an array of nested lexical scopes, each of which
+ * is currently a PerlHash. Scratchpads are currently intended to
+ * be manipulated only by the scratchpad-handling functions
+ * defined in sub.c and by the lexical operations in core.ops, and
+ * not by the user.
+ * History: Initial revision Mon Sep 16 2002 by Sean O'Rourke
+ * Notes:
+ * References: Most compiler books, e.g. Aho, Sethi, and Ullman,
+ * "Compilers: Principles, tools, and techniques."
+ */
+
+#include "parrot/parrot.h"
+
+#define NO_DEPTH (-100000)
+
+static PMC * pad_keys(struct Parrot_Interp *, PMC *, INTVAL * , STRING ** );
+static PMC * pad_index_pmc(struct Parrot_Interp *, PMC *, INTVAL, STRING *,
+ int);
+static HASH_ENTRY * pad_find (struct Parrot_Interp *, PMC *, STRING *);
+static PMC * pad_copy (struct Parrot_Interp *, PMC *, INTVAL);
+static HASH_ENTRY * pad_index (struct Parrot_Interp *, PMC *, INTVAL,
+ STRING *, int);
+static INTVAL pad_offset (PMC *, INTVAL);
+
+/*
+ * rest_of_key = pad_keys(interp, key, &ix, &sx)
+ *
+ * Get pad-relevant elements from a key, returning the remainder of
+ * the key.
+ *
+ * { string, ... } -> [NO_DEPTH, string] (lexical name without depth)
+ * { int } -> [int, NULL] (lexical depth without name)
+ * { int, string, ... } -> [int, string] (lexical name at depth)
+ */
+static PMC *
+pad_keys(struct Parrot_Interp * interp, PMC * key, INTVAL * ix, STRING ** sx)
+{
+ if (key_type(interp, key) & KEY_string_FLAG) {
+ /* need to do a pad_find */
+ *ix = NO_DEPTH;
+ *sx = key_string(interp, key);
+ return key_next(interp, key);
+ }
+
+ *ix = key_integer(interp, key);
+ key = key_next(interp, key);
+ if (key) {
+ *sx = key_string(interp, key);
+ key = key_next(interp, key);
+ }
+ else {
+ *sx = NULL;
+ }
+ return key;
+}
+
+/*
+ * pmc = pad_index_pmc(interp, pad, depth, name, create)
+ *
+ * If depth is NO_DEPTH, find lexical name (or die).
+ * Else get name at depth.
+ * If create is true, create a new PerlUndef PMC
+ * Else, die.
+ */
+static PMC *
+pad_index_pmc(struct Parrot_Interp * interp, PMC * self, INTVAL ix,
+ STRING * sx, int create)
+{
+ HASH_ENTRY * e;
+
+ /* XXX: should this auto-insert? */
+ if (ix == NO_DEPTH)
+ e = pad_find(interp, self, sx);
+ else
+ e = pad_index(interp, self, ix, sx, create);
+ if (e == NULL)
+ internal_exception(-1, "No such variable\n");
+
+ if (e->val.pmc_val == NULL) {
+ /* XXX: perl-specificity... */
+ e->type = enum_hash_pmc;
+ e->val.pmc_val = pmc_new(interp, enum_class_PerlUndef);
+ }
+ return e->val.pmc_val;
+}
+
+/* Just to make it compile */
+INTVAL
+pad_offset (PMC *pmc, INTVAL ix)
+{
+ internal_exception (0, "pad_offset not implemented");
+ return 0;
+}
+
+HASH_ENTRY *
+pad_find (struct Parrot_Interp *interpreter, PMC *pmc, STRING *sx)
+{
+ HASH_ENTRY *e = NULL;
+ PMC *pad;
+ INTVAL i;
+
+ i = pmc->cache.int_val;
+ while (e == NULL && i--) {
+ pad = ((PMC**)pmc->data)[i];
+ e = hash_get (interpreter, (HASH *)pad->data, sx);
+ }
+
+ return e;
+}
+
+HASH_ENTRY *
+pad_index (struct Parrot_Interp *interpreter, PMC *pmc,
+ INTVAL ix, STRING *sx, int create)
+{
+ HASH_ENTRY * e;
+ PMC* pad;
+
+ if (ix < -pmc->cache.int_val || ix >= pmc->cache.int_val) {
+ internal_exception (OUT_OF_BOUNDS, "Scrachpad: index out of bounds");
+ return NULL;
+ }
+ if (ix < 0) ix += pmc->cache.int_val;
+
+ pad = ((PMC **)pmc->data)[ix];
+ e = hash_get (interpreter, (HASH *)pad->data, sx);
+
+ if (e == NULL && create) {
+ HASH_ENTRY new_entry;
+ new_entry.type = enum_hash_pmc;
+ new_entry.val.pmc_val = pmc_new (interpreter, enum_class_PerlUndef);
+ hash_put (interpreter, (HASH *)pad->data, sx, &new_entry);
+ e = hash_get (interpreter, (HASH *)pad->data, sx);
+ }
+
+ return e;
+}
+
+PMC *
+pad_copy (struct Parrot_Interp *interpreter, PMC *pmc, INTVAL depth)
+{
+ PMC *self = pmc_new (interpreter, enum_class_Scratchpad);
+
+ self->data = mem_sys_allocate (depth * sizeof (PMC *));
+ mem_sys_memcopy (self->data, pmc->data, depth * sizeof (PMC *));
+
+ self->cache.int_val = depth;
+
+ return self;
+}
+
+pmclass Scratchpad {
+
+ void init () {
+ SELF->cache.int_val = 0;
+ SELF->data = NULL;
+ SELF->flags |= PMC_custom_mark_FLAG | PMC_active_destroy_FLAG;
+ }
+
+ PMC* mark (PMC* last) {
+ int j;
+ for (j = 0; j < SELF->cache.int_val; j++)
+ last = mark_used(((PMC **)SELF->data)[j], last);
+ return last;
+ }
+
+ void destroy () {
+ fprintf(stderr, "Freed pad at %p\n", SELF);
+ mem_sys_free(SELF->data);
+ }
+
+ INTVAL type () {
+ return enum_class_Scratchpad;
+ }
+
+ INTVAL type_keyed (PMC* key) {
+ INTVAL ix;
+ STRING * sx;
+ PMC * p;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (sx == NULL)
+ return enum_class_PerlHash;
+ p = pad_index_pmc(INTERP, SELF, ix, sx, 0);
+ if (key)
+ return p->vtable->type_keyed(INTERP, p, key);
+ return p->vtable->type(INTERP, p);
+ }
+
+ INTVAL type_keyed_int (INTVAL* key) {
+ return enum_class_PerlHash;
+ }
+
+ STRING* name () {
+ return whoami;
+ }
+
+ PMC* clone () {
+ return pad_copy(INTERP, SELF, SELF->cache.int_val);
+ }
+
+ PMC* clone_keyed (PMC* key) {
+ INTVAL ix;
+ STRING * sx;
+ PMC * p;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (sx == NULL) {
+ ix = pad_offset(SELF, ix);
+ p = ((PMC **)SELF->data)[pad_offset(SELF, ix)];
+ return p->vtable->clone(INTERP, p);
+ }
+ p = pad_index_pmc(INTERP, SELF, ix, sx, 0);
+ if (key)
+ return p->vtable->clone_keyed(INTERP, p, key);
+ return p->vtable->clone(INTERP, p);
+ }
+
+ PMC* clone_keyed_int (INTVAL* key) {
+ return pad_copy(INTERP, SELF, *key);
+ }
+
+ INTVAL get_integer () {
+ return SELF->cache.int_val;
+ }
+
+ void set_integer_native (INTVAL depth) {
+ if (depth < 0) {
+ depth += SELF->cache.int_val;
+ if (depth < 0)
+ internal_exception(-1, "index too negative\n");
+ }
+ if (depth > SELF->cache.int_val) {
+ int i;
+ PMC ** p;
+ SELF->data = mem_sys_realloc(SELF->data, depth * sizeof(PMC *));
+ p = (PMC**)SELF->data;
+ for (i = SELF->cache.int_val; i < depth; i++)
+ p[i] = pmc_new(INTERP, enum_class_PerlHash);
+ }
+ SELF->cache.int_val = depth;
+ }
+
+ void set_integer (PMC * p) {
+ INTVAL i = p->vtable->get_integer(INTERP, p);
+ SELF.set_integer_native(i);
+ }
+
+/* INTVAL get_integer_keyed (PMC* key) { */
+/* } */
+
+/* XXX: not sure how these will be used, so they're currently unavailable. */
+/* INTVAL elements () { */
+/* return SELF->cache.int_val; */
+/* } */
+
+/* INTVAL elements_keyed (PMC* key) { */
+/* } */
+
+/* INTVAL elements_keyed_int (INTVAL* key) { */
+/* PMC * thing = SELF.get_pmc_keyed_int(key); */
+/* if (thing) */
+/* return thing->vtable->elements(INTERP, thing); */
+/* return 0; */
+/* } */
+
+ PMC* get_pmc () {
+ return SELF;
+ }
+
+ PMC* get_pmc_keyed (PMC* key) {
+ INTVAL ix;
+ STRING * sx;
+ PMC * p;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (sx == NULL)
+ return ((PMC **)SELF->data)[pad_offset(SELF, ix)];
+ p = pad_index_pmc(INTERP, SELF, ix, sx, 0);
+ if (key)
+ return p->vtable->get_pmc_keyed(INTERP, p, key);
+ return p->vtable->get_pmc(INTERP, p);
+ }
+
+ PMC* get_pmc_keyed_int (INTVAL* key) {
+ INTVAL k = pad_offset(SELF, *key);
+ return ((PMC **)SELF->data)[k];
+ }
+
+ void set_integer_keyed (PMC* key, INTVAL value) {
+ INTVAL ix;
+ STRING * sx;
+ PMC * p;
+ if (key == NULL) {
+ SELF.set_integer_native(value);
+ return;
+ }
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (sx == NULL)
+ internal_exception(-1, "Can't set a lexical scope level\n");
+ p = pad_index_pmc(INTERP, SELF, ix, sx, 1);
+ if (key)
+ return p->vtable->set_integer_keyed(INTERP, p, key, value);
+ return p->vtable->set_integer_native(INTERP, p, value);
+ }
+
+ void set_number_keyed (PMC* key, FLOATVAL value) {
+ INTVAL ix;
+ STRING * sx;
+ PMC * p;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (sx == NULL)
+ internal_exception(-1, "Can't set a lexical scope level\n");
+ p = pad_index_pmc(INTERP, SELF, ix, sx, 1);
+ if (key)
+ return p->vtable->set_number_keyed(INTERP, p, key, value);
+ return p->vtable->set_number_native(INTERP, p, value);
+ }
+
+ void set_string_keyed (PMC* key, STRING* value) {
+ INTVAL ix;
+ STRING * sx;
+ PMC * p;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (sx == NULL)
+ internal_exception(-1, "Can't set a lexical scope level\n");
+ p = pad_index_pmc(INTERP, SELF, ix, sx, 1);
+ if (key)
+ return p->vtable->set_string_keyed(INTERP, p, key, value);
+ return p->vtable->set_string_native(INTERP, p, value);
+ }
+
+ void set_pmc_keyed (PMC* key, PMC* value, PMC* value_key) {
+ INTVAL ix;
+ STRING * sx;
+ PMC * p, * val;
+ HASH_ENTRY * e;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (sx == NULL)
+ internal_exception(-1, "Can't set a lexical scope level\n");
+
+ /* XXX: should this auto-insert? */
+ if (ix == NO_DEPTH)
+ e = pad_find(INTERP, SELF, sx);
+ else
+ e = pad_index(INTERP, SELF, ix, sx, 1);
+ if (key == NULL) {
+ /* Special case -- make this just like "set Py, Px" if
+ * there are no more keys. */
+ if (value_key)
+ e->val.pmc_val
+ = value->vtable->get_pmc_keyed(INTERP, value, value_key);
+ else
+ e->val.pmc_val = value->vtable->get_pmc(INTERP, value);
+ }
+ else {
+ p = e->val.pmc_val;
+ p->vtable->set_pmc_keyed(INTERP, p, key, value, value_key);
+ }
+ }
+
+/* void set_pmc_keyed_int (INTVAL* key, PMC* value, INTVAL* value_key) { */
+/* } */
+
+ void set_same (PMC* value) {
+ SELF->cache.int_val = value->cache.int_val;
+ mem_sys_free(SELF->data);
+ SELF->data = mem_sys_allocate(value->cache.int_val * sizeof(PMC *));
+ mem_sys_memcopy(SELF->data, value->data,
+ value->cache.int_val * sizeof(PMC *));
+ }
+
+/* void set_same_keyed (PMC* key, PMC* value, PMC* value_key) { */
+/* } */
+
+/* void set_same_keyed_int (INTVAL* key, PMC* value, INTVAL* value_key) { */
+/* } */
+
+ PMC* pop_pmc () {
+ PMC * ret;
+ if (SELF->cache.int_val == 0)
+ internal_exception(OUT_OF_BOUNDS, "No nested scopes\n");
+ return ((PMC **)SELF->data)[--(SELF->cache.int_val)];
+ }
+
+ void push_pmc (PMC* value) {
+ if (value->vtable != &Parrot_base_vtables[enum_class_PerlHash])
+ internal_exception(-1, "Wrong type for scope stack\n");
+ SELF->data = mem_sys_realloc(SELF->data, ++SELF->cache.int_val);
+ ((PMC **)SELF->data)[SELF->cache.int_val - 1] = value;
+ }
+
+ INTVAL defined () {
+ return 1;
+ }
+
+ INTVAL defined_keyed (PMC* key) {
+ INTVAL ix;
+ STRING * sx;
+ PMC * p;
+ HASH_ENTRY * e;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (ix == NO_DEPTH)
+ e = pad_find(INTERP, SELF, sx);
+ else
+ e = pad_index(INTERP, SELF, ix, sx, 0);
+ if (e == NULL)
+ return 0;
+
+ p = e->val.pmc_val;
+ if (key)
+ return p->vtable->defined_keyed(INTERP, p, key);
+ return p->vtable->defined(INTERP, p);
+ }
+
+ INTVAL defined_keyed_int (INTVAL* key) {
+ return *key < SELF->cache.int_val && *key >= -SELF->cache.int_val;
+ }
+
+ void delete_keyed (PMC* key) {
+ INTVAL ix;
+ STRING * sx;
+ HASH_ENTRY * e;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (ix == NO_DEPTH)
+ e = pad_find(INTERP, SELF, sx);
+ else
+ e = pad_index(INTERP, SELF, ix, sx, 0);
+ if (e == NULL)
+ return;
+
+ if (key == NULL) {
+ /* delete pad entry */
+ HASH * hash;
+ ix = pad_offset(SELF, ix);
+ hash = (HASH *)((PMC **)SELF->data)[ix]->data;
+ hash_delete(INTERP, hash, sx);
+ }
+ else {
+ /* forward to whatever's inside */
+ PMC * p = e->val.pmc_val;
+ p->vtable->delete_keyed(INTERP, p, key);
+ }
+ }
+
+ INTVAL exists_keyed(PMC* key) {
+ INTVAL ix;
+ STRING * sx;
+ HASH_ENTRY * e;
+ key = pad_keys(INTERP, key, &ix, &sx);
+ if (ix == NO_DEPTH)
+ e = pad_find(INTERP, SELF, sx);
+ else
+ e = pad_index(INTERP, SELF, ix, sx, 0);
+ if (e == NULL)
+ return 0;
+
+ if (key == NULL) {
+ /* lexical entry exists */
+ return 1;
+ }
+ else {
+ /* forward to whatever's inside */
+ PMC * p = e->val.pmc_val;
+ return p->vtable->exists_keyed(INTERP, p, key);
+ }
+ }
+
+ INTVAL exists_keyed_int(INTVAL* key) {
+ return *key < SELF->cache.int_val && *key >= -SELF->cache.int_val;
+ }
+}
Index: languages/scheme/Scheme/Builtins.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Builtins.pm,v
retrieving revision 1.1
diff -u -r1.1 Builtins.pm
--- languages/scheme/Scheme/Builtins.pm 5 Sep 2002 19:54:42 -0000 1.1
+++ languages/scheme/Scheme/Builtins.pm 23 Sep 2002 23:19:34 -0000
@@ -6,20 +6,22 @@
(
write =>
[['# Write function', ''],
- ['write_ENTRY', 'save', 'I0'],
- ['', 'typeof', 'I0', 'P5'],
+ ['write_ENTRY', 'typeof', 'I0', 'P5'],
['', 'ne', 'I0', '.PerlUndef', 'write_N_UNDEF'],
['', 'print', '"()"'],
- ['', 'branch', 'write_RET0'],
- ['write_N_UNDEF','eq', 'I0', '.Array', 'write_ARRAY'],
+ ['', 'branch', 'write_RET'],
+ ['write_N_UNDEF','ne', 'I0', '.Scratchpad', 'write_N_LAMBDA'],
+ ['', 'print', '"lambda"'],
+ ['', 'branch', 'write_RET'],
+ ['write_N_LAMBDA','eq', 'I0', '.Array', 'write_ARRAY'],
['', 'print', 'P5'],
- ['', 'branch', 'write_RET0'],
- ['write_ARRAY', 'save', 'P5'],
- ['', 'save', 'P6'],
- ['', 'print', '"("'],
+ ['', 'branch', 'write_RET'],
+ ['write_ARRAY', 'print', '"("'],
['write_NEXT', 'set', 'P6', 'P5'],
['', 'set', 'P5', 'P6[0]'],
+ ['', 'save', 'P6'],
['', 'bsr', 'write_ENTRY'],
+ ['', 'restore', 'P6'],
['', 'set', 'P5', 'P6[1]'],
['', 'typeof', 'I0', 'P5'],
['', 'eq', 'I0', '.PerlUndef', 'write_KET'],
@@ -29,10 +31,28 @@
['write_DOT', 'print', '" . "'],
['', 'bsr', 'write_ENTRY'],
['write_KET', 'print', '")"'],
- ['', 'restore', 'P6'],
- ['', 'restore', 'P5'],
- ['write_RET0', 'restore', 'I0'],
- ['', 'ret'],
+ ['write_RET', 'ret'],
+ ],
+ apply =>
+ [['# apply Function',''],
+ ['apply_ENTRY', 'set', 'P7', 'P5[0]'],
+ ['', 'set', 'I0', 'P7'],
+ ['', 'clone', 'P31', 'P7'],
+ ['', 'add', 'I0', '1'],
+ ['', 'set', 'P31', 'I0'],
+ ['', 'set', 'P7', 'P5[2]'],
+ ['apply_NEXT', 'typeof', 'I0', 'P6'],
+ ['', 'eq', 'I0', '.PerlUndef', 'apply_LAST'],
+ ['', 'set', 'S0', 'P7[0]'],
+# ['', 'set', 'P31[-1;S0]', 'P6[0]'], # not working yet
+ ['', 'set', 'P8', 'P6[0]'],
+ ['', 'set', 'P31[-1;S0]', 'P8'],
+#-----------------------------------------------
+ ['', 'set', 'P6', 'P6[1]'],
+ ['', 'set', 'P7', 'P7[1]'],
+ ['', 'branch', 'apply_NEXT'],
+ ['apply_LAST', 'set', 'I0', 'P5[1]'],
+ ['', 'jump', 'I0'],
]
);
Index: languages/scheme/Scheme/Generator.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Generator.pm,v
retrieving revision 1.3
diff -u -r1.3 Generator.pm
--- languages/scheme/Scheme/Generator.pm 5 Sep 2002 15:03:55 -0000 1.3
+++ languages/scheme/Scheme/Generator.pm 23 Sep 2002 23:19:35 -0000
@@ -15,14 +15,17 @@
#------------------------------------
-my $regs = {
- I => { map { $_ => 0 } (0..31) },
- N => { map { $_ => 0 } (0..31) },
- S => { map { $_ => 0 } (0..31) },
- P => { map { $_ => 0 } (0..31) },
+sub _new_regs {
+ {
+ I => { map { $_ => 0 } (0..31) },
+ N => { map { $_ => 0 } (0..31) },
+ S => { map { $_ => 0 } (0..31) },
+ P => { 31 => -1, map { $_ => 0 } (0..30) },
+ };
};
sub _save {
+ my $self = shift;
my $count = shift;
my $type = shift || 'I';
die "No registers to save"
@@ -31,39 +34,101 @@
unless $type and $type=~/^[INPS]$/;
my @temp;
for(0..31) {
- next if $regs->{$type}{$_} == 1;
+ next if $self->{regs}->{$type}{$_} == 1;
last if $count<=0;
push @temp,"$type$_";
- $regs->{$type}{$_}=1;
+ $self->{regs}->{$type}{$_}=1;
$count--;
}
@temp;
}
+sub _save_set {
+ my $self = shift;
+ my %regs = %{$self->{regs}};
+ for my $type (keys %regs) {
+ for my $count (0..31) {
+ $self->_add_inst ('', 'save', ["$type$count"])
+ if $regs{$type}->{$count};
+ }
+ }
+}
+
sub _save_1 {
+ my $self = shift;
my $type = shift || 'I';
- my @temp = _save 1, $type;
+ my @temp = $self->_save(1, $type);
$temp[0];
}
sub _restore {
+ my $self = shift;
+
die "Nothing to restore"
unless defined @_;
- for(@_) {
- s/^(\w)//;
+ foreach my $reg (@_) {
+ next if grep { $_ eq $reg } qw (none);
+ $reg =~ /^(\w)(\d+)/;
die "Missing register type"
unless defined $1;
- $regs->{$1}{$_}=0;
+ if ($self->{regs}->{$1}{$2}) {
+ $self->{regs}->{$1}{$2} = 0;
+ }
+ }
+}
+
+sub _restore_set {
+ my $self = shift;
+ my %regs = %{$self->{regs}};
+
+ for my $type (reverse keys %regs) {
+ for (my $count=31; $count>=0; $count--) {
+ $self->_add_inst ('','restore',["$type$count"])
+ if $regs{$type}->{$count};
+ }
}
}
sub _num_arg {
my ($node, $expected, $name) = @_;
- my $children = scalar @{$node->{children}};
+ my $args = scalar @{$node->{children}} - 1;
+
+ die "$name: Wrong number of arguments (expected $expected, got $args).\n"
+ if ($args != $expected);
+}
+
+sub _get_arg {
+ my ($node, $num) = @_;
+ $node->{children}->[$num];
+}
+
+sub _get_args {
+ my ($node, $num) = @_;
+ $num = 1 unless defined $num;
- die "$name: Wrong number of arguments (expected $expected, got $children).\n"
- if ($children != $expected);
+ my @args = @{$node->{children}};
+ splice @args, 0, $num;
+
+ return @args;
+}
+
+# until there is a working find_lex/store_lex
+sub _find_lex {
+ my ($self, $symbol) = @_;
+ my $return = $self->_save_1 ('P');
+ $self->_add_inst ('','set',[$return,"P31[\"$symbol\"]"]);
+ return $return;
+}
+
+sub _store_lex {
+ my ($self, $symbol,$value) = @_;
+ $self->_add_inst ('','set',["P31[\"$symbol\"]",$value]);
+}
+
+sub _new_lex {
+ my ($self, $symbol, $value) = @_;
+ $self->_add_inst ('','set',["P31[-1;\"$symbol\"]",$value]);
}
#------------------------------------
@@ -78,29 +143,133 @@
#------------------------------------
-sub _op_constant {
- my ($self,$node) = @_;
- my ($num_registers,$type) = @{$type_map->{$node->{type}}};
- my @register = _save($num_registers,$type);
- for(@register) {
- $self->_add_inst('','set',[$_,$node->{value}]);
+sub _constant {
+ my ($self, $value) = @_;
+ my $return;
+
+ if ($value =~ /^[-+]?\d+$/) {
+ $return = $self->_save_1 ('I');
+ $self->_add_inst ('', 'set', [$return,$value]);
+ }
+ elsif ($value =~ /^[-+]?((\d+\.\d*)|(\.d+))([eE][-+]?\d+)?$/) {
+ $return = $self->_save_1 ('N');
+ $self->_add_inst ('', 'set', [$return,$value]);
+ }
+ else {
+ $return = $self->_save_1 ('I');
+ $self->_add_inst ('', 'set', [$return,0]);
}
- return $register[0];
-}
-sub _constant {
- my ($self,$value) = @_;
- return $self->_generate({value=>$value,type=>'INTEGER'});
+ return $return;
}
-#------------------------------------
+sub _morph {
+ my ($self, $to, $from) = @_;
+
+ if ($to =~ /P/) {
+ if ($from =~ /P/) {
+ $self->_add_inst ('', 'clone',[$to,$from]);
+ } elsif ($from =~ /I/) {
+ $self->_add_inst ('', 'new',[$to,'.PerlInt']);
+ $self->_add_inst ('', 'set',[$to,$from]);
+ } elsif ($from =~ /N/) {
+ $self->_add_inst ('', 'new',[$to,'.PerlNum']);
+ $self->_add_inst ('', 'set',[$to,$from]);
+ }
+ }
+}
#---- Section 4 ----
+sub __quoted {
+ my ($self, $node) = @_;
+ my $return = $self->_save_1 ('P');
+
+ if (exists $node->{value}) {
+ my $value = $node->{value};
+ if ($value =~ /^[-+]?\d+$/) {
+ $self->_add_inst ('', 'new',[$return,'.PerlInt']);
+ $self->_add_inst ('', 'set',[$return,$value]);
+ }
+ elsif ($value =~ /^[-+]?((\d+\.\d*)|(\.d+))([eE][-+]?\d+)?$/) {
+ $self->_add_inst ('', 'new',[$return,'.PerlNum']);
+ $self->_add_inst ('', 'set',[$return,$value]);
+ }
+ else { # assume its a symbol
+ $self->_add_inst ('', 'new',[$return,'.PerlString']);
+ $self->_add_inst ('', 'set',[$return,"\"$value\""]);
+ }
+ }
+ elsif (exists $node->{children}) {
+ $self->_add_inst ('', 'new', [$return,'.PerlUndef']);
+ for (reverse @{$node->{children}}) {
+
+ my $item = __quoted ($self, $_);
+ my $pair = $self->_save_1 ('P');
+ $self->_add_inst ('', 'new', [$pair,'.Array']);
+ $self->_add_inst ('', 'set', [$pair,2]);
+ $self->_add_inst ('', 'set', [$pair.'[0]',$item]);
+ $self->_add_inst ('', 'set', [$pair.'[1]',$return]);
+ $self->_add_inst ('', 'set', [$return,$pair]);
+ $self->_restore ($item, $pair);
+ }
+ }
+
+ return $return;
+}
+
sub _op_quote {
+ my ($self, $node) = @_;
+ my $return;
+
+ _num_arg ($node, 1, 'quote');
+
+ my $item = _get_arg($node,1);
+
+ return __quoted ($self, $item);
}
sub _op_lambda {
+ my ($self,$node) = @_;
+ my $return;
+ my $label = $self->_gensym();
+
+ $return = $self->_save_1 ('P');
+
+ $self->_add_inst ('', 'new',[$return,'.Array']);
+ $self->_add_inst ('', 'set',[$return,3]);
+ $self->_add_inst ('', 'set',[$return.'[0]','P31']);
+
+ my $addr = $self->_save_1 ('I');
+ $self->_add_inst ('', 'set_addr',[$addr,"LAMBDA_$label"]);
+ $self->_add_inst ('', 'set',[$return.'[1]',$addr]);
+ $self->_restore ($addr);
+
+ my $temp = __quoted ($self,_get_arg($node,1));
+ $self->_add_inst ('', 'set',[$return.'[2]',$temp]);
+ $self->_restore ($temp);
+
+ $self->_add_inst ('', 'branch',["DONE_$label"]);
+ $self->_add_inst ("LAMBDA_$label");
+
+ # caller saved => start a new frame
+ push @{$self->{frames}}, $self->{regs};
+ $self->{regs} = _new_regs;
+
+ $temp = 'none';
+ for (_get_args($node,2)) {
+ $self->_restore ($temp);
+ $temp = $self->_generate($_);
+ }
+
+ $self->_add_inst('', 'set', ['P5', $temp]);
+
+ $self->_add_inst('', 'ret');
+ $self->_add_inst("DONE_$label");
+
+ $self->{regs} = pop @{$self->{frames}};
+
+ return $return;
}
sub _op_if {
@@ -108,23 +277,84 @@
my $return;
my $label = $self->_gensym();
- $return = "I"._save(1,'I');
- my $cond = $self->_generate($node->{children}[0]);
+ my $cond = $self->_generate(_get_arg($node,1));
$self->_add_inst('','eq',[$cond,0,"FALSE_$label"]);
- my $true = $self->_generate($node->{children}[1]);
- $self->_add_inst('','set',[$return,$true]);
+ $self->_restore($cond);
+ $return = $self->_save_1 ('P');
+
+ my $true = $self->_generate(_get_arg($node,2));
+ $self->_morph($return,$true);
$self->_add_inst('','branch',["DONE_$label"]);
+ $self->_restore($true);
+
$self->_add_inst("FALSE_$label");
- _restore($true);
- _restore($cond);
- my $false = $self->_generate($node->{children}[2]);
- $self->_add_inst('','set',[$return,$false]);
- _restore($false);
+ my $false = $self->_generate(_get_arg($node,3));
+ $self->_morph($return,$false);
+ $self->_restore($false);
+
$self->_add_inst("DONE_$label");
return $return;
}
+sub _op_define {
+ my ($self, $node) = @_;
+
+ _num_arg ($node, 2, 'define');
+
+ my ($symbol, $value);
+
+ if (exists _get_arg($node,1)->{children}) {
+ my @formals;
+ ($symbol, @formals) = @{_get_arg($node,1)->{children}};
+ $symbol = $symbol->{value};
+ my $lambda = { children => [ { value => 'lambda' },
+ { children => [ @formals ] },
+ _get_args ($node, 2) ] };
+ $value = $self->_generate($lambda);
+ }
+ else {
+ $symbol = _get_arg($node,1)->{value};
+ $value = $self->_generate (_get_arg($node,2));
+ }
+
+ if (exists $self->{scope}->{$symbol}) {
+ die "define: $symbol is already defined\n";
+ }
+
+ if ($value !~ /^P/) {
+ my $pmc = $self->_save_1 ('P');
+ $self->_morph ($pmc, $value);
+ $self->_restore ($value);
+ $value = $pmc;
+ }
+
+ $self->{scope}->{$symbol} = 1;
+# $self->_add_inst ('', 'store_lex', ["\"$symbol\"",$temp]);
+ $self->_new_lex ($symbol,$value);
+
+ return $value;
+}
+
sub _op_set_bang {
+ my ($self, $node) = @_;
+
+ _num_arg ($node, 2, 'set!');
+
+ my $symbol = _get_arg ($node, 1)->{value};
+# if (!exists $self->{scope}->{$symbol}) {
+# die "set!: $symbol not in current scope!";
+# }
+ my $temp = $self->_generate(_get_arg($node,2));
+ if ($temp !~ /^P/) {
+ my $pmc = $self->_save_1 ('P');
+ $self->_morph ($pmc, $temp);
+ $self->_restore ($temp);
+ $temp = $pmc;
+ }
+# $self->_add_inst ('', 'store_lex', ["\"$symbol\"",$temp]);
+ $self->_store_lex ($symbol,$temp);
+
+ return $temp;
}
sub _op_cond {
@@ -139,10 +369,10 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- for(@{$node->{children}}) {
+ for(_get_args($node)) {
my $temp = $self->_generate($_);
$self->_add_inst('' ,'eq' ,[$temp,0,"DONE_$label"]);
- _restore($temp);
+ $self->_restore($temp);
}
$self->_add_inst('' ,'set',[$return,1]);
$self->_add_inst("DONE_$label");
@@ -155,10 +385,10 @@
my $label = $self->_gensym();
$return = $self->_constant(1);
- for(@{$node->{children}}) {
+ for(_get_args($node)) {
my $temp = $self->_generate($_);
$self->_add_inst('' ,'eq' ,[$temp,1,"DONE_$label"]);
- _restore($temp);
+ $self->_restore($temp);
}
$self->_add_inst('' ,'set',[$return,0]);
$self->_add_inst("DONE_$label");
@@ -166,6 +396,28 @@
}
sub _op_let {
+ my ($self, $node) = @_;
+ my $return;
+
+ my ($locals, @body) = _get_args ($node,1);
+ my (@variables, @values);
+ for (@{$locals->{children}}) {
+ _num_arg ($_, 1, 'let locals');
+ my ($var, $val) = _get_args ($_, 0);
+ push @variables, $var;
+ push @values, $val;
+ }
+
+ my $let = { children => [
+ { children => [ { value => 'lambda' },
+ { children => [ @variables ] },
+ @body ]},
+ @values
+ ]};
+
+ $return = $self->_generate($let);
+
+ return $return;
}
sub _op_let_star {
@@ -175,6 +427,16 @@
}
sub _op_begin {
+ my ($self, $node) = @_;
+ my $temp = 'none';
+
+ my @args = _get_args ($node);
+
+ for (@args) {
+ $self->_restore ($temp);
+ $temp = $self->_generate ($_);
+ }
+ return $temp;
}
sub _op_do {
@@ -189,13 +451,13 @@
#---- Section 6 ----
sub _op_not {
- my ($self,$node,$return) = @_;
+ my ($self,$node) = @_;
- my @temp = _save(1);
- $self->_generate($node->{children}[0],$temp[0]);
- $self->_add_inst('','not',[$temp[0],$temp[0]]);
- $self->_add_inst('','and',[$return,$temp[0],1]);
- _restore(@temp);
+ my $return = $self->_save_1 ('I');
+ $self->_generate(_get_arg($node,1));
+ $self->_add_inst('','not',[$return,$return]);
+
+ $return;
}
sub _op_boolean_p {
@@ -217,9 +479,9 @@
_num_arg ($node, 1, 'pair?');
- my $item = $self->_generate($node->{children}->[0]);
+ my $item = $self->_generate(_get_arg($node,1));
- $return = _save_1 ('I');
+ $return = $self->_save_1 ('I');
if ($item =~ /^[INS]/) {
$self->_add_inst ('', 'set', [$return,0]);
@@ -244,17 +506,17 @@
_num_arg ($node, 2, 'cons');
- my $car = $self->_generate($node->{children}->[0]);
- $return = _save_1('P');
+ my $car = $self->_generate(_get_arg($node,1));
+ $return = $self->_save_1('P');
$self->_add_inst ('', 'new', [$return,'.Array']);
$self->_add_inst ('', 'set', [$return,2]);
$self->_add_inst ('', 'set', [$return.'[0]',$car]);
- _restore ($car);
+ $self->_restore ($car);
- my $cdr = $self->_generate($node->{children}->[1]);
+ my $cdr = $self->_generate(_get_arg($node,2));
$self->_add_inst ('', 'set', [$return.'[1]', $cdr]);
- _restore ($cdr);
+ $self->_restore ($cdr);
return $return;
}
@@ -264,7 +526,7 @@
_num_arg ($node, 1, 'car');
- my $return = $self->_generate ($node->{children}->[0]);
+ my $return = $self->_generate (_get_arg($node,1));
die "car: Element not pair\n" unless $return =~ /^P/;
$self->_add_inst ('', 'set', [$return,$return.'[0]']);
@@ -276,7 +538,7 @@
_num_arg ($node, 1, 'cdr');
- my $return = $self->_generate ($node->{children}->[0]);
+ my $return = $self->_generate (_get_arg($node,1));
die "cdr: Element not pair\n" unless $return =~ /^P/;
$self->_add_inst ('', 'set', [$return,$return.'[1]']);
@@ -288,11 +550,11 @@
_num_arg ($node, 2, 'set-car!');
- my $return = $self->_generate ($node->{children}->[0]);
+ my $return = $self->_generate (_get_arg($node,1));
die "set-car!: Element not pair\n" unless $return =~ /^P/;
- my $value = $self->_generate ($node->{children}->[1]);
+ my $value = $self->_generate (_get_arg($node,2));
$self->_add_inst ('', 'set', [$return.'[0]',$value]);
- _restore ($value);
+ $self->_restore ($value);
return $return;
}
@@ -302,16 +564,32 @@
_num_arg ($node, 2, 'set-cdr!');
- my $return = $self->_generate ($node->{children}->[0]);
+ my $return = $self->_generate (_get_arg($node,1));
die "set-cdr!: Element not pair\n" unless $return =~ /^P/;
- my $value = $self->_generate ($node->{children}->[1]);
+ my $value = $self->_generate (_get_arg($node,2));
$self->_add_inst ('', 'set', [$return.'[1]',$value]);
- _restore ($value);
+ $self->_restore ($value);
return $return;
}
-sub _op_null {
+sub _op_null_p {
+ my ($self, $node) = @_;
+ my $return = $self->_save_1 ('I');
+ my $label = $self->_gensym();
+
+ _num_arg ($node, 1, 'null?');
+
+ my $temp = $self->_generate(_get_arg($node,1));
+ $self->_add_inst ('', 'typeof',[$return,$temp]);
+ $self->_add_inst ('', 'ne', [$return,'.PerlUndef',"FAIL_$label"]);
+ $self->_add_inst ('', 'set', [$return,1]);
+ $self->_add_inst ('', 'branch', ["DONE_$label"]);
+ $self->_add_inst ("FAIL_$label", 'set', [$return,0]);
+ $self->_add_inst ("DONE_$label");
+ $self->_restore ($temp);
+
+ return $return;
}
sub _op_list_p {
@@ -320,15 +598,15 @@
sub _op_list {
my ($self, $node) = @_;
my $label = $self->_gensym ();
- my $return = _save_1 ('P');
+ my $return = $self->_save_1 ('P');
$self->_add_inst ('', 'new',[$return,'.PerlUndef']);
- return $return unless exists $node->{children};
+ my @reverse = reverse _get_args($node);
- for (reverse @{$node->{children}}) {
+ for (@reverse) {
my $item = $self->_generate($_);
- my $pair = _save_1 ('P');
+ my $pair = $self->_save_1 ('P');
$self->_add_inst ('', 'new',[$pair,'.Array']);
$self->_add_inst ('', 'set',[$pair,2]);
@@ -336,7 +614,7 @@
$self->_add_inst ('', 'set',[$pair.'[1]',$return]);
$self->_add_inst ('', 'set',[$return,$pair]);
- _restore($item, $pair);
+ $self->_restore($item, $pair);
}
return $return;
@@ -345,14 +623,14 @@
sub _op_length {
my ($self, $node) = @_;
my $label = $self->_gensym ();
- my $return = _save_1 ('I');
+ my $return = $self->_save_1 ('I');
_num_arg ($node, 1, 'length');
- my $list = $self->_generate($node->{children}->[0]);
+ my $list = $self->_generate(_get_arg($node,1));
$self->_add_inst ('', 'set',[$return,'0']);
- my $type = _save_1 ('I');
+ my $type = $self->_save_1 ('I');
$self->_add_inst ("NEXT_$label", 'typeof',[$type,$list]);
$self->_add_inst ('', 'eq',[$type,'.PerlUndef', "DONE_$label"]);
$self->_add_inst ('', 'ne',[$type,'.Array', "ERR_$label"]);
@@ -430,15 +708,21 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
- $self->_add_inst('','ne',[$temp_0,$temp_1,"DONE_$label"]);
- _restore($temp_1);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$_]);
+ if (substr ($temp_0, 0, 1) ne substr ($temp_1, 0, 1)) {
+ my $temp_2 = $self->_save_1(substr ($temp_0, 0, 1));
+ $self->_morph($temp_2, $temp_1);
+ $self->_restore ($temp_1);
+ $temp_1 = $temp_2;
+ }
+ $self->_add_inst ('', 'ne', [$temp_0,$temp_1,"DONE_$label"]);
+ $self->_restore($temp_1);
}
$self->_add_inst('','set',[$return,1]);
$self->_add_inst("DONE_$label");
- _restore($temp_0);
+ $self->_restore($temp_0);
return $return;
}
@@ -448,15 +732,15 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$_]);
$self->_add_inst('','ge',[$temp_0,$temp_1,"DONE_$label"]);
- _restore($temp_1);
+ $self->_restore($temp_1);
}
$self->_add_inst('','set',[$return,1]);
$self->_add_inst("DONE_$label");
- _restore($temp_0);
+ $self->_restore($temp_0);
return $return;
}
@@ -466,15 +750,15 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$_]);
$self->_add_inst('','le',[$temp_0,$temp_1,"DONE_$label"]);
- _restore($temp_1);
+ $self->_restore($temp_1);
}
$self->_add_inst('','set',[$return,1]);
$self->_add_inst("DONE_$label");
- _restore($temp_0);
+ $self->_restore($temp_0);
return $return;
}
@@ -484,15 +768,15 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$_]);
$self->_add_inst('','gt',[$temp_0,$temp_1,"DONE_$label"]);
- _restore($temp_1);
+ $self->_restore($temp_1);
}
$self->_add_inst('','set',[$return,1]);
$self->_add_inst("DONE_$label");
- _restore($temp_0);
+ $self->_restore($temp_0);
return $return;
}
@@ -502,15 +786,15 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$1]);
$self->_add_inst('','lt',[$temp_0,$temp_1,"DONE_$label"]);
- _restore($temp_1);
+ $self->_restore($temp_1);
}
$self->_add_inst('','set',[$return,1]);
$self->_add_inst("DONE_$label");
- _restore($temp_0);
+ $self->_restore($temp_0);
return $return;
}
@@ -520,12 +804,11 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my @temp = _save(1);
$self->_add_inst('' ,'set' ,[$return,1]);
- my $temp = $self->_generate($node->{children}[0]);
+ my $temp = $self->_generate($node->{children}[1]);
$self->_add_inst('' ,'eq' ,[$temp,0,"DONE_$label"]);
- _restore($temp);
+ $self->_restore($temp);
$self->_add_inst('' ,'set' ,[$return,0]);
$self->_add_inst("DONE_$label");
return $return;
@@ -537,9 +820,9 @@
my $label = $self->_gensym();
$return = $self->_constant(1);
- my $temp = $self->_generate($node->{children}[0]);
+ my $temp = $self->_generate($node->{children}[1]);
$self->_add_inst('' ,'gt' ,[$temp,0,"DONE_$label"]);
- _restore($temp);
+ $self->_restore($temp);
$self->_add_inst('' ,'set' ,[$return,0]);
$self->_add_inst("DONE_$label");
return $return;
@@ -551,9 +834,9 @@
my $label = $self->_gensym();
$return = $self->_constant(1);
- my $temp = $self->_generate($node->{children}[0]);
+ my $temp = $self->_generate($node->{children}[1]);
$self->_add_inst('' ,'lt' ,[$temp,0,"DONE_$label"]);
- _restore($temp);
+ $self->_restore($temp);
$self->_add_inst('' ,'set' ,[$return,0]);
$self->_add_inst("DONE_$label");
return $return;
@@ -564,14 +847,14 @@
my $return;
my $label = $self->_gensym();
- my $temp_0 = $self->_generate($node->{children}[0]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
$return = $self->_constant(1);
my $temp_1 = $self->_constant(2);
$self->_add_inst('' ,'mod' ,[$temp_0,$temp_0,$temp_1]);
$self->_add_inst('' ,'eq' ,[$temp_0,1,"DONE_$label"]);
$self->_add_inst('' ,'set' ,[$return,0]);
$self->_add_inst("DONE_$label");
- _restore($temp_0,$temp_1);
+ $self->_restore($temp_0,$temp_1);
return $return;
}
@@ -580,14 +863,14 @@
my $return;
my $label = $self->_gensym();
- my $temp_0 = $self->_generate($node->{children}[0]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
$return = $self->_constant(1);
my $temp_1 = $self->_constant(2);
$self->_add_inst('' ,'mod' ,[$temp_0,$temp_0,$temp_1]);
$self->_add_inst('' ,'eq' ,[$temp_0,0,"DONE_$label"]);
$self->_add_inst('' ,'set' ,[$return,0]);
$self->_add_inst("DONE_$label");
- _restore($temp_0,$temp_1);
+ $self->_restore($temp_0,$temp_1);
return $return;
}
@@ -596,14 +879,14 @@
my $return;
my $label = $self->_gensym();
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
my $label = $self->_gensym();
$self->_add_inst('','gt', [$return,$temp,"NEXT_$label"]);
$self->_add_inst('','set',[$return,$temp]);
$self->_add_inst("NEXT_$label");
- _restore($temp);
+ $self->_restore($temp);
}
return $return;
}
@@ -613,14 +896,14 @@
my $return;
my $label = $self->_gensym();
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
my $label = $self->_gensym();
$self->_add_inst('','lt', [$return,$temp,"NEXT_$label"]);
$self->_add_inst('','set',[$return,$temp]);
$self->_add_inst("NEXT_$label");
- _restore($temp);
+ $self->_restore($temp);
}
return $return;
}
@@ -628,17 +911,29 @@
sub _op_plus {
my ($self,$node) = @_;
my $return;
- my $num_children = defined $node->{children} ? @{$node->{children}} : 0;
+ my $num_children = defined $node->{children} ? @{$node->{children}} - 1 : 0;
if($num_children==0) {
$return = $self->_constant(0);
} elsif($num_children==1) {
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
+ if ($return =~ /^P/) {
+ my $temp = $self->_save_1 ('P');
+ $self->_morph ($temp, $return);
+ $self->_restore ($return);
+ $return = $temp;
+ }
} else {
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ if ($return =~ /^P/) {
+ my $temp = $self->_save_1 ('P');
+ $self->_morph ($temp, $return);
+ $self->_restore ($return);
+ $return = $temp;
+ }
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
$self->_add_inst('','add',[$return,$return,$temp]);
- _restore($temp);
+ $self->_restore($temp);
}
}
return $return;
@@ -647,22 +942,34 @@
sub _op_minus {
my ($self,$node) = @_;
my $return;
- my $num_children = defined $node->{children} ? @{$node->{children}} : 0;
+ my $num_children = defined $node->{children} ? @{$node->{children}} - 1 : 0;
if($num_children==0) {
$return = $self->_constant(0);
} elsif($num_children==1) {
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
+ if ($return =~ /^P/) {
+ my $temp = $self->_save_1 ('P');
+ $self->_morph ($temp, $return);
+ $self->_restore ($return);
+ $return = $temp;
+ }
my $temp = $self->_constant(0);
$self->_add_inst('','sub',[$return,$temp,$return]);
- _restore($temp);
+ $self->_restore($temp);
} else {
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp = $self->_generate($node->{children}[$_]);
- $self->_add_inst('','sub',[$return,$return,$temp]);
- _restore($temp);
- }
+ $return = $self->_generate($node->{children}[1]);
+ if ($return =~ /^P/) {
+ my $temp = $self->_save_1 ('P');
+ $self->_morph ($temp, $return);
+ $self->_restore ($return);
+ $return = $temp;
+ }
+ for(2..$#{$node->{children}}) {
+ my $temp = $self->_generate($node->{children}[$_]);
+ $self->_add_inst('','sub',[$return,$return,$temp]);
+ $self->_restore($temp);
+ }
}
return $return;
}
@@ -670,18 +977,30 @@
sub _op_times {
my ($self,$node) = @_;
my $return;
- my $num_children = defined $node->{children} ? @{$node->{children}} : 0;
+ my $num_children = defined $node->{children} ? @{$node->{children}} - 1: 0;
if($num_children==0) {
$return = $self->_constant(0);
} elsif($num_children==1) {
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
+ if ($return =~ /^P/) {
+ my $temp = $self->_save_1 ('P');
+ $self->_morph ($temp, $return);
+ $self->_restore ($return);
+ $return = $temp;
+ }
} else {
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ if ($return =~ /^P/) {
+ my $temp = $self->_save_1 ('P');
+ $self->_morph ($temp, $return);
+ $self->_restore ($return);
+ $return = $temp;
+ }
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
$self->_add_inst('','mul',[$return,$return,$temp]);
- _restore($temp);
+ $self->_restore($temp);
}
}
return $return;
@@ -690,21 +1009,33 @@
sub _op_divide {
my ($self,$node) = @_;
my $return;
- my $num_children = defined $node->{children} ? @{$node->{children}} : 0;
+ my $num_children = defined $node->{children} ? @{$node->{children}} - 1 : 0;
if($num_children==0) {
$return = $self->_constant(0);
} elsif($num_children==1) {
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
+ if ($return =~ /^P/) {
+ my $temp = $self->_save_1 ('P');
+ $self->_morph ($temp, $return);
+ $self->_restore ($return);
+ $return = $temp;
+ }
my $temp = $self->_constant(1);
$self->_add_inst('','div',[$return,$temp,$return]);
- _restore($temp);
+ $self->_restore($temp);
} else {
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ if ($return =~ /^P/) {
+ my $temp = $self->_save_1 ('P');
+ $self->_morph ($temp, $return);
+ $self->_restore ($return);
+ $return = $temp;
+ }
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
$self->_add_inst('','div',[$return,$return,$temp]);
- _restore($temp);
+ $self->_restore($temp);
}
}
return $return;
@@ -715,11 +1046,11 @@
my $return;
my $label = $self->_gensym();
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
$self->_add_inst('', 'gt', [$return,0,"DONE_$label"]);
my $temp = $self->_constant(-1);
$self->_add_inst('', 'mul',[$return,$return,$temp]);
- _restore($temp);
+ $self->_restore($temp);
$self->_add_inst("DONE_$label");
return $return;
}
@@ -974,9 +1305,41 @@
}
sub _op_procedure_p {
+ my ($self, $node) = @_;
+ my $return;
+
+ _check_num_arg ($node, 1, 'procedure?');
+
+ $return = self->_constant(0);
+
+ my $temp = $self->_generate(_get_arg($node,1));
+ if ($temp =~ /^P/) {
+ }
+
+ return $return;
}
sub _op_apply {
+ my ($self, $node) = @_;
+ my $return;
+
+ my $func = $self->_generate(_get_arg ($node, 1));
+ my @args = _get_args ($node, 2);
+ die "apply: wrong number of args\n" unless @args;
+
+ my $argl = $self->_generate(pop @args);
+ while (@args) {
+ my $elem = $self->_generate(pop @args);
+ my $pair = _save_1('P');
+ $self->_add_inst ('','new',[$pair,'.Array']);
+ $self->_add_inst ('','set',[$pair,2]);
+ $self->_add_inst ('','set',[$pair.'[0]',$elem]);
+ $self->_add_inst ('','set',[$pair.'[1]',$argl]);
+ }
+
+ $return = $self->_call_function ('apply');
+
+ return $return;
}
sub _op_map {
@@ -1044,24 +1407,19 @@
sub _op_write {
my ($self,$node) = @_;
- for(@{$node->{children}}) {
- my $temp = $self->_generate($_);
+ my $temp = 'none';
+
+ for(_get_args($node)) {
+ $self->_restore ($temp);
+ $temp = $self->_generate($_);
if ($temp =~ /[INS]/) {
$self->_add_inst('','print',[$temp]);
}
else {
- $self->_use_function ('write');
- if ($temp ne 'P5') {
- $self->_add_inst('', 'save', ['P5']) if $regs->{P}{5};
- $self->_add_inst('', 'set', ['P5',$temp]);
- }
- $self->_add_inst('', 'bsr', ['write_ENTRY']);
- if ($temp ne 'P5' && $regs->{P}{5}) {
- $self->_add_inst('', 'restore', ['P5']);
- }
+ $self->_call_function ('write',$temp);
}
- _restore($temp);
}
+ return $temp; # We need to return something
}
sub _op_display {
@@ -1122,8 +1480,6 @@
my %global_ops = (
- 'CONSTANT' => \&_op_constant,
-
#----------------------
#
# Section 4 Expressions
@@ -1133,6 +1489,7 @@
'quote' => \&_op_quote,
'lambda' => \&_op_lambda,
'if' => \&_op_if,
+ 'define' => \&_op_define,
'set!' => \&_op_set_bang,
'cond' => \&_op_cond,
'case' => \&_op_case,
@@ -1420,11 +1777,47 @@
@max_len;
}
-sub _use_function {
- my ($self, $name) = @_;
+sub _call_function {
+ my $self = shift;
+ my $func = shift;
+
+ push @{$self->{functions}}, $func
+ unless grep { $_ eq $func } @{$self->{functions}};
+
+ my $return = $self->_save_1 ('P');
+ $self->_restore ($return); # dont need to save this
- push @{$self->{functions}}, $name
- unless grep { $_ eq $name } @{$self->{functitons}};
+ $self->_save_set;
+
+ my $count = 5;
+ my $empty = $return;
+ while (my $arg = shift) {
+ if ($arg ne "P$count") {
+ # Check if any later argument needs the old value of P$count
+ my $moved;
+ for (@_) {
+ if ($_ eq "P$count") {
+ $moved = $_;
+ $_ = $empty;
+ }
+ }
+ if ($moved) {
+ $self->_add_inst ('', 'set',[$empty,"P$count"]);
+ $empty = $moved;
+ }
+ $self->_add_inst ('','set',["P$count",$arg]);
+ }
+ $count++;
+ }
+
+ $self->_add_inst ('', 'bsr', [$func.'_ENTRY']);
+ $self->_add_inst ('', 'set', [$return,'P5']) unless $return eq 'P5';
+ $self->_restore_set;
+
+ $return =~ /(\w)(\d+)/;
+ $self->{regs}->{$1}->{$2} = 1;
+
+ return $return;
}
sub _format_columns {
@@ -1451,7 +1844,8 @@
my $tree = shift;
my $self = {
tree => $tree,
- register => [(0) x 32],
+ regs => _new_regs,
+ frames => [],
gensym => 0,
functions=> [],
};
@@ -1475,15 +1869,39 @@
my ($self,$node) = @_;
my $return;
- if($node->{value} =~ /\d/) {
- $return = $global_ops{CONSTANT}->($self,$node);
+ if (exists $node->{children}) {
+ my $func = _get_arg ($node, 0);
+ if (exists $func->{value}) {
+ my $symbol = $func->{value};
+ if (exists $global_ops{$symbol}) {
+ $return = $global_ops{$symbol}->($self, $node);
+ } else {
+# my $func_obj = $self->_save_1('P');
+# $self->_add_inst('', 'find_lex',[$func_obj,"\"$func_sym\""]);
+ my $func_obj = $self->_find_lex ($symbol);
+ my $argl = $self->_op_list ($node);
+ $return = $self->_call_function('apply', $func_obj, $argl);
+ $self->_restore ($func_obj, $argl);
+ }
+ } else {
+ my $func_obj = $self->_generate ($func);
+ my $argl = $self->_op_list ($node);
+ $return = $self->_call_function('apply', $func_obj, $argl);
+ $self->_restore ($func_obj, $argl);
+ }
} else {
- $return = $global_ops{$node->{value}}->($self,$node);
+ my $value = $node->{value};
+ if ($value =~ /^[a-zA-Z]/) {
+ $return = $self->_find_lex($value);
+ }
+ else {
+ $return = $self->_constant($node->{value});
+ }
}
- $return;
+ return $return;
}
-sub _link_buildins {
+sub _link_builtins {
my ($self) = @_;
for (@{$self->{functions}}) {
@@ -1493,12 +1911,20 @@
sub generate {
my $self = shift;
- my @temp = _save(1);
- $self->_generate($self->{tree},$temp[0]);
+ my $temp;
+
+ $self->{scope} = {};
+# $self->_add_inst ('', 'new_pad');
+ $self->_add_inst ('', 'new',['P31','.Scratchpad']);
+ $self->_add_inst ('', 'set',['P31',1]);
+
+ $temp = $self->_generate($self->{tree});
+
+# $self->_add_inst ('', 'pop_pad');
#die Dumper($self->{tree});
- _restore(@temp);
+ $self->_restore($temp);
$self->_add_inst('',"end");
- $self->_link_buildins();
+ $self->_link_builtins();
$self->_format_columns();
}
Index: languages/scheme/Scheme/Parser.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Parser.pm,v
retrieving revision 1.2
diff -u -r1.2 Parser.pm
--- languages/scheme/Scheme/Parser.pm 24 Mar 2002 23:42:38 -0000 1.2
+++ languages/scheme/Scheme/Parser.pm 23 Sep 2002 23:19:36 -0000
@@ -9,27 +9,34 @@
use Data::Dumper;
+my $ind = 0;
sub _build_tree {
my ($tokens,$count) = @_;
my $temp = {};
- $count++;
+ die "EOF reached" if $count >= $#$tokens;
- while($tokens->[$count] ne ')') {
- if($tokens->[$count] eq '(') {
- my ($lcount,$ltemp) = _build_tree($tokens,$count);
- $count = $lcount;
- push @{$temp->{children}},$ltemp;
- } else {
- if(exists $temp->{value} or exists $temp->{children}) {
- push @{$temp->{children}},{value=>$tokens->[$count]};
- } else {
- $temp->{value} = $tokens->[$count];
- }
+ if ($tokens->[$count] eq '(') {
+ $temp->{children} = [];
+ $count++;
+ while($tokens->[$count] ne ')') {
+ my $expr;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
}
$count++;
}
-
+ elsif ($tokens->[$count] eq "'") {
+ $temp = { children => [{ value => 'quote' }] };
+ my $expr;
+ $count++;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
+ }
+ else {
+ $temp->{value} = $tokens->[$count++];
+ }
+
return ($count,$temp);
}
@@ -57,9 +64,23 @@
sub parse {
my $tokens = shift;
- my (undef,$tree) = _build_tree($tokens,0);
- _dataflow($tree);
+ my @tree;
+ my $tree;
+ my $count = 0;
+
+ while ($count < scalar @$tokens) {
+ #print Dumper $tokens;
+ ($count,$tree) = _build_tree($tokens,$count);
+ #_dataflow($tree);
+ #print Data::Dumper->Dump ([$count, $tree]);
+ push @tree, $tree;
+ }
+
+ # Implicit begin at toplevel
+ if (@tree > 1) {
+ $tree = { children => [ { value => 'begin' }, @tree ] };
+ }
return $tree;
}
Index: languages/scheme/Scheme/Tokenizer.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Tokenizer.pm,v
retrieving revision 1.3
diff -u -r1.3 Tokenizer.pm
--- languages/scheme/Scheme/Tokenizer.pm 5 Sep 2002 15:03:55 -0000 1.3
+++ languages/scheme/Scheme/Tokenizer.pm 23 Sep 2002 23:19:36 -0000
@@ -18,6 +18,7 @@
open SOURCE,"<$file";
while(<SOURCE>) {
next if /^\s*;/;
+ s/;.*$//;
$text .= $_;
}
close SOURCE;
Index: languages/scheme/t/logic/defines.t
===================================================================
RCS file: languages/scheme/t/logic/defines.t
diff -N languages/scheme/t/logic/defines.t
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ languages/scheme/t/logic/defines.t 23 Sep 2002 23:19:36 -0000
@@ -0,0 +1,100 @@
+#! perl -w
+
+use Scheme::Test tests => 12;
+
+output_is (<<'CODE', 'a', 'a symbol');
+(write 'a) ; for emacs ')
+CODE
+
+output_is (<<'CODE', '5', 'define');
+(define a 5)
+(write a)
+CODE
+
+output_is (<<'CODE', '5', 'define II');
+(define a 4)
+(define b (+ a 1))
+(write b)
+CODE
+
+output_is (<<'CODE', '8', 'set!');
+(define a 5)
+(set! a 8)
+(write a)
+CODE
+
+output_is (<<'CODE', '13', 'set! II');
+(define a 5)
+(set! a (+ a 8))
+(write a)
+CODE
+
+output_is (<<'CODE', '(2 1)', 'define function');
+(define (f a b) (list b a))
+(write (f 1 2))
+CODE
+
+output_is (<<'CODE', '3', 'define via lambda');
+(define sum (lambda (a b) (+ a b)))
+(write (sum 1 2))
+CODE
+
+output_is (<<'CODE', '101', 'let');
+(let ((a 1))
+ (write a)
+ (let ((a 0)
+ (b 0))
+ (write a))
+ (write a))
+CODE
+
+output_is (<<'CODE', '321', 'counter');
+(define (make-counter val)
+ (lambda ()
+ (set! val (- val 1))
+ val)
+)
+(define counter (make-counter 4))
+(write (counter))
+(write (counter))
+(write (counter))
+CODE
+
+output_is (<<'CODE', '9837', '2 counter');
+(define (make-counter val)
+ (lambda ()
+ (set! val (- val 1))
+ val)
+)
+(define ci (make-counter 10))
+(write (ci))
+(define cii (make-counter 4))
+(write (ci))
+(write (cii))
+(write (ci))
+CODE
+
+output_is (<<'CODE', '012023', 'yet another counter');
+(define (make-counter incr)
+ (let ((val 0))
+ (lambda ()
+ (let ((ret val))
+ (set! val (+ incr val))
+ ret))))
+(define ci (make-counter 1))
+(write (ci))
+(write (ci))
+(define cii (make-counter 2))
+(write (ci))
+(write (cii))
+(write (cii))
+(write (ci))
+CODE
+
+output_is (<<'CODE','120','fakultaet');
+(define (fak n)
+ (if (= n 0)
+ 1
+ (* n (fak (- n 1)))))
+(write (fak 5))
+CODE
Index: languages/scheme/t/logic/lists.t
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/t/logic/lists.t,v
retrieving revision 1.1
diff -u -r1.1 lists.t
--- languages/scheme/t/logic/lists.t 5 Sep 2002 19:55:13 -0000 1.1
+++ languages/scheme/t/logic/lists.t 23 Sep 2002 23:19:36 -0000
@@ -1,10 +1,6 @@
#! perl -w
-use Scheme::Test tests => 15;
-
-###
-### Add
-###
+use Scheme::Test tests => 21;
output_is(<<'CODE', '(2 . 5)', 'cons');
(write (cons 2 5))
@@ -81,4 +77,32 @@
output_is(<<'CODE', '(1 4 2)', 'set-cdr!');
(write
(set-cdr! (list 1 2 3) (list 4 2)))
+CODE
+
+output_is(<<'CODE', '(1 2 3 4)', 'quoted list');
+(write '(1 2 3 4)) ; for emacs ')
+CODE
+
+output_is(<<'CODE', '1', 'null?');
+(write
+ (null? (list)))
+CODE
+
+output_is (<<'CODE', '()', "'()");
+(write '()) ; for emacs ')
+CODE
+
+output_is (<<'CODE', '0', 'failed null?');
+(write
+ (null? (list 1)))
+CODE
+
+output_is (<<'CODE', '(1 2 (3 4))', 'complex list');
+(write
+ '(1 2 (3 4))) ; for emacs ')
+CODE
+
+output_is (<<'CODE', '(1 2 (3 4))', 'complex list II');
+(write
+ (list 1 2 (list 3 4)))
CODE
