PScm-0.1.4/0000755000076500007650000000000011000456160012247 5ustar billbill00000000000000PScm-0.1.4/ABSTRACT0000644000076500007650000000012610737002401013375 0ustar billbill00000000000000=head1 ABSTRACT PScm - a toy scheme-like interpreter written entirely in Perl. =cut PScm-0.1.4/Changes0000644000076500007650000000062110727330146013553 0ustar billbill00000000000000Revision history for Perl extension PScm. 0.0.4 Sat Oct 8 13:17:53 BST 2005 - added let* 0.0.3 Sat Oct 8 12:36:50 BST 2005 - added letrec 0.0.2 Sat Oct 8 10:32:44 BST 2005 - added lambda and closure 0.0.1 Sat Oct 8 09:13:21 BST 2005 - Added 'let' and extended the Env 0.0.0 Sat Oct 15 09:59:18 BST 2005 - Simplest working form: '-', '*' and 'if' PScm-0.1.4/lib/0000755000076500007650000000000011000456160013015 5ustar billbill00000000000000PScm-0.1.4/lib/PScm/0000755000076500007650000000000011000456160013657 5ustar billbill00000000000000PScm-0.1.4/lib/PScm/Closure.pm0000644000076500007650000000203610763466214015652 0ustar billbill00000000000000package PScm::Closure; use strict; use warnings; use base qw(PScm); sub new { my ($class, $args, $body, $env) = @_; bless { args => $args, body => $body, env => $env, }, $class; } sub args { $_[0]->{args}->value } sub body { $_[0]->{body} } sub env { $_[0]->{env} } sub _apply { my ($self, $ra_args, $cont) = @_; my $extended_env = $self->env->ExtendUnevaluated([$self->args], $ra_args); $self->body->Eval($extended_env, $cont); } sub as_string { my ($self) = @_; return PScm::Expr::List->new( $self->_symbol, $self->{args}, $self->{body} )->as_string; } ################################ package PScm::Closure::Function; use base qw(PScm::Closure); use PScm::Continuation; sub Apply { my ($self, $form, $env, $cont) = @_; $form->map_eval( $env, cont { my ($ra_evaluated_args) = @_; $self->_apply($ra_evaluated_args, $cont); } ); } sub _symbol { PScm::Expr::Symbol->new('lambda'); } 1; PScm-0.1.4/lib/PScm/Continuation.pm0000644000076500007650000000134110763466214016706 0ustar billbill00000000000000package PScm::Continuation; use strict; use warnings; use base qw(PScm); require Exporter; our @ISA = qw(PScm Exporter); our @EXPORT = qw(cont); sub new { my ($class, $cont) = @_; bless { cont => $cont }, $class; } sub cont(&) { my ($cont) = @_; return __PACKAGE__->new($cont); } sub Apply { my ($self, $form, $env, $cont) = @_; $form->map_eval( $env, cont { my ($ra_evaluated_args) = @_; $self->Cont($ra_evaluated_args->[0]); } ); } sub Cont { my ($self, $arg) = @_; return cont { $self->{cont}->($arg) }; } sub Bounce { my ($self) = @_; $self->{cont}->(); } sub Eval { my ($self, $env, $cont) = @_; $cont->Cont($self); } 1; PScm-0.1.4/lib/PScm/Env.pm0000644000076500007650000000547710763466214015002 0ustar billbill00000000000000package PScm::Env; use strict; use warnings; use base qw(PScm); use PScm::Continuation; sub new { my ($class, %bindings) = @_; $class = ref($class) || $class; bless { bindings => {%bindings}, parent => 0 }, $class; } sub Extend { my ($self, $ra_symbols, $ra_values, $cont) = @_; PScm::Expr::List->new(@$ra_values)->map_eval( $self, cont { my ($ra_evaluated_values) = @_; $cont->Cont( $self->ExtendUnevaluated( $ra_symbols, $ra_evaluated_values ) ); } ); } sub ExtendUnevaluated { my ($self, $ra_symbols, $ra_values) = @_; my %newbindings; @newbindings{ map { $_->value } @$ra_symbols } = @$ra_values; my $newenv = $self->new(%newbindings); $newenv->{parent} = $self; return $newenv; } sub ExtendRecursively { my ($self, $ra_symbols, $ra_values, $cont) = @_; my $newenv = $self->ExtendUnevaluated($ra_symbols, $ra_values); $newenv->_eval_values($cont); } sub ExtendIteratively { my ($self, $ra_symbols, $ra_values, $cont) = @_; my @symbols = @$ra_symbols; my @values = @$ra_values; if (@symbols) { my $symbol = shift @symbols; my $value = shift @values; $self->Extend( [$symbol], [$value], cont { my ($extended) = @_; $extended->ExtendIteratively([@symbols], [@values], $cont); } ); } else { $cont->Cont($self); } } sub _eval_values { my ($self, $cont) = @_; $self->_map_bindings([keys %{ $self->{bindings} }], $cont); } sub _map_bindings { my ($self, $ra_keys, $cont) = @_; my (@keys) = @$ra_keys; if (@keys) { my $firstkey = shift @keys; $self->{bindings}{$firstkey}->Eval( $self, cont { my ($value) = @_; $self->{bindings}{$firstkey} = $value; $self->_map_bindings([@keys], $cont); } ); } else { $cont->Cont($self); } } sub LookUp { my ($self, $symbol) = @_; if (defined(my $ref = $self->_lookup_ref($symbol))) { return $$ref; } else { die "no binding for @{[$symbol->value]}", " in @{[ref($self)]}\n"; } } sub Assign { my ($self, $symbol, $value) = @_; if (defined(my $ref = $self->_lookup_ref($symbol))) { $$ref = $value; } else { die "no binding for @{[$symbol->value]}", " in @{[ref($self)]}\n"; } } sub _lookup_ref { my ($self, $symbol) = @_; if (exists($self->{bindings}{ $symbol->value })) { return \$self->{bindings}{ $symbol->value }; } elsif ($self->{parent}) { return $self->{parent}->_lookup_ref($symbol); } else { return undef; } } 1; PScm-0.1.4/lib/PScm/Expr.pm0000644000076500007650000000465110763466214015161 0ustar billbill00000000000000package PScm::Expr; use strict; use warnings; use base qw(PScm::Token); sub isTrue { my ($self) = @_; scalar($self->value); } sub Eval { my ($self, $env, $cont) = @_; $cont->Cont($self); } sub value { $_[0] } ######################### package PScm::Expr::Atom; use base qw(PScm::Expr); sub new { my ($class, $value) = @_; bless \$value, $class; } sub value { ${ $_[0] } } sub as_string { $_[0]->value } ######################### package PScm::Expr::List; use base qw(PScm::Expr); use PScm::Continuation; sub new { my ($class, @list) = @_; $class = ref($class) || $class; bless [@list], $class; } sub value { @{ $_[0] } } sub first { $_[0][0] } sub rest { my ($self) = @_; my @value = $self->value; shift @value; return $self->new(@value); } sub as_string { my ($self) = @_; return '(' . join(' ', map { $_->as_string } $self->value) . ')'; } sub Eval { my ($self, $env, $cont) = @_; return cont { $self->first()->Eval( $env, cont { my ($op) = @_; $op->Apply($self->rest, $env, $cont); } ); }; } sub map_eval { my ($self, $env, $cont) = @_; if (@$self) { $self->first->Eval( $env, cont { my ($evaluated_first) = @_; $self->rest->map_eval( $env, cont { my ($evaluated_rest) = @_; $cont->Cont([$evaluated_first, @$evaluated_rest]); } ); } ); } else { $cont->Cont([]); } } ########################### package PScm::Expr::Symbol; use base qw(PScm::Expr::Atom); sub Eval { my ($self, $env, $cont) = @_; $cont->Cont($env->LookUp($self)); } ############################ package PScm::Expr::Literal; use base qw(PScm::Expr::Atom); ########################### package PScm::Expr::Number; use base qw(PScm::Expr::Literal); use Math::BigInt; sub new { my ($class, $value) = @_; $value = new Math::BigInt($value) unless ref($value); $class->SUPER::new($value); } ########################### package PScm::Expr::String; use base qw(PScm::Expr::Literal); sub as_string { my ($self) = @_; my $copy = $self->value; $copy =~ s/\\/\\\\/sg; $copy =~ s/"/\\"/sg; return qq'"$copy"'; } 1; PScm-0.1.4/lib/PScm/Primitive.pm0000644000076500007650000000256610763466214016216 0ustar billbill00000000000000package PScm::Primitive; use strict; use warnings; use base qw(PScm::Expr); use PScm::Continuation; sub Apply { my ($self, $form, $env, $cont) = @_; $form->map_eval( $env, cont { my ($ra_evaluated_args) = @_; $cont->Cont($self->_apply(@$ra_evaluated_args)); } ); } sub _check_type { my ($self, $thing, $type) = @_; die "wrong type argument(", ref($thing), ") to ", ref($self), "\n" unless $thing->isa($type); } ################################## package PScm::Primitive::Multiply; use base qw(PScm::Primitive); sub _apply { my ($self, @args) = @_; my $result = PScm::Expr::Number->new(1)->value(); while (@args) { my $arg = shift @args; $self->_check_type($arg, 'PScm::Expr::Number'); $result *= $arg->value; } return new PScm::Expr::Number($result); } ################################## package PScm::Primitive::Subtract; use base qw(PScm::Primitive); sub _apply { my ($self, @args) = @_; unshift @args, PScm::Expr::Number->new(0) if @args < 2; my $arg = shift @args; $self->_check_type($arg, 'PScm::Expr::Number'); my $result = $arg->value; while (@args) { $arg = shift @args; $self->_check_type($arg, 'PScm::Expr::Number'); $result -= $arg->value; } return new PScm::Expr::Number($result); } 1; PScm-0.1.4/lib/PScm/Read.pm0000644000076500007650000000272110747072332015106 0ustar billbill00000000000000package PScm::Read; use strict; use warnings; use PScm::Expr; use PScm::Token; use base qw(PScm); sub new { my ($class, $fh) = @_; bless { FileHandle => $fh, Line => '', }, $class; } sub _read { my ($self) = @_; my $token = $self->_next_token(); return undef unless defined $token; return $token unless $token->is_open_token; my @res = (); while (1) { $token = $self->_read; die "unexpected EOF" if !defined $token; last if $token->is_close_token; push @res, $token; } return new PScm::Expr::List(@res); } sub _next_token { my ($self) = @_; while (!$self->{Line}) { $self->{Line} = $self->{FileHandle}->getline(); return undef unless defined $self->{Line}; $self->{Line} =~ s/^\s+//s; } for ($self->{Line}) { s/^\(\s*// && return PScm::Token::Open->new(); s/^\)\s*// && return PScm::Token::Close->new(); s/^([-+]?\d+)\s*// && return PScm::Expr::Number->new($1); s/^"((?:(?:\\.)|([^"]))*)"\s*// && do { my $string = $1; $string =~ s/\\//g; return PScm::Expr::String->new($string); }; s/^([^\s\(\)]+)\s*// && return PScm::Expr::Symbol->new($1); } die "can't parse: $self->{Line}"; } sub Read { my ($self, $cont) = @_; my $res = $self->_read(); return undef unless defined $res; $cont->Cont($res); } 1; PScm-0.1.4/lib/PScm/SpecialForm.pm0000644000076500007650000000550410747072332016441 0ustar billbill00000000000000package PScm::SpecialForm; use strict; use warnings; use base qw(PScm::Expr); ############################### package PScm::SpecialForm::Let; use base qw(PScm::SpecialForm); use PScm::Continuation; sub Apply { my ($self, $form, $env, $cont) = @_; my ($ra_symbols, $ra_values, $body) = $self->UnPack($form); $env->Extend( $ra_symbols, $ra_values, cont { my ($newenv) = @_; $body->Eval($newenv, $cont); } ); } sub UnPack { my ($self, $form) = @_; my ($bindings, $body) = $form->value; my (@symbols, @values); foreach my $binding ($bindings->value) { my ($symbol, $value) = $binding->value; push @symbols, $symbol; push @values, $value; } return (\@symbols, \@values, $body); } ################################## package PScm::SpecialForm::LetRec; use base qw(PScm::SpecialForm::Let); use PScm::Continuation; sub Apply { my ($self, $form, $env, $cont) = @_; my ($ra_symbols, $ra_values, $body) = $self->UnPack($form); $env->ExtendRecursively( $ra_symbols, $ra_values, cont { my ($extended_env) = @_; $body->Eval($extended_env, $cont); } ); } ################################### package PScm::SpecialForm::LetStar; use base qw(PScm::SpecialForm::Let); use PScm::Continuation; sub Apply { my ($self, $form, $env, $cont) = @_; my ($ra_symbols, $ra_values, $body) = $self->UnPack($form); $env->ExtendIteratively( $ra_symbols, $ra_values, cont { my ($extended_env) = @_; $body->Eval($extended_env, $cont); } ); } ############################## package PScm::SpecialForm::If; use base qw(PScm::SpecialForm); use PScm::Continuation; sub Apply { my ($self, $form, $env, $cont) = @_; my ($condition, $true_branch, $false_branch) = $form->value; $condition->Eval( $env, cont { my ($result) = @_; if ($result->isTrue) { $true_branch->Eval($env, $cont); } else { $false_branch->Eval($env, $cont); } } ); } ################################## package PScm::SpecialForm::Lambda; use base qw(PScm::SpecialForm); use PScm::Closure; sub Apply { my ($self, $form, $env, $cont) = @_; my ($args, $body) = $form->value; $cont->Cont(PScm::Closure::Function->new($args, $body, $env)); } ################################## package PScm::SpecialForm::CallCC; use base qw(PScm::SpecialForm); use PScm::Closure; use PScm::Continuation; sub Apply { my ($self, $form, $env, $cont) = @_; $form->first->Eval( $env, cont { my ($closure) = @_; $closure->Apply(new PScm::Expr::List($cont), $env, $cont); } ); } 1; PScm-0.1.4/lib/PScm/Token.pm0000644000076500007650000000052210741522161015302 0ustar billbill00000000000000package PScm::Token; use strict; use warnings; use base qw(PScm); sub is_open_token { 0 } sub is_close_token { 0 } ########################## package PScm::Token::Open; use base qw(PScm::Token); sub is_open_token { 1 } ########################### package PScm::Token::Close; use base qw(PScm::Token); sub is_close_token { 1 } 1; PScm-0.1.4/lib/PScm.pm0000644000076500007650000000356310763466214014244 0ustar billbill00000000000000package PScm; use strict; use warnings; use PScm::Read; use PScm::Env; use PScm::Primitive; use PScm::SpecialForm; use PScm::Continuation; use FileHandle; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(ReadEvalPrint); =head1 NAME PScm - PScm interpreter written in Perl =head1 SYNOPSIS use PScm; ReadEvalPrint($in_filehandle[, $out_filehandle]); =head1 DESCRIPTION Just messing about, A toy lisp interpreter. =cut sub ReadEvalPrint { my ($infh, $outfh) = @_; $outfh ||= new FileHandle(">-"); my $reader = new PScm::Read($infh); trampoline(cont { repl($reader, $outfh) }); } sub repl { my ($reader, $outfh) = @_; $reader->Read( cont { my ($expr) = @_; $expr->Eval( new PScm::Env( let => new PScm::SpecialForm::Let(), '*' => new PScm::Primitive::Multiply(), '-' => new PScm::Primitive::Subtract(), if => new PScm::SpecialForm::If(), lambda => new PScm::SpecialForm::Lambda(), letrec => new PScm::SpecialForm::LetRec(), 'let*' => new PScm::SpecialForm::LetStar(), 'call/cc' => new PScm::SpecialForm::CallCC(), ), cont { my ($result) = @_; $result->Print( $outfh, cont { repl($reader, $outfh); } ) } ) } ) } sub trampoline { my ($cont) = @_; $cont = $cont->Bounce() while defined $cont; } sub Print { my ($expr, $outfh, $cont) = @_; print $outfh $expr->as_string, "\n"; $cont->Cont($expr); } sub as_string { ref($_[0]); } sub new { bless {}, $_[0] } 1; PScm-0.1.4/Makefile.PL0000644000076500007650000000101610735262742014236 0ustar billbill00000000000000use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'PScm', VERSION_FROM => 'VERSION', # finds $VERSION PREREQ_PM => { Test::More => 0, }, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'ABSTRACT', # retrieve abstract from file AUTHOR => 'Bill Hails ') : ()), ); PScm-0.1.4/MANIFEST0000644000076500007650000000070310741512120013400 0ustar billbill00000000000000ABSTRACT Changes Makefile.PL MANIFEST README VERSION t/CPS_repl.t t/CPS_Letrec.t t/PScm.t t/PScm_CallCC.t t/PScm_Lambda.t t/PScm_Let.t t/PScm_LetStar.t t/PScm_Letrec.t t/interactive t/lib/PScm/Test.pm lib/PScm.pm lib/PScm/Closure.pm lib/PScm/Continuation.pm lib/PScm/Expr.pm lib/PScm/Env.pm lib/PScm/Primitive.pm lib/PScm/Read.pm lib/PScm/SpecialForm.pm lib/PScm/Token.pm META.yml Module meta-data (added by MakeMaker) PScm-0.1.4/META.yml0000644000076500007650000000050611000456160013521 0ustar billbill00000000000000# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: PScm version: 0.1.4 version_from: VERSION installdirs: site requires: Test::More: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 PScm-0.1.4/README0000644000076500007650000000265210727330146013146 0ustar billbill00000000000000PScm - various versions ======================= PScheme is a toy scheme-like interpreter written entirely in Perl. It is not intended as a production quality implementation, it lacks all but the most rudimentary error detection and when it does detect an error all it can do is die. The design and implementation of PScheme was totally driven by the needs of the accompanying book: "Exploring Programming Language Architecture in Perl" (http://billhails.net/Book) and the source code is provided only as a courtesy to the readers of that book. PScheme is not meant to be installed (though there is nothing to stop you doing so). Each "version" of the implementation is really a separate entity to be studied and compared with other versions. If you do install a particular version it will replace any other version you had previously installed. Better to just unpack the .tgz and play with the code in place. INSTALLATION Although you can install the package, it's really just for reading and playing with the code. If you must install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES Test::More - for testing COPYRIGHT AND LICENCE Copyright (C) 2005, 2006 by Bill Hails This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.7 or, at your option, any later version of Perl 5 you may have available. PScm-0.1.4/t/0000755000076500007650000000000011000456160012512 5ustar billbill00000000000000PScm-0.1.4/t/CPS_Letrec.t0000644000076500007650000000063310731565166014645 0ustar billbill00000000000000use strict; use warnings; use Test::More; use lib 't/lib'; use PScm::Test tests => 2; BEGIN { use_ok('PScm') } eval_ok(< 2; BEGIN { use_ok('PScm') } eval_ok(< new Term::ReadLine('PScheme'), }, $class; } sub getline { my ($self) = @_; $self->{term}->readline('> '); } package main; my $in = new GetLine(); ReadEvalPrint($in); # vim: ft=perl PScm-0.1.4/t/lib/0000755000076500007650000000000011000456160013260 5ustar billbill00000000000000PScm-0.1.4/t/lib/PScm/0000755000076500007650000000000011000456160014122 5ustar billbill00000000000000PScm-0.1.4/t/lib/PScm/Test.pm0000644000076500007650000000170010741525700015405 0ustar billbill00000000000000package PScm::Test; use strict; use warnings; use FileHandle; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(eval_ok evaluate); my $Test = Test::Builder->new; sub import { my ($self) = shift; my $pack = caller; $Test->exported_to($pack); $Test->plan(@_); $self->export_to_level(1, $self, 'eval_ok'); $self->export_to_level(1, $self, 'evaluate'); } sub eval_ok { my ($expr, $expected, $name) = @_; my $result = evaluate($expr); $result .= "\n" if $expected =~ /\n/; $Test->is_eq($result, $expected, $name); } sub evaluate { my ($expression) = @_; my $fh = new FileHandle("> junk"); $fh->print($expression); $fh = new FileHandle('< junk'); my $outfh = new FileHandle("> junk2"); PScm::ReadEvalPrint($fh, $outfh); $fh = 0; $outfh = 0; my $res = `cat junk2`; chomp $res; unlink('junk'); unlink('junk2'); # warn "# [$res]\n"; return $res; } 1; PScm-0.1.4/t/PScm.t0000644000076500007650000000136110736745054013564 0ustar billbill00000000000000use strict; use warnings; use Test::More; use lib './t/lib'; use PScm::Test tests => 10; BEGIN { use_ok('PScm') } eval_ok('1', '1', 'numbers'); eval_ok('+1', '1', 'explicit positive numbers'); eval_ok('-1', '-1', 'negative numbers'); eval_ok('"hello"', '"hello"', 'strings'); eval_ok('(* 2 3 4)', '24', 'multiplication'); eval_ok('(- 10 2 3)', '5', 'subtraction'); eval_ok('(- 10)', '-10', 'negation'); eval_ok('(if (* 0 1) 10 20)', '20', 'simple conditional'); eval_ok(< 2; BEGIN { use_ok('PScm') } eval_ok(< 5; use FileHandle; BEGIN { use_ok('PScm') } eval_ok(< 3; BEGIN { use_ok('PScm') } eval_ok('(let ((x 2)) x)', '2', 'simple let'); eval_ok(< 4; BEGIN { use_ok('PScm') } ok( !defined(eval { evaluate(< 3; BEGIN { use_ok('PScm') } eval_ok(<