<commit_before># $Id$
# Copyright (C) 2001-2007, The Perl Foundation.

package Scheme::Generator;

# pragmata
use strict;
use warnings;
use 5.008;

use Carp;
use Data::Dumper;
use Scheme::Builtins;

our $VERSION   = '0.01';


sub _gensym {
    return sprintf "G%04d", shift->{gensym}++;
}

sub _add_inst {
    my $self = shift;

    push @{ $self->{instruction} }, [@_];

    return;
}

sub _add_comment {
    my $self    = shift;
    my $comment = shift;

    return
        $self->_add_inst( '', '#', [ $comment ] );
}

sub _new_regs {
    return {
        I => { map { $_ => 0 } ( 0 .. 31 ) },
        N => { map { $_ => 0 } ( 0 .. 31 ) },
        S => { map { $_ => 0 } ( 0 .. 31 ) },
        P => { map { $_ => 0 } ( 0 .. 31 ) },
    };
}

# save a number of registers on the stack
# Mark it only in $self->{_regs}, _save_set() emits the PIR code 
sub _save {
    my $self  = shift;
    my $count = shift;
    my $type  = shift || 'I';

    die "No registers to save"
        unless $count and $count > 0;
    die "Illegal register type"
        unless $type and $type =~ m/^[INPS]$/;
    my @temp;
    for ( 0 .. 31 ) {
        next if $self->{regs}->{$type}{$_} == 1;
        last if $count <= 0;
        push @temp, "$type$_";
        $self->{regs}->{$type}{$_} = 1;
        $count--;
    }

    return @temp;
}

sub _save_set {
    my $self = shift;

    $self->_add_comment( 'start of _save_set()' );

    my %regs = %{ $self->{regs} };
    for my $type ( keys %regs ) {
        for my $count ( 0 .. 31 ) {
            $self->_add_inst( '', 'save', ["$type$count"] )
                if $regs{$type}->{$count};
        }
    }

    $self->_add_comment( 'end of _save_set()' );

    return;
}

# save a single register on the stack
sub _save_1 {
    my $self = shift;
    my $type = shift || 'I';

    my @temp = $self->_save( 1, $type );

    return $temp[0];
}

# say that a register should not be saved by _save_set()
sub _restore {
    my $self = shift;

    # die "Nothing to restore" unless @_;

    foreach my $reg (@_) {
        next if grep { $_ eq $reg } qw (none);

        my ( $reg_type, $reg_num ) = $reg =~ m/^(\w)(\d+)/;
        die 'Missing register type'
            unless defined $reg_type;
        if ( $self->{regs}->{$reg_type}{$reg_num} ) {
            $self->{regs}->{$reg_type}{$reg_num} = 0;
        }
    }

    return;
}

sub _restore_set {
    my $self = shift;

    my %regs = %{ $self->{regs} };

    $self->_add_comment( 'start of _restore_set()' );
    for my $type ( reverse keys %regs ) {
        for ( my $count = 31 ; $count >= 0 ; $count-- ) {
            $self->_add_inst( '', 'restore', [ "$type$count" ] )
                if $regs{$type}->{$count};
        }
    }
    $self->_add_comment( 'end of _restore_set()' );

    return;
}

sub _check_num_args {
    my ( $node, $expected, $name ) = @_;

    my $num_args = _get_num_args( $node );

    if ( my ( $min ) = $expected =~ m/ \A \s* >= \s* (\d+) /xms ) {
        my $plural = $min == 1 ? q{} : 's';
        confess "$name: expects at least $min argument$plural, given $num_args\n"
            unless $num_args >= $min;
    }
    else {
        confess "$name: Wrong number of arguments (expected $expected, got $num_args).\n"
            unless $num_args == $expected;
    }
}

sub _get_num_args {
    my ( $node ) = @_;

    return 
        defined $node->{children} ? @{ $node->{children} } - 1 : 0;
}

sub _get_arg {
    my ( $node, $num ) = @_;

    return $node->{children}->[$num];
}

# first child is the function, the args are after that
sub _get_args {
    my ( $node, $num ) = @_;
    $num = 1 unless defined $num;

    return splice @{ $node->{children} }, $num;
}

# until there is a working find_lex/store_lex
sub _find_lex {
    my ( $self, $symbol ) = @_;

    my $return_reg = $self->_save_1('P');
    $self->_add_inst( '', 'find_lex', [ $return_reg, qq{"$symbol"} ] );

    return $return_reg;
}

sub _find_name {
    my ( $self, $symbol ) = @_;

    my $return = $self->_save_1('P');
    $self->_add_inst( '', 'find_name', [ $return, qq{"$symbol"} ] );

    return $return;
}

sub _store_lex {
    my ( $self, $symbol, $value ) = @_;

    return $self->_add_inst( '', 'store_lex', [ qq{"$symbol"}, $value ] );
}

sub _new_lex {
    my ( $self, $symbol, $value ) = @_;

    $self->_add_comment( 'start of _new_lex' );

    $self->_add_inst( '', 'store_lex', [ qq{"$symbol"}, $value ] );
    $self->{scope}->{$symbol} = $value;

    $self->_add_comment( 'end of _new_lex' );

    return;
}

sub _new_pair {
    my ($self) = @_;

    my $return = $self->_save_1('P');

    $self->_add_inst( '', 'new', [ $return, q{'Array'} ] );
    $self->_add_inst( '', 'set', [ $return, 2 ] );

    return $return;
}

my $type_map = {
    INTEGER  => [ 1, 'I' ],
    RATIONAL => [ 2, 'I' ],
    REAL     => [ 1, 'N' ],
    COMPLEX  => [ 2, 'I' ],
    STRING   => [ 1, 'S' ],
};

sub _constant {
    my ( $self, $value ) = @_;

    $self->_add_comment( 'start of _constant' );
    my ( $reg_type );

    if ( $value =~ m/ \A [-+]?\d+ \z /xms ) {                                        # an integer
        $reg_type = 'I';
    }
    elsif ( $value =~ m/ \A [-+]?((\d+\.\d*) | (\.d+)) ([eE][-+]?\d+)? \z/xms ) {    # a float
        $reg_type = 'N';
    }
    elsif ( $value =~ m/ \A " [^"]* " \z/xms ) {                                     # a string, not escapes yet
        $reg_type = 'S';
    }
    elsif ( $value eq '#t' || $value eq '#f' ) {
        my $return = $self->_save_1( 'P' );
        $self->_add_inst( '', 'new', [ $return, q{'Boolean'} ] );
        $self->_add_inst( '', 'set', [ $return, $value eq '#t' ? '1' : '0' ] );
        $self->_add_comment( 'end of _constant' );

        return $return;
    }
    else {                                                                           # default 0
        $reg_type = 'I';
        $value = 0;
    }
    
    my $return = $self->_save_1( $reg_type );
    $self->_add_inst( '', 'set', [ $return, $value ] );

    $self->_add_comment( 'end of _constant' );

    return $return;
}

sub _morph {
    my ( $self, $to, $from ) = @_;

    $self->_add_comment( 'start of _morph' );

    if ( $to =~ /P/ ) {
        if ( $from =~ /P/ ) {
            $self->_add_inst( '', 'clone', [ $to, $from ] );
        }
        elsif ( $from =~ /I/ ) {
            $self->_add_inst( '', 'new', [ $to, q{'Integer'} ] );
            $self->_add_inst( '', 'set', [ $to, $from ] );
        }
        elsif ( $from =~ /N/ ) {
            $self->_add_inst( '', 'new', [ $to, q{'Float'} ] );
            $self->_add_inst( '', 'set', [ $to, $from ] );
        }
    }

    $self->_add_comment( 'end of _morph' );

    return;
}

#---- Section 4 ----

sub __quoted {
    my ( $self, $node, $return, $special ) = @_;

    if ( exists $node->{value} ) {
        my $value = $node->{value};
        if ( $value =~ /^[-+]?\d+$/ ) {
            $self->_add_inst( '', 'new', [ $return, q{'Integer'} ] );
            $self->_add_inst( '', 'set', [ $return, $value ] );
        }
        elsif ( $value =~ /^[-+]?((\d+\.\d*)|(\.d+))([eE][-+]?\d+)?$/ ) {
            $self->_add_inst( '', 'new', [ $return, q{'Float'} ] );
            $self->_add_inst( '', 'set', [ $return, $value ] );
        }
        else {    # assume its a symbol
            $self->_add_inst( '', 'new', [ $return, q{'String'} ] );
            $self->_add_inst( '', 'set', [ $return, "\"$value\"" ] );
        }
    }
    elsif ( exists $node->{children} ) {
        my $children = $node->{children};

        $self->_add_inst( '', 'new', [ $return, q{'Undef'} ] );
        for ( reverse @$children ) {
            if ( exists $_->{children} ) {
                my $arg0 = _get_arg( $_, 0 );
                if ( exists $arg0->{value} ) {
                    my $value = $arg0->{value};
                    if ( exists $special->{$value} ) {
                        _check_num_args( $_, 1 );
                        $special->{$value}->( $self, _get_arg( $_, 1 ), $return );
                        next;
                    }
                }
            }
            my $item = $self->_save_1('P');

            __quoted( $self, $_, $item, $special );

            my $pair = $self->_new_pair();

            $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 = $self->_save_1('P');

    _check_num_args( $node, 1, 'quote' );

    my $item = _get_arg( $node, 1 );

    return __quoted( $self, $item, $return, {} );
}

sub _op_quasiquote {
    my ( $self, $node ) = @_;

    my $return  = $self->_save_1('P');
    my $special = {
        unquote            => \&_qq_unquote,
        'unquote-splicing' => \&_qq_unquote_splicing
    };

    _check_num_args( $node, 1, 'quote' );

    my $item = _get_arg( $node, 1 );

    return __quoted( $self, $item, $return, $special );
}

# helper functions for quasiquote

sub _qq_unquote {
    my ( $self, $node, $return ) = @_;

    my $item = $self->_generate($node);

    if ( $item =~ /^[INS]/ ) {
        my $temp = $self->_save_1('P');
        $self->_morph( $temp, $item );
        $self->_restore($item);
        $item = $temp;
    }
    my $pair = $self->_new_pair();
    $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 _qq_unquote_splicing {
    my ( $self, $node, $return ) = @_;

    my $list = $self->_generate($node);

    die "unquote-splicing called on no list" if ( $list =~ /^[INS]/ );

    my $type  = $self->_save_1('S');
    my $head  = $self->_save_1('P');
    my $label = $self->_gensym;

    # check for empty list
    $self->_add_inst( '', 'typeof', [ $type, $list ] );
    $self->_add_inst( '', 'eq', [ $type, q{'Undef'}, "DONE_$label" ] );

    my $copy = $self->_new_pair();

    $self->_add_inst( '', 'set', [ $head, $copy ] );

    # maybe ensure that $type is a pair here
    my $temp = $self->_save_1('P');
    $self->_add_inst( "ITER_$label", 'set', [ $temp, $list . '[0]' ] );
    $self->_add_inst( '', 'set', [ $copy . '[0]', $temp ] );
    $self->_restore($temp);

    $self->_add_inst( '', 'set',    [ $list, $list . '[1]' ] );
    $self->_add_inst( '', 'typeof', [ $type, $list ] );
    $self->_add_inst( '', 'eq',     [ $type, q{'Undef'}, "FINISH_$label" ] );

    $temp = $self->_new_pair();
    $self->_add_inst( '', 'set', [ $copy . '[1]', $temp ] );
    $self->_add_inst( '', 'set', [ $copy, $temp ] );
    $self->_add_inst( '', 'branch', ["ITER_$label"] );
    $self->_restore($temp);

    # append the rest to the end of list
    $self->_add_inst( "FINISH_$label", 'set', [ $copy . '[1]', $return ] );
    $self->_add_inst( '', 'set', [ $return, $head ] );
    $self->_add_inst("DONE_$label");

    $self->_restore( $list, $copy, $head, $type );

    return $return;
}

sub _op_lambda {
    my ( $self, $node ) = @_;

    $self->_add_comment( 'start of _op_lambda()' );

    my $sub_name
        = join( q{_}, 'LAMBDA', $self->_gensym() );

    my $sub_reg = $self->_save_1('P');
    my $return = $self->_save_1('P');

    $self->_add_inst( '', '.const', [ qq{.Sub $sub_reg = "$sub_name"} ] );
    $self->_add_inst( '', 'newclosure', [ $return, $sub_reg ] );

    # caller saved => start a new frame
    push @{ $self->{frames} }, $self->{regs};
    $self->{regs} = _new_regs;

    # expand the lexical scope
    my $oldscope = $self->{scope};
    $self->{scope} = { '*UP*' => $oldscope };

    # lambda body
    # Another ugly hack. Move the generated code to 'lambda_instructions'
    $self->_add_comment( "start: body of lambda is in $sub_name" );
    my $ins_count = scalar @{ $self->{instruction} };
    $self->_add_inst( '', '' );

    $self->_add_comment( 'generated for lambda' );
    my $outer = $self->{outer}->[-1];
    $self->_add_inst( '', '.sub', [ qq{$sub_name :outer('$outer') :lex} ] );
    push @{ $self->{outer} }, $sub_name;

    # loop over parameters
    my $cnt = 0;
    my @store_lex;
    for ( @{ _get_arg( $node, 1 )->{children} } ) {
        my $param_name = "param_$cnt";
        $self->_add_inst( '', '.param pmc', [ $param_name ] );
        push @store_lex, [ '', '.lex', [ qq{"$_->{value}"}, $param_name ]]; 
        $cnt++;
    }
    foreach ( @store_lex ) {
        $self->_add_inst( @{$_} );
    }
  
    # generate code for the body
    my $temp = 'none';
    for ( _get_args( $node, 2 ) ) {
        $self->_restore($temp);
        $temp = $self->_generate($_);
    }

    $self->_add_inst( '', 'set_returns', [ q{"0"}, $temp ] );

    $self->_add_inst( '', '.end' );
    unshift @{ $self->{lambda_instructions} }, splice @{ $self->{instruction} }, $ins_count;
    $self->_add_comment( "end:   body of lambda is in $sub_name" );

    $self->{regs}  = pop @{ $self->{frames} };
    $self->{scope} = $self->{scope}->{'*UP*'};
    pop @{ $self->{outer} };

    $self->_add_comment( 'end of _op_lambda()' );

    return $return;
}

sub _op_if {
    my ( $self, $node ) = @_;

    my $return;
    my $label = $self->_gensym();

    my $cond = $self->_generate( _get_arg( $node, 1 ) );
    $self->_add_inst( '', 'eq', [ $cond, 0, "FALSE_$label" ] );
    $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");
    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 ) = @_;

    $self->_add_comment( 'start of _op_define()' );

    _check_num_args( $node, 2, 'define' );

    my ( $symbol, $lambda );

    if ( exists _get_arg( $node, 1 )->{children} ) {
        ( $symbol, my @formals ) = @{ _get_arg( $node, 1 )->{children} };
        $symbol = $symbol->{value};
        $lambda =
            { children =>
                [ { value => 'lambda' }, { children => [@formals] }, _get_args( $node, 2 ) ] };
    }
    else {
        $symbol = _get_arg( $node, 1 )->{value};
        $lambda = _get_arg( $node, 2 );
    }

    if ( exists $self->{scope}->{$symbol} ) {
        die "define: $symbol is already defined\n";
    }
    else {
        $self->{scope}->{$symbol} = '*unknown*';
    }

    my $value = $self->_generate($lambda);

    if ( $value !~ m/^P/ ) {
        my $pmc = $self->_save_1('P');
        $self->_morph( $pmc, $value );
        $self->_restore($value);
        $value = $pmc;
    }

    $self->_new_lex( $symbol, $value );

    $self->_add_comment( 'end of _op_define()' );

    return $value;
}

sub _op_set_bang {
    my ( $self, $node ) = @_;

    _check_num_args( $node, 2, 'set!' );

    my $symbol = _get_arg( $node, 1 )->{value};
    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->_store_lex( $symbol, $temp );

    return $temp;
}

sub _op_cond {
    my ( $self, $node ) = @_;

    my @clauses = _get_args($node);

    my $transnode;

    if ( $clauses[-1]->{children}->[0]->{value} eq 'else' ) {
        my $elseclause = pop @clauses;
        $transnode = { children => [ { value => 'begin' }, _get_args($elseclause) ] };
    }
    else {
        $transnode = { value => '#f' };
    }

    for my $clause ( reverse @clauses ) {
        $transnode = {
            children => [
                { value => 'if' },
                _get_arg( $clause, 0 ),
                { children => [ { value => 'begin' }, _get_args( $clause, 1 ) ] }, $transnode
            ]
        };
    }

    return $self->_generate($transnode);
}

sub _op_case {
}

sub _op_and {
    my ( $self, $node ) = @_;

    my $return;
    my $label = $self->_gensym();

    $return = $self->_constant(0);
    for ( _get_args($node) ) {
        my $temp = $self->_generate($_);
        $self->_add_inst( '', 'eq', [ $temp, 0, "DONE_$label" ] );
        $self->_restore($temp);
    }
    $self->_add_inst( '', 'set', [ $return, 1 ] );
    $self->_add_inst("DONE_$label");

    return $return;
}

sub _op_or {
    my ( $self, $node ) = @_;

    my $return;
    my $label = $self->_gensym();

    $return = $self->_constant(1);
    for ( _get_args($node) ) {
        my $temp = $self->_generate($_);
        $self->_add_inst( '', 'eq', [ $temp, 1, "DONE_$label" ] );
        $self->_restore($temp);
    }
    $self->_add_inst( '', 'set', [ $return, 0 ] );
    $self->_add_inst("DONE_$label");

    return $return;
}

sub _op_let {
    my ( $self, $node ) = @_;

    $self->_add_comment( 'start of _op_let()' );<commit_msg>[Scheme] Fiddle with 'and', return '#f' or the last argument.<commit_after># $Id$
# Copyright (C) 2001-2007, The Perl Foundation.

package Scheme::Generator;

# pragmata
use strict;
use warnings;
use 5.008;

use Carp;
use Data::Dumper;
use Scheme::Builtins;

our $VERSION   = '0.01';


sub _gensym {
    return sprintf "G%04d", shift->{gensym}++;
}

sub _add_inst {
    my $self = shift;

    push @{ $self->{instruction} }, [@_];

    return;
}

sub _add_comment {
    my $self    = shift;
    my $comment = shift;

    return
        $self->_add_inst( '', '#', [ $comment ] );
}

sub _new_regs {
    return {
        I => { map { $_ => 0 } ( 0 .. 31 ) },
        N => { map { $_ => 0 } ( 0 .. 31 ) },
        S => { map { $_ => 0 } ( 0 .. 31 ) },
        P => { map { $_ => 0 } ( 0 .. 31 ) },
    };
}

# save a number of registers on the stack
# Mark it only in $self->{_regs}, _save_set() emits the PIR code 
sub _save {
    my $self  = shift;
    my $count = shift;
    my $type  = shift || 'I';

    die "No registers to save"
        unless $count and $count > 0;
    die "Illegal register type"
        unless $type and $type =~ m/^[INPS]$/;
    my @temp;
    for ( 0 .. 31 ) {
        next if $self->{regs}->{$type}{$_} == 1;
        last if $count <= 0;
        push @temp, "$type$_";
        $self->{regs}->{$type}{$_} = 1;
        $count--;
    }

    return @temp;
}

sub _save_set {
    my $self = shift;

    $self->_add_comment( 'start of _save_set()' );

    my %regs = %{ $self->{regs} };
    for my $type ( keys %regs ) {
        for my $count ( 0 .. 31 ) {
            $self->_add_inst( '', 'save', ["$type$count"] )
                if $regs{$type}->{$count};
        }
    }

    $self->_add_comment( 'end of _save_set()' );

    return;
}

# save a single register on the stack
sub _save_1 {
    my $self = shift;
    my $type = shift || 'I';

    my @temp = $self->_save( 1, $type );

    return $temp[0];
}

# say that a register should not be saved by _save_set()
sub _restore {
    my $self = shift;

    # die "Nothing to restore" unless @_;

    foreach my $reg (@_) {
        next if grep { $_ eq $reg } qw (none);

        my ( $reg_type, $reg_num ) = $reg =~ m/^(\w)(\d+)/;
        die 'Missing register type'
            unless defined $reg_type;
        if ( $self->{regs}->{$reg_type}{$reg_num} ) {
            $self->{regs}->{$reg_type}{$reg_num} = 0;
        }
    }

    return;
}

sub _restore_set {
    my $self = shift;

    my %regs = %{ $self->{regs} };

    $self->_add_comment( 'start of _restore_set()' );
    for my $type ( reverse keys %regs ) {
        for ( my $count = 31 ; $count >= 0 ; $count-- ) {
            $self->_add_inst( '', 'restore', [ "$type$count" ] )
                if $regs{$type}->{$count};
        }
    }
    $self->_add_comment( 'end of _restore_set()' );

    return;
}

sub _check_num_args {
    my ( $node, $expected, $name ) = @_;

    my $num_args = _get_num_args( $node );

    if ( my ( $min ) = $expected =~ m/ \A \s* >= \s* (\d+) /xms ) {
        my $plural = $min == 1 ? q{} : 's';
        confess "$name: expects at least $min argument$plural, given $num_args\n"
            unless $num_args >= $min;
    }
    else {
        confess "$name: Wrong number of arguments (expected $expected, got $num_args).\n"
            unless $num_args == $expected;
    }
}

sub _get_num_args {
    my ( $node ) = @_;

    return 
        defined $node->{children} ? @{ $node->{children} } - 1 : 0;
}

sub _get_arg {
    my ( $node, $num ) = @_;

    return $node->{children}->[$num];
}

# first child is the function, the args are after that
sub _get_args {
    my ( $node, $num ) = @_;
    $num = 1 unless defined $num;

    return splice @{ $node->{children} }, $num;
}

# until there is a working find_lex/store_lex
sub _find_lex {
    my ( $self, $symbol ) = @_;

    my $return_reg = $self->_save_1('P');
    $self->_add_inst( '', 'find_lex', [ $return_reg, qq{"$symbol"} ] );

    return $return_reg;
}

sub _find_name {
    my ( $self, $symbol ) = @_;

    my $return = $self->_save_1('P');
    $self->_add_inst( '', 'find_name', [ $return, qq{"$symbol"} ] );

    return $return;
}

sub _store_lex {
    my ( $self, $symbol, $value ) = @_;

    return $self->_add_inst( '', 'store_lex', [ qq{"$symbol"}, $value ] );
}

sub _new_lex {
    my ( $self, $symbol, $value ) = @_;

    $self->_add_comment( 'start of _new_lex' );

    $self->_add_inst( '', 'store_lex', [ qq{"$symbol"}, $value ] );
    $self->{scope}->{$symbol} = $value;

    $self->_add_comment( 'end of _new_lex' );

    return;
}

sub _new_pair {
    my ($self) = @_;

    my $return = $self->_save_1('P');

    $self->_add_inst( '', 'new', [ $return, q{'Array'} ] );
    $self->_add_inst( '', 'set', [ $return, 2 ] );

    return $return;
}

my $type_map = {
    INTEGER  => [ 1, 'I' ],
    RATIONAL => [ 2, 'I' ],
    REAL     => [ 1, 'N' ],
    COMPLEX  => [ 2, 'I' ],
    STRING   => [ 1, 'S' ],
};

sub _constant {
    my ( $self, $value ) = @_;

    $self->_add_comment( 'start of _constant' );
    my ( $reg_type );

    if ( $value =~ m/ \A [-+]?\d+ \z /xms ) {                                        # an integer
        $reg_type = 'I';
    }
    elsif ( $value =~ m/ \A [-+]?((\d+\.\d*) | (\.d+)) ([eE][-+]?\d+)? \z/xms ) {    # a float
        $reg_type = 'N';
    }
    elsif ( $value =~ m/ \A " [^"]* " \z/xms ) {                                     # a string, not escapes yet
        $reg_type = 'S';
    }
    elsif ( $value eq '#t' || $value eq '#f' ) {
        my $return = $self->_save_1( 'P' );
        $self->_add_inst( '', 'new', [ $return, q{'Boolean'} ] );
        $self->_add_inst( '', 'set', [ $return, $value eq '#t' ? '1' : '0' ] );
        $self->_add_comment( 'end of _constant' );

        return $return;
    }
    else {                                                                           # default 0
        $reg_type = 'I';
        $value = 0;
    }
    
    my $return = $self->_save_1( $reg_type );
    $self->_add_inst( '', 'set', [ $return, $value ] );

    $self->_add_comment( 'end of _constant' );

    return $return;
}

sub _morph {
    my ( $self, $to, $from ) = @_;

    $self->_add_comment( 'start of _morph' );

    if ( $to =~ /P/ ) {
        if ( $from =~ /P/ ) {
            $self->_add_inst( '', 'clone', [ $to, $from ] );
        }
        elsif ( $from =~ /I/ ) {
            $self->_add_inst( '', 'new', [ $to, q{'Integer'} ] );
            $self->_add_inst( '', 'set', [ $to, $from ] );
        }
        elsif ( $from =~ /N/ ) {
            $self->_add_inst( '', 'new', [ $to, q{'Float'} ] );
            $self->_add_inst( '', 'set', [ $to, $from ] );
        }
    }

    $self->_add_comment( 'end of _morph' );

    return;
}

#---- Section 4 ----

sub __quoted {
    my ( $self, $node, $return, $special ) = @_;

    if ( exists $node->{value} ) {
        my $value = $node->{value};
        if ( $value =~ /^[-+]?\d+$/ ) {
            $self->_add_inst( '', 'new', [ $return, q{'Integer'} ] );
            $self->_add_inst( '', 'set', [ $return, $value ] );
        }
        elsif ( $value =~ /^[-+]?((\d+\.\d*)|(\.d+))([eE][-+]?\d+)?$/ ) {
            $self->_add_inst( '', 'new', [ $return, q{'Float'} ] );
            $self->_add_inst( '', 'set', [ $return, $value ] );
        }
        else {    # assume its a symbol
            $self->_add_inst( '', 'new', [ $return, q{'String'} ] );
            $self->_add_inst( '', 'set', [ $return, "\"$value\"" ] );
        }
    }
    elsif ( exists $node->{children} ) {
        my $children = $node->{children};

        $self->_add_inst( '', 'new', [ $return, q{'Undef'} ] );
        for ( reverse @$children ) {
            if ( exists $_->{children} ) {
                my $arg0 = _get_arg( $_, 0 );
                if ( exists $arg0->{value} ) {
                    my $value = $arg0->{value};
                    if ( exists $special->{$value} ) {
                        _check_num_args( $_, 1 );
                        $special->{$value}->( $self, _get_arg( $_, 1 ), $return );
                        next;
                    }
                }
            }
            my $item = $self->_save_1('P');

            __quoted( $self, $_, $item, $special );

            my $pair = $self->_new_pair();

            $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 = $self->_save_1('P');

    _check_num_args( $node, 1, 'quote' );

    my $item = _get_arg( $node, 1 );

    return __quoted( $self, $item, $return, {} );
}

sub _op_quasiquote {
    my ( $self, $node ) = @_;

    my $return  = $self->_save_1('P');
    my $special = {
        unquote            => \&_qq_unquote,
        'unquote-splicing' => \&_qq_unquote_splicing
    };

    _check_num_args( $node, 1, 'quote' );

    my $item = _get_arg( $node, 1 );

    return __quoted( $self, $item, $return, $special );
}

# helper functions for quasiquote

sub _qq_unquote {
    my ( $self, $node, $return ) = @_;

    my $item = $self->_generate($node);

    if ( $item =~ /^[INS]/ ) {
        my $temp = $self->_save_1('P');
        $self->_morph( $temp, $item );
        $self->_restore($item);
        $item = $temp;
    }
    my $pair = $self->_new_pair();
    $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 _qq_unquote_splicing {
    my ( $self, $node, $return ) = @_;

    my $list = $self->_generate($node);

    die "unquote-splicing called on no list" if ( $list =~ /^[INS]/ );

    my $type  = $self->_save_1('S');
    my $head  = $self->_save_1('P');
    my $label = $self->_gensym;

    # check for empty list
    $self->_add_inst( '', 'typeof', [ $type, $list ] );
    $self->_add_inst( '', 'eq', [ $type, q{'Undef'}, "DONE_$label" ] );

    my $copy = $self->_new_pair();

    $self->_add_inst( '', 'set', [ $head, $copy ] );

    # maybe ensure that $type is a pair here
    my $temp = $self->_save_1('P');
    $self->_add_inst( "ITER_$label", 'set', [ $temp, $list . '[0]' ] );
    $self->_add_inst( '', 'set', [ $copy . '[0]', $temp ] );
    $self->_restore($temp);

    $self->_add_inst( '', 'set',    [ $list, $list . '[1]' ] );
    $self->_add_inst( '', 'typeof', [ $type, $list ] );
    $self->_add_inst( '', 'eq',     [ $type, q{'Undef'}, "FINISH_$label" ] );

    $temp = $self->_new_pair();
    $self->_add_inst( '', 'set', [ $copy . '[1]', $temp ] );
    $self->_add_inst( '', 'set', [ $copy, $temp ] );
    $self->_add_inst( '', 'branch', ["ITER_$label"] );
    $self->_restore($temp);

    # append the rest to the end of list
    $self->_add_inst( "FINISH_$label", 'set', [ $copy . '[1]', $return ] );
    $self->_add_inst( '', 'set', [ $return, $head ] );
    $self->_add_inst("DONE_$label");

    $self->_restore( $list, $copy, $head, $type );

    return $return;
}

sub _op_lambda {
    my ( $self, $node ) = @_;

    $self->_add_comment( 'start of _op_lambda()' );

    my $sub_name
        = join( q{_}, 'LAMBDA', $self->_gensym() );

    my $sub_reg = $self->_save_1('P');
    my $return = $self->_save_1('P');

    $self->_add_inst( '', '.const', [ qq{.Sub $sub_reg = "$sub_name"} ] );
    $self->_add_inst( '', 'newclosure', [ $return, $sub_reg ] );

    # caller saved => start a new frame
    push @{ $self->{frames} }, $self->{regs};
    $self->{regs} = _new_regs;

    # expand the lexical scope
    my $oldscope = $self->{scope};
    $self->{scope} = { '*UP*' => $oldscope };

    # lambda body
    # Another ugly hack. Move the generated code to 'lambda_instructions'
    $self->_add_comment( "start: body of lambda is in $sub_name" );
    my $ins_count = scalar @{ $self->{instruction} };
    $self->_add_inst( '', '' );

    $self->_add_comment( 'generated for lambda' );
    my $outer = $self->{outer}->[-1];
    $self->_add_inst( '', '.sub', [ qq{$sub_name :outer('$outer') :lex} ] );
    push @{ $self->{outer} }, $sub_name;

    # loop over parameters
    my $cnt = 0;
    my @store_lex;
    for ( @{ _get_arg( $node, 1 )->{children} } ) {
        my $param_name = "param_$cnt";
        $self->_add_inst( '', '.param pmc', [ $param_name ] );
        push @store_lex, [ '', '.lex', [ qq{"$_->{value}"}, $param_name ]]; 
        $cnt++;
    }
    foreach ( @store_lex ) {
        $self->_add_inst( @{$_} );
    }
  
    # generate code for the body
    my $temp = 'none';
    for ( _get_args( $node, 2 ) ) {
        $self->_restore($temp);
        $temp = $self->_generate($_);
    }

    $self->_add_inst( '', 'set_returns', [ q{"0"}, $temp ] );

    $self->_add_inst( '', '.end' );
    unshift @{ $self->{lambda_instructions} }, splice @{ $self->{instruction} }, $ins_count;
    $self->_add_comment( "end:   body of lambda is in $sub_name" );

    $self->{regs}  = pop @{ $self->{frames} };
    $self->{scope} = $self->{scope}->{'*UP*'};
    pop @{ $self->{outer} };

    $self->_add_comment( 'end of _op_lambda()' );

    return $return;
}

sub _op_if {
    my ( $self, $node ) = @_;

    my $return;
    my $label = $self->_gensym();

    my $cond = $self->_generate( _get_arg( $node, 1 ) );
    $self->_add_inst( '', 'eq', [ $cond, 0, "FALSE_$label" ] );
    $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");
    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 ) = @_;

    $self->_add_comment( 'start of _op_define()' );

    _check_num_args( $node, 2, 'define' );

    my ( $symbol, $lambda );

    if ( exists _get_arg( $node, 1 )->{children} ) {
        ( $symbol, my @formals ) = @{ _get_arg( $node, 1 )->{children} };
        $symbol = $symbol->{value};
        $lambda =
            { children =>
                [ { value => 'lambda' }, { children => [@formals] }, _get_args( $node, 2 ) ] };
    }
    else {
        $symbol = _get_arg( $node, 1 )->{value};
        $lambda = _get_arg( $node, 2 );
    }

    if ( exists $self->{scope}->{$symbol} ) {
        die "define: $symbol is already defined\n";
    }
    else {
        $self->{scope}->{$symbol} = '*unknown*';
    }

    my $value = $self->_generate($lambda);

    if ( $value !~ m/^P/ ) {
        my $pmc = $self->_save_1('P');
        $self->_morph( $pmc, $value );
        $self->_restore($value);
        $value = $pmc;
    }

    $self->_new_lex( $symbol, $value );

    $self->_add_comment( 'end of _op_define()' );

    return $value;
}

sub _op_set_bang {
    my ( $self, $node ) = @_;

    _check_num_args( $node, 2, 'set!' );

    my $symbol = _get_arg( $node, 1 )->{value};
    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->_store_lex( $symbol, $temp );

    return $temp;
}

sub _op_cond {
    my ( $self, $node ) = @_;

    my @clauses = _get_args($node);

    my $transnode;

    if ( $clauses[-1]->{children}->[0]->{value} eq 'else' ) {
        my $elseclause = pop @clauses;
        $transnode = { children => [ { value => 'begin' }, _get_args($elseclause) ] };
    }
    else {
        $transnode = { value => '#f' };
    }

    for my $clause ( reverse @clauses ) {
        $transnode = {
            children => [
                { value => 'if' },
                _get_arg( $clause, 0 ),
                { children => [ { value => 'begin' }, _get_args( $clause, 1 ) ] }, $transnode
            ]
        };
    }

    return $self->_generate($transnode);
}

sub _op_case {
}

sub _op_and {
    my ( $self, $node ) = @_;

    my $label = $self->_gensym();

    my $temp;
    my $return = $self->_save_1('P');
    for ( _get_args($node) ) {
        $temp = $self->_generate($_);
        # only '#f', therfore only Boolean PMCs, therefore only PMCs can be false
        if ( $temp =~ m/ \A P /xms )       
        {
            my $tmp_s = $self->_save_1('S');
            $self->_add_inst( '',            'typeof', [ $tmp_s, $temp ] );
            $self->_restore($tmp_s);
            $self->_add_inst( '',            'ne',     [ $tmp_s, q{'Boolean'}, "NOT_YET_DONE_$label" ] );
            $self->_add_inst( '', "unless $temp goto FALSE_$label" );
            $self->_add_inst("NOT_YET_DONE_$label");
        }
    }
    $self->_add_inst( '', 'new', [ $return, q{'Undef'} ] );
    $self->_add_inst( '', 'set', [ $return, $temp ] );
    $self->_add_inst( '', 'branch', [ "TRUE_$label" ] );
    $self->_add_inst("FALSE_$label");
    $self->_add_inst( '', 'new', [ $return, q{'Boolean'} ] );
    $self->_add_inst( '', 'set', [ $return, 0 ] );
    $self->_add_inst("TRUE_$label");

    return $return;
}

sub _op_or {
    my ( $self, $node ) = @_;

    my $return;
    my $label = $self->_gensym();

    $return = $self->_constant(1);
    for ( _get_args($node) ) {
        my $temp = $self->_generate($_);
        $self->_add_inst( '', 'eq', [ $temp, 1, "DONE_$label" ] );
        $self->_restore($temp);
    }
    $self->_add_inst( '', 'set', [ $return, 0 ] );
    $self->_add_inst("DONE_$label");

    return $return;
}

sub _op_let {
    my ( $self, $node ) = @_;

    $self->_add_comment( 'start of _op_let()' );
{'fraction_non_alphanumeric': 0.21914163090128755, 'fraction_numerical': 0.007381974248927039, 'mean_word_length': 2.101792687255946, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 484, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 14, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7045809', 'n_tokens_mistral': 13294, 'n_tokens_neox': 12782, 'n_words': 2888}