PScm-0.1.2/0000755000076500007650000000000011000456157012253 5ustar billbill00000000000000PScm-0.1.2/ABSTRACT0000644000076500007650000000012610737002136013400 0ustar billbill00000000000000=head1 ABSTRACT PScm - a toy scheme-like interpreter written entirely in Perl. =cut PScm-0.1.2/Changes0000644000076500007650000000043310727327703013557 0ustar billbill00000000000000Revision history for Perl extension PScm. 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.2/lib/0000755000076500007650000000000011000456157013021 5ustar billbill00000000000000PScm-0.1.2/lib/PScm/0000755000076500007650000000000011000456157013663 5ustar billbill00000000000000PScm-0.1.2/lib/PScm/Closure.pm0000644000076500007650000000204510763324252015643 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); return $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.2/lib/PScm/Continuation.pm0000644000076500007650000000134110763324353016701 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.2/lib/PScm/Env.pm0000644000076500007650000000225310763324533014762 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 LookUp { my ($self, $symbol) = @_; if (exists($self->{bindings}{ $symbol->value })) { return $self->{bindings}{ $symbol->value }; } elsif ($self->{parent}) { return $self->{parent}->LookUp($symbol); } else { die "no binding for @{[$symbol->value]} ", "in @{[ref($self)]}\n"; } } 1; PScm-0.1.2/lib/PScm/Expr.pm0000644000076500007650000000465110763324312015147 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.2/lib/PScm/Primitive.pm0000644000076500007650000000256610763324563016214 0ustar billbill00000000000000package PScm::Primitive; use strict; use warnings; use PScm::Continuation; use base qw(PScm::Expr); 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.2/lib/PScm/Read.pm0000644000076500007650000000272110747071052015102 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.2/lib/PScm/SpecialForm.pm0000644000076500007650000000346510747071070016441 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 ($bindings, $body) = $form->value; my (@symbols, @values); foreach my $binding ($bindings->value) { my ($symbol, $value) = $binding->value; push @symbols, $symbol; push @values, $value; } $env->Extend( \@symbols, \@values, cont { my ($newenv) = @_; $body->Eval($newenv, $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.2/lib/PScm/Token.pm0000644000076500007650000000052210741522153015301 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.2/lib/PScm.pm0000644000076500007650000000336410763323043014231 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(), '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.2/._Makefile.PL0000644000076500000000000000261410735262477014623 0ustar billwheel00000000000000Mac OS X  2 R:2&/Applications/DarwinPorts/Vim/Vim.app;x;x³³;w³³³³<x³³³³³³:²²²²²²²²:w²³²²²²:v²³³³:v±²:v2¬ðZ·2usro ÿÿ„´WPScm-0.1.2/Makefile.PL0000644000076500007650000000101610735262477014241 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.2/MANIFEST0000644000076500007650000000062310741510060013400 0ustar billbill00000000000000ABSTRACT Changes Makefile.PL MANIFEST README VERSION t/CPS_repl.t t/PScm.t t/PScm_CallCC.t t/PScm_Lambda.t t/PScm_Let.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.2/META.yml0000644000076500007650000000050611000456157013525 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.2 version_from: VERSION installdirs: site requires: Test::More: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 PScm-0.1.2/README0000644000076500007650000000265210727327703013151 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.2/t/0000755000076500007650000000000011000456157012516 5ustar billbill00000000000000PScm-0.1.2/t/CPS_repl.t0000644000076500007650000000054110742230525014353 0ustar billbill00000000000000use strict; use warnings; use Test::More; use lib './t/lib'; use PScm::Test tests => 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.2/t/lib/0000755000076500007650000000000011000456157013264 5ustar billbill00000000000000PScm-0.1.2/t/lib/PScm/0000755000076500007650000000000011000456157014126 5ustar billbill00000000000000PScm-0.1.2/t/lib/PScm/Test.pm0000644000076500007650000000170010741525672015413 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.2/t/PScm.t0000644000076500007650000000136110736745050013556 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(<