[Rt-commit] [svn] r1118 - in mzscheme: . Scheme Scheme/lib
Scheme/lib/Scheme Scheme/lib/Scheme/Util Scheme/script
autrijus at pallas.eruditorum.org
autrijus at pallas.eruditorum.org
Sat Jun 19 12:30:21 EDT 2004
Author: autrijus
Date: Sat Jun 19 12:30:20 2004
New Revision: 1118
Added:
mzscheme/Scheme/
mzscheme/Scheme/Makefile.PL
mzscheme/Scheme/lib/
mzscheme/Scheme/lib/Scheme/
mzscheme/Scheme/lib/Scheme.pm
mzscheme/Scheme/lib/Scheme/Parser.pm
mzscheme/Scheme/lib/Scheme/REPL.pm
mzscheme/Scheme/lib/Scheme/Tokenizer.pm
mzscheme/Scheme/lib/Scheme/Util/
mzscheme/Scheme/lib/Scheme/Util/File.pm
mzscheme/Scheme/lib/Scheme/Util/SchemeSocketThread.pm
mzscheme/Scheme/script/
mzscheme/Scheme/script/scheme.pl
Modified:
mzscheme/ (props changed)
Log:
----------------------------------------------------------------------
r5669 at not: autrijus | 2004-06-19T16:24:05.822466Z
* Initial commit of Scheme.pm.
----------------------------------------------------------------------
r5670 at not: autrijus | 2004-06-19T16:29:48.071721Z
* add misc. code sources for refactoring.
----------------------------------------------------------------------
Added: mzscheme/Scheme/Makefile.PL
==============================================================================
--- (empty file)
+++ mzscheme/Scheme/Makefile.PL Sat Jun 19 12:30:20 2004
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+use strict;
+use inc::Module::Install;
+
+name ('Scheme');
+author ('Autrijus Tang <autrijus at autrijus.org>');
+abstract ('Perl interpreter for Scheme code');
+license ('perl');
+version_from ('lib/Scheme.pm');
+
+requires(map +($_ => 0), qw(
+ Spiffy
+ Perl6::Say
+));
+
+WriteAll( sign => 1 );
Added: mzscheme/Scheme/lib/Scheme.pm
==============================================================================
--- (empty file)
+++ mzscheme/Scheme/lib/Scheme.pm Sat Jun 19 12:30:20 2004
@@ -0,0 +1,15 @@
+package Scheme;
+
+use strict;
+use base 'Exporter';
+our @EXPORT = qw( true false null );
+our $VERSION = '0.01';
+
+use constant true => 1;
+use constant false => undef;
+use constant null => undef;
+
+# XXX - alias all class names into simple names
+# XXX - export ~~ from i18n.pm
+
+1;
Added: mzscheme/Scheme/lib/Scheme/Parser.pm
==============================================================================
--- (empty file)
+++ mzscheme/Scheme/lib/Scheme/Parser.pm Sat Jun 19 12:30:20 2004
@@ -0,0 +1,133 @@
+package Scheme::Parser;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+$VERSION = '0.01';
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(parse);
+
+use Data::Dumper;
+
+my $ind = 0;
+sub _build_tree {
+ my ($tokens,$count) = @_;
+ my $temp = {};
+
+ die "EOF reached" if $count >= $#$tokens;
+
+ 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;
+ }
+ elsif ($tokens->[$count] eq "`") {
+ $temp = { children => [{ value => 'quasiquote' }] };
+ my $expr;
+ $count++;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
+ }
+ elsif ($tokens->[$count] eq ",") {
+ $temp = { children => [{ value => 'unquote' }] };
+ my $expr;
+ $count++;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
+ }
+ elsif ($tokens->[$count] eq ",@") {
+ $temp = { children => [{ value => 'unquote-splicing' }] };
+ my $expr;
+ $count++;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
+ }
+ else {
+ $temp->{value} = $tokens->[$count++];
+ }
+
+ return ($count,$temp);
+}
+
+sub _dataflow {
+ my $node = shift;
+
+ if(exists $node->{children}) {
+ for(@{$node->{children}}) {
+ _dataflow($_);
+ }
+ my $cur_type = $node->{children}[0]{type};
+ for(@{$node->{children}}) {
+ $cur_type = $_->{type} if $_->{type} eq 'REAL';
+ }
+ $node->{type} = $cur_type;#$node->{children}[0]{type};
+ } else {
+ $node->{type} = 'INTEGER' if $node->{value} =~ /^[-]?\d+$/;
+ $node->{type} = 'REAL' if $node->{value} =~
+ /^[-]?\d+\.(\d+([-+]?[eE]\d+)?)?/;
+ $node->{type} = 'REAL' if $node->{value} =~
+ /^[-]?\.(\d+([-+]?[eE]\d+)?)/;
+ $node->{type} ||= 'EXPRESSION';
+ }
+}
+
+sub parse {
+ my $tokens = shift;
+ 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;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Scheme::Parser - The Scheme token parser
+
+=head1 SYNOPSIS
+
+ use Scheme::Parser qw(parse);
+
+ my @code = parse($tokens);
+
+=head1 DESCRIPTION
+
+The parser reads a list of tokens and turns it into a tree structure.
+
+=head1 AUTHOR
+
+Jeffrey Goff, drforr at hargray.com
+
+=head1 SEE ALSO
+
+L<Scheme>, L<Scheme::Tokenizer>, L<Scheme::Generator>
+
+=cut
Added: mzscheme/Scheme/lib/Scheme/REPL.pm
==============================================================================
--- (empty file)
+++ mzscheme/Scheme/lib/Scheme/REPL.pm Sat Jun 19 12:30:20 2004
@@ -0,0 +1,342 @@
+package Scheme::REPL;
+
+use strict;
+use Scheme;
+use Error;
+use Perl6::Say;
+use Spiffy '-Base';
+
+field 'primordialThread';
+field 'appName';
+
+sub new {
+ if ($_[1]->isa('DynamicEnvironment')) {
+ my ($appName, $dynenv, $repl) = @_;
+ $self = $self->new($appName, $repl);
+ $self->env($dynenv);
+ return $self;
+ }
+ elsif ($_[1]->isa('Procedure')) {
+ my ($appName, $repl) = @_;
+ return $self->new($appName, SchemeThread->new($appName, $repl));
+ }
+
+ my ($appName, $primordialThread) = @_;
+ $self = super;
+ $self->primordialThread($primordialThread);
+ $self->appName($appName);
+}
+
+sub findHeap {
+ my ($heapLocation) = @_;
+ try {
+ $heapLocation ||= 'pisc.shp';
+ BufferedRandomAccessInputStream->new($heapLocation, 'r', 1, 8192);
+ }
+ catch Exception with {
+ my $e = shift;
+ return null;
+ }
+}
+
+sub simpleErrorToString {
+ my ($p) = @_;
+ my ($b, $location, $message, $parent);
+
+ while ($p != Util->EMPTYLIST and (!$location or !$message)) {
+ my $cp = $p->car;
+ if ($cp->car->equals(Util->MESSAGE)) {
+ $message = $cp->cdr->toString;
+ }
+ elsif ($cp->car->equals(Util->LOCATION)) {
+ $location = $cp->cdr->toString;
+ }
+ elsif ($cp->car->equals(Util->PARENT)) {
+ $parent = $cp->cdr->toString;
+ }
+ $p = $p->cdr;
+ }
+
+ if ($location == null) {
+ $b .= ~~"error";
+ }
+ else {
+ $b .= ~~"errorinwhere $location";
+ }
+
+ if ($message != null) {
+ $b .= ": $message";
+ }
+ else {
+ $b .= ".";
+ }
+
+ if ($parent != null) {
+ $b .= "\n ".$self->simpleErrorToString($parent);
+ }
+
+ return $b;
+}
+
+sub loadHeap {
+ my ($r, $in) = @_;
+
+ throw ClassNotFoundException unless eval {
+ try {
+ $r->getCtx->loadEnv($r, SeekableInputStream->new($in))
+ }
+ catch IOException with {
+ my $e = shift;
+ STDERR->say("\n".~~"errorloadingheap");
+ $e->printStackTrace;
+ return false;
+ };
+
+ try {
+ my $roots = File->listRoots;
+ my $rootss = [ map SchemeString->new($_), scalar @$roots ];
+ $r->define(
+ Symbol->get("fs-roots"),
+ Util->valArrayToList($rootss, 0, scalar @$rootss),
+ Util->SISC,
+ );
+ }
+ catch AccessControlException with {
+ my $ace = shift;
+ };
+
+ try {
+ $r->eval('(initialize)');
+ }
+ catch SchemeString with {
+ my $se = shift;
+ STDERR->say(~~"errorduringinitialize".$self->simpleErrorToString($se));
+ }
+ catch IOException with {
+ my $e = shift;
+ STDERR->say(~~"errorduringinitialize".$e->getMessage);
+ };
+
+ return true;
+ }
+}
+
+sub loadSourceFiles {
+ my ($r, $files) = @_;
+ my $returnStatus = true;
+ my $loadSymb = Symbol->get("load");
+
+ foreach my $file (@$files) {
+ try {
+ $r->eval(
+ $r->lookup($loadSymb, Util->TOPLEVEL),
+ SchemeString->new($files),
+ );
+ }
+ catch SchemeException with {
+ my $se = shift;
+ my $vm = $se->m;
+ if ($vm->isa('Pair')) {
+ my $errormessage = $self->simpleErrorToString($vm);
+ STDERR->say($errormessage);
+ }
+ else {
+ STDERR->say(~~"errorduringload".$vm);
+ }
+ $returnStatus = false;
+ }
+
+ return $returnStatus;
+ }
+}
+
+sub go {
+ try {
+ $self->primordialThread->env->out->write(
+ "SISC (".Util->VERSION.") - ".$self->appName."\n"
+ );
+ }
+ catch IOException with {
+ my $e = shift;
+ };
+
+ if ($self->primordialThread->thunk == null) {
+ STDERR->say(~~"heapnotfound");
+ return;
+ }
+
+ $self->primordialThread->start;
+}
+
+sub main {
+ my ($argv) = @_;
+
+ throw Exception unless eval {
+ my $args = $self->parseOpts($argv);
+ if ($args->{help}) {
+ $self->printUsage;
+ exit(0);
+ }
+ elsif ($args->{version}) {
+ say "SISC - The Second Interpreter of Scheme Code - ".Util->VERSION;
+ exit(0);
+ }
+
+ my $heap = $self->findHeap($args->{heap});
+ if ($heap == null) {
+ STDERR->say(~~"noheap");
+ return;
+ }
+
+ my $props = Properties->new;
+ my $configFile = $args->{properties};
+ if ($configFile != null) {
+ try {
+ my $url = Util->url($configFile);
+ my $conn = $url->openConnection;
+ $conn->setDoInput(true);
+ $conn->setDoOutput(false);
+ $props->load($conn->getInputStream);
+ }
+ catch MalformedURLException with {
+ my $e = shift;
+ STDERR->say(~~"WARNING: ".$e->getMessage);
+ }
+ catch IOException with {
+ my $e = shift;
+ STDERR->say(~~"WARNING: ".$e->getMessage);
+ };
+ }
+
+ my $ctx = AppContext->new($props);
+ Context->register("main", $ctx);
+ my $r = Context->enter($ctx);
+ if (!$self->loadHeap($r, $heap)) {
+ return;
+ }
+
+ my $filesLoadedSuccessfully = $self->loadSourceFiles(
+ $r,
+ @{$args->{files}}
+ );
+
+ my $noRepl = ($args->{'no-repl'} != null);
+ my $call = ($args->{'call-with-args'} != null);
+ my $returnCode = 0;
+
+ my $expr = $args->{eval};
+ if ($expr != null) {
+ my $v = $r->eval($expr);
+ if (!$call) {
+ say $v;
+ }
+ }
+
+ my $func = $args->{"call-with-args"};
+ if ($func != null) {
+ my $fun = Util->proc($r->eval($func));
+ my $av = $args->{argv};
+ my $sargs = [ map SchemeString->new($_), @$av ];
+ my $v = $r->eval($fun, $sargs);
+ if ($noRepl) {
+ if ($v->isa('Quantity')) {
+ $returnCode = $v->indexValue;
+ }
+ elsif (!$v->isa('SchemeVoid')) {
+ say $v;
+ }
+ }
+ }
+
+ my $dynenv = $r->dynenv;
+ Context->exit;
+
+ if (!$noRepl) {
+ my $listen = $args->{listen};
+ if ($listen != null) {
+ my $ssocket = ($listen =~ /(.+):(\d+)/) ?
+ ServerSocket->new($2, 50) :
+ ServerSocket->new($2, 50, $1);
+
+ local $| = 1;
+ say ~~"Listening on ".$ssocket->getInetAddress.":".$ssocket->getLocalPort;
+ $self->listen('main', $ssocket);
+ } else {
+ my $p = $r->lookup(Symbol->get('pisc-cli'), Util->TOPLEVEL);
+ my $repl = REPL->new("main", $dynenv, $p);
+ $repl->go;
+ $repl->primordialThread->thread->join;
+ for my $state ($repl->primordialThread->state) {
+ if ($state == SchemeThread->FINISHED) {
+ if ($repl->primordialThread->rv->isa('Quantity')) {
+ $returnCode = $repl->primordialThread->rv->intValue;
+ }
+ }
+ elsif ($state == SchemeThread->FINISHED_ABNORMALLY) {
+ $returnCode = 1;
+ }
+ }
+ }
+ } elsif ($returnCode == 0 and !$filesLoadedSuccessfully) {
+ $returnCode = 1;
+ }
+
+ exit($returnCode);
+ };
+}
+
+sub listen {
+ my ($app, $ssocket) = @_;
+
+ throw IOException unless eval {
+ while (1) {
+ my $client = $ssocket->accept;
+ my $dynenv = DynamicEnvironment->new(
+ Context->lookup($app),
+ SourceInputPort->new(
+ BufferedInputStream->new($client->getInputStream),
+ 'console'
+ ),
+ StreamOutputPort->new(
+ $client->getOutputStream,
+ true
+ )
+ );
+ my $r = Context->enter($dynenv);
+ my $p = $r->lookup(Symbol->get('pisc-cli'), Util->TOPLEVEL);
+ Context->exit;
+ my $t = SchemeSocketThread->new($app, $p, $client);
+ $t->env = $dynenv;
+ my $repl = REPL->new($app, $t);
+ $repl->go;
+ }
+ }
+}
+
+sub printUsage {
+ say ~~"PISC - Perl Interpreter of Scheme Code\n";
+ say ~~"usage: pisc [-?xv] [-l port] [-h heapfile] [-p property-file]";
+ say ~~" [-e s-expression] [-c function] [source-file ...] [-- arguments ...]";
+}
+
+sub parseOpts {
+ my ($args) = @_;
+ local @ARGV = @$args;
+
+ my %args;
+ use Getopt::Long qw(:config no_ignore_case);
+ GetOptions( \%args, qw(
+ help|?
+ listen|l
+ heap|h
+ properties|p
+ eval|e
+ call-with-args|c
+ no-repl|x
+ version|v
+ ) );
+
+ return \%args;
+}
+
+1;
Added: mzscheme/Scheme/lib/Scheme/Tokenizer.pm
==============================================================================
--- (empty file)
+++ mzscheme/Scheme/lib/Scheme/Tokenizer.pm Sat Jun 19 12:30:20 2004
@@ -0,0 +1,94 @@
+package Scheme::Tokenizer;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+$VERSION = '0.01';
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(tokenize);
+
+use Data::Dumper;
+
+sub tokenize {
+ my $file = shift;
+ my $text;
+ my $tokref;
+ my $token = '';
+
+ open SOURCE,"<$file";
+ while(<SOURCE>) {
+ next if /^\s*;/;
+ s/;.*$//;
+ $text .= $_;
+ }
+ close SOURCE;
+
+ for my $ch (split //,$text) {
+ if($ch eq '(' or
+ $ch eq ')') {
+ push @$tokref,$token;
+ $token = $ch;
+ } elsif($ch eq '-' and
+ ($token =~ /^[a-z]/ or # Dashes can be in an ident
+ $token =~ /^[-]\d+(\.\d+)?[eE]/)) { # Dashes could be a neg. expt
+ $token .= $ch;
+ } elsif($ch eq '?' and
+ $token =~ /^[a-z]/) { # Question marks can follow an identifier
+ $token .= $ch;
+ } elsif($ch eq '!' and
+ $token =~ /^[a-z]/) { # Exclamation marks can follow an identifier
+ $token .= $ch;
+ } elsif($ch eq '=' and
+ $token =~ /^[<>]/) { # Equal sign can follow '<','>'
+ $token .= $ch;
+ } elsif($ch eq '.' and
+ $token =~ /^\d+$/) { # Equal sign can follow '<','>'
+ $token .= $ch;
+ } elsif($ch =~ /\d/ and
+ ($token =~ /^[-]/ or # Digits can follow a dash
+ $token =~ /^\./ or # Digits can follow a decimal point
+ $token =~ /^\d/)) { # Digits can follow other digits
+ $token .= $ch;
+ } elsif($ch =~ /[a-zA-Z]/ and
+ $token =~ /^\w/) { # Letters can follow other letters
+ $token .= $ch;
+ } elsif($ch =~ /\s/ and
+ $token =~ /^\s/) { # White can follow white
+ $token .= $ch;
+ } elsif($ch =~ /@/ and
+ $token =~ /^,$/) { # token ,@
+ $token .= $ch;
+ } else {
+ push @$tokref,$token;
+ $token = $ch;
+ }
+ }
+ return [grep { /\S/ } @$tokref];
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Scheme::Tokenizer - The Scheme tokenizer
+
+=head1 SYNOPSIS
+
+ use Scheme:Tokenizer;
+
+ my @code = Scheme::Tokenizer->new($file_name)->tokenize();
+
+=head1 DESCRIPTION
+
+The tokenizer takes a file and splits it into tokens.
+
+=head1 AUTHOR
+
+Jeffrey Goff, drforr at hargray.com
+
+=head1 SEE ALSO
+
+L<Scheme>, L<Scheme::Parser>, L<Scheme::Generator>
+
+=cut
Added: mzscheme/Scheme/lib/Scheme/Util/File.pm
==============================================================================
--- (empty file)
+++ mzscheme/Scheme/lib/Scheme/Util/File.pm Sat Jun 19 12:30:20 2004
@@ -0,0 +1,12 @@
+package PISC::Util::File;
+use strict;
+
+sub listRoots {
+ eval {
+ require Win32API::File;
+ return Win32API::File::getLogicalDrives();
+ };
+ return '/';
+}
+
+1;
Added: mzscheme/Scheme/lib/Scheme/Util/SchemeSocketThread.pm
==============================================================================
--- (empty file)
+++ mzscheme/Scheme/lib/Scheme/Util/SchemeSocketThread.pm Sat Jun 19 12:30:20 2004
@@ -0,0 +1,26 @@
+package Scheme::Util::SchemeSocketThread;
+
+use strict;
+use Scheme;
+use Spiffy '-Base';
+use base SchemeThread;
+
+field 's';
+
+sub new {
+ my ($appName, $thunk, $s) = @_;
+ $self = super;
+ $self->s($s);
+}
+
+sub run {
+ super;
+ try {
+ $self->s->close
+ }
+ catch IOException with {
+ my $e = shift;
+ }
+}
+
+1;
Added: mzscheme/Scheme/script/scheme.pl
==============================================================================
--- (empty file)
+++ mzscheme/Scheme/script/scheme.pl Sat Jun 19 12:30:20 2004
@@ -0,0 +1,989 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Math::BigInt;
+use Math::BigFloat;
+
+sub car { $_[0][1] }
+sub cdr { $_[0][2] }
+sub cons { [ pair => @_[0,1] ] }
+
+use constant Null => [ 'empty' ];
+use constant True => [ boolean => '#t' ];
+use constant False => [ boolean => '#f' ];
+use constant Characters => {
+ '#\space' => " ",
+ '#\tab' => "\t",
+ '#\newline' => "\n"
+};
+
+my @tokens;
+sub token {
+ my ($in, $line) = @_;
+
+ while (!@tokens) {
+ return undef if eof($in);
+
+ $line = <$in>;
+ if ($line =~ /^([^;]*);/) {
+ $line = $1;
+ }
+
+ @tokens = map {
+ if (!/\"[^"]*\"/) {
+ grep !/^$/, split /([\(\)\'])/;
+ }
+ else {
+ $_;
+ }
+ } map {
+ if (!/\"[^"]*\"/) {
+ split ' ';
+ }
+ else {
+ $_;
+ }
+ } split /(\"[^"]*\")/, $line;
+ }
+
+ return shift @tokens;
+}
+
+sub read_expression {
+ my $in = shift;
+ my $t = token($in);
+
+ return undef if not defined $t;
+
+ return [ string => $1 ]
+ if $t =~ /^\"([^\"]+)\"$/;
+
+ return [ float => Math::BigFloat->new($t) ]
+ if $t =~ /^[+-]?\d+\.\d+([eE][+-]?\d+)?$/;
+
+ return [ integer => Math::BigInt->new($t) ]
+ if $t =~ /^[+-]?\d+$/;
+
+ return [ symbol => $t ]
+ if $t =~ /^[\+\-\*\/\=\>\<]|<=|>=$/
+ or $t =~ /^[a-zA-Z\?][a-zA-Z0-9\-\?\!\*]*$/;
+
+ return True if $t eq '#t';
+ return False if $t eq '#f';
+
+ return [ character => $t ]
+ if $t =~ /^\#\\(\w+|\.|\,|\+|\-|\*|\/)$/;
+
+ my $item;
+ if ($t =~ /^\'$/) {
+ die "parse error (quote missing an item)"
+ if not defined($item = read_expression($in));
+ return cons([ 'symbol', 'quote' ], cons($item, Null));
+ }
+
+ if ($t =~ /^\#$/) {
+ die "parse error (vector missing vector data)"
+ if not defined($item = read_expression($in));
+
+ die "parse error (malformed vector data)"
+ if $item->[0] ne 'pair'
+ and $item->[0] ne 'empty';
+
+ my ($vector) = ([]);
+ while ($item->[0] eq 'pair') {
+ push @$vector, car($item);
+ $item = cdr($item);
+ }
+
+ die "parse error (malformed vector data: improper list)"
+ if $item->[0] ne 'empty';
+
+ return [ vector => $vector ];
+ }
+
+ return ['improper']
+ if $t =~ /^\.$/;
+ return ['close']
+ if $t =~ /^\)$/;
+
+ die "parse error: $t\n" if $t !~ /\(/;
+
+ my @list;
+ while (defined($item = read_expression($in))) {
+ last if $item->[0] eq 'close' or $item->[0] eq 'improper';
+ push @list, $item;
+ }
+
+ die "parse error: right parenthesis or dot expected"
+ if not defined $item;
+
+ my $result;
+ if ($item->[0] eq 'improper') {
+ my $temp;
+
+ die "improper list parse error (missing item)"
+ if not defined($result = read_expression($in));
+ die "improper list parse error (missing parenthesis)"
+ if (not defined($temp = read_expression($in)))
+ or ($temp->[0] ne 'close');
+ }
+ else {
+ $result = Null;
+ }
+ $result = cons($item, $result) while (defined($item = pop @list));
+
+ return $result;
+}
+
+sub display {
+ my ($out, $item, $evalStrings) = @_;
+
+ if ($item->[0] eq 'primitive') {
+ print $out "<primitive>";
+ }
+ elsif ($item->[0] eq 'procedure') {
+ print $out "<procedure ";
+ display($out, $item->[1], $evalStrings);
+ print $out ">";
+ }
+ elsif ($item->[0] eq 'empty') {
+ print $out '()';
+ }
+ elsif ($item->[0] eq 'vector') {
+ my ($count) = (scalar @{ $item->[1] });
+
+ print $out "#(";
+
+ if ($count > 0) {
+ display($out, $item->[1][0], $evalStrings);
+ if ($count > 1) {
+ for (my $index = 1 ; $index < $count ; $index++) {
+ print $out " ";
+ display($out, $item->[1][$index], $evalStrings);
+ }
+ }
+ }
+
+ print $out ")";
+ }
+ elsif ($item->[0] eq 'pair') {
+ print $out "(";
+
+ display($out, car($item), $evalStrings);
+
+ my $rest = $item;
+ while ($rest = cdr($rest), $rest->[0] eq 'pair') {
+ print $out " ";
+ display($out, car($rest), $evalStrings);
+ }
+ if ($rest->[0] ne 'empty') {
+ print $out " . ";
+ display($out, $rest, $evalStrings);
+ }
+
+ print $out ")";
+ }
+ elsif ($item->[0] eq 'close') {
+ die "parse error: extra parenthesis";
+ }
+ elsif ($item->[0] eq 'character' and $evalStrings) {
+ if (defined(my $value = +Characters->{ $item->[1] })) {
+ print $out $value;
+ }
+ else {
+ print $out ($item->[1] =~ /^\#\\(.)/);
+ }
+ }
+ elsif ($item->[0] eq 'string' and !$evalStrings) {
+ print $out "\"$item->[1]\"";
+ }
+ else {
+ print $out $item->[1];
+ }
+
+ return 0;
+}
+
+
+sub do_map {
+ my ($list, $proc, @args) = @_;
+
+ return Null if $list->[0] eq 'empty';
+
+ return cons(&$proc(car($list), @args),
+ do_map(cdr($list), $proc, @args));
+}
+
+sub do_length {
+ my ($len, $list) = (0, @_);
+
+ while ($list->[0] eq 'pair') {
+ $len++;
+ $list = cdr($list);
+ }
+
+ return $len;
+}
+
+sub lookup {
+ my ($symbol, $env) = @_;
+
+ foreach my $e (@$env) {
+ defined(my $value = $e->{$symbol}) or next;
+ return [ $value => $e ];
+ }
+
+ return undef;
+}
+
+sub layer {
+ my ($names, $values, $nextname, $nextval) = @_;
+ my ($name, $value, $l);
+
+ for (
+ $l = {} ;
+ $names->[0] eq 'pair' and $values->[0] eq 'pair' ;
+ $names = $nextname, $values = $nextval
+ )
+ {
+ $name = car($names);
+ $value = car($values);
+ $l->{ $name->[1] } = $value;
+
+ ($nextname, $nextval) = (cdr($names), cdr($values));
+ if ($nextname->[0] eq 'symbol') {
+ $l->{ $nextname->[1] } = $nextval;
+ return $l;
+ }
+ }
+
+ die "malformed argument list"
+ if $names->[0] ne 'empty'
+ or $values->[0] ne 'empty';
+
+ return $l;
+}
+
+my $primitives = {
+ '=' => sub {
+ my ($args, $env) = @_;
+ die "= needs at least two arguments"
+ if do_length($args) < 2;
+
+ local $^W = 0;
+
+ my ($v, $vf, $t) = (car($args));
+ die "= requires numeric arguments"
+ if $v->[0] ne 'integer'
+ and $v->[0] ne 'float';
+ $vf = Math::BigFloat->new($v->[1]);
+ $args = cdr($args);
+
+ while ($args->[0] eq 'pair') {
+ $t = car($args);
+
+ die "= requires numeric arguments"
+ if $t->[0] ne 'integer'
+ and $t->[0] ne 'float';
+ return False
+ if $vf->fcmp(Math::BigFloat->new($t->[1]));
+
+ $args = cdr($args);
+ }
+
+ return True;
+ },
+ '>' => sub {
+ my ($args, $env) = @_;
+ die "= needs at least two arguments"
+ if do_length($args) < 2;
+
+ local $^W = 0;
+
+ my $v = car($args);
+ die "> requires numeric arguments"
+ if $v->[0] ne 'integer'
+ and $v->[0] ne 'float';
+ my $vf = Math::BigFloat->new($v->[1]);
+ $args = cdr($args);
+
+ while ($args->[0] eq 'pair') {
+ my $t = car($args);
+
+ die "> requires numeric arguments"
+ if $t->[0] ne 'integer'
+ and $t->[0] ne 'float';
+ my $tf = Math::BigFloat->new($t->[1]);
+ return False if $vf->fcmp($tf) != 1;
+
+ $args = cdr($args);
+ $vf = $tf;
+ }
+
+ return True;
+ },
+ '<' => sub {
+ my ($args, $env) = @_;
+ die "< needs at least two arguments"
+ if do_length($args) < 2;
+
+ local $^W = 0;
+
+ my $v = car($args);
+ die "> requires numeric arguments"
+ if $v->[0] ne 'integer'
+ and $v->[0] ne 'float';
+ my $vf = Math::BigFloat->new($v->[1]);
+ $args = cdr($args);
+
+ while ($args->[0] eq 'pair') {
+ my $t = car($args);
+
+ die "< requires numeric arguments"
+ if $t->[0] ne 'integer'
+ and $t->[0] ne 'float';
+ my $tf = Math::BigFloat->new($t->[1]);
+ return False if $vf->fcmp($tf) != -1;
+
+ $args = cdr($args);
+ $vf = $tf;
+ }
+
+ return True;
+ },
+ 'eqv?' => sub {
+ my ($args, $env) = @_;
+ die "eqv? needs exactly two arguments"
+ if do_length($args) != 2;
+
+ my ($t1, $t2) = (car($args), car(cdr($args)));
+ return True if $t1 == $t2;
+ return False if $t1->[0] ne $t2->[0];
+
+ return ($t1->[1] eq $t2->[1] ? True : False)
+ if ( $t1->[0] eq 'symbol'
+ or $t1->[0] eq 'string'
+ or $t1->[0] eq 'boolean'
+ or $t1->[0] eq 'character');
+
+ return ($t1->[1] == $t2->[1] ? True : False)
+ if ( $t1->[0] eq 'integer'
+ or $t1->[0] eq 'float');
+
+ return False
+ if ( $t1->[0] eq 'primitive'
+ or $t1->[0] eq 'procedure');
+
+ return True if $t1->[0] eq 'empty';
+
+ die "eqv: couldn't compare objects";
+ },
+ 'eq?' => sub {
+ my ($args, $env) = @_;
+ die "eq? needs exactly two arguments"
+ if do_length($args) != 2;
+
+ my ($t1, $t2) = (car($args), car(cdr($args)));
+ return ($t1 == $t2 ? True : False);
+ },
+ 'make-vector' => sub {
+ my ($args) = @_;
+ my ($len) = do_length($args);
+ die "make-vector: count required; optional fill"
+ if $len < 1;
+ die "make-vector: too many arguments"
+ if $len > 2;
+
+ my $count = car($args);
+ die "make-vector: count must be a non-negative integer"
+ if $count->[0] ne 'integer'
+ or $count->[1] < 0;
+ $args = cdr($args);
+
+ my $fill = ($args->[0] eq 'empty' ? Null : car($args));
+
+ return [ vector => [ ($fill) x $count->[1] ] ];
+ },
+ 'vector-ref' => sub {
+ my ($args) = @_;
+ die "vector-ref needs exactly two arguments"
+ if do_length($args) != 2;
+
+ my $vector = car($args);
+ die "vector-ref: first argument not a vector"
+ if $vector->[0] ne 'vector';
+ $args = cdr($args);
+
+ my $k = car($args);
+ die "vector-ref: second argument not an integer"
+ if $k->[0] ne 'integer';
+ die "vector-ref: second argument out of range"
+ if $k->[1] < 0
+ or $k->[1] >= (scalar @{ $vector->[1] });
+
+ return $vector->[1][ $k->[1] ];
+ },
+ 'vector-set!' => sub {
+ my ($args) = @_;
+ die "vector-set! needs exactly three arguments"
+ if do_length($args) != 3;
+
+ my $vector = car($args);
+ die "vector-set!: first argument not a vector"
+ if $vector->[0] ne 'vector';
+ $args = cdr($args);
+
+ my $k = car($args);
+ die "vector-set!: second argument not an integer"
+ if $k->[0] ne 'integer';
+ die "vector-set!: second argument out of range"
+ if $k->[1] < 0
+ or $k->[1] >= (scalar @{ $vector->[1] });
+ $args = cdr($args);
+
+ my $obj = car($args);
+ $vector->[1][ $k->[1] ] = $obj;
+
+ return $obj;
+ },
+ 'null?' => sub {
+ my ($args) = @_;
+ die "Null? needs exactly one argument"
+ if do_length($args) != 1;
+
+ my $value = car($args);
+ return ($value->[0] eq 'empty' ? True : False);
+ },
+ 'pair?' => sub {
+ my ($args) = @_;
+ die "pair? needs exactly one argument"
+ if do_length($args) != 1;
+
+ my $value = car($args);
+ return ($value->[0] eq 'pair' ? True : False);
+ },
+ 'length' => sub {
+ my ($args) = @_;
+ die "length needs exactly one argument"
+ if do_length($args) != 1;
+
+ return [ 'integer', do_length(car($args)) ];
+ },
+ 'cons' => sub {
+ my ($args) = @_;
+ die "cons needs two arguments"
+ if do_length($args) != 2;
+
+ return cons(car($args), car(cdr($args)));
+ },
+ 'car' => sub {
+ my ($args) = @_;
+ die "car takes a pair as its argument"
+ if do_length($args) != 1
+ or car($args)->[0] ne 'pair';
+
+ return car(car($args));
+ },
+ 'cdr' => sub {
+ my ($args) = @_;
+ die "cdr takes a pair as its argument"
+ if do_length($args) != 1
+ or car($args)->[0] ne 'pair';
+
+ return cdr(car($args));
+ },
+ 'list' => sub {
+ return $_[0];
+ },
+ 'apply' => sub {
+ my ($args, $env) = @_;
+ die "apply requires a procedure and an argument list"
+ if do_length($args) != 2;
+
+ my ($proc, $arglist) = (car($args), car(cdr($args)));
+ die "apply: procedure or primitive required"
+ if $proc->[0] ne 'primitive'
+ and $proc->[0] ne 'procedure';
+ die "apply: argument list required"
+ if $arglist->[0] ne 'pair';
+
+ return &{ $proc->[1] }($arglist, $env)
+ if $proc->[0] eq 'primitive';
+
+ return scheme_sequence($proc->[2],
+ [ layer($proc->[1], $arglist), @{ $proc->[3] } ]);
+ },
+ 'display' => sub {
+ my ($args) = @_;
+
+ display(\*STDOUT, car($args), 1);
+ return Null;
+ },
+ 'newline' => sub {
+ print "\n";
+ return Null;
+ },
+ 'load' => sub {
+ my ($args, $env) = @_;
+ die "load takes a filename as its argument"
+ if do_length($args) != 1;
+
+ my ($name) = (car($args));
+ local *DATA;
+
+ open(DATA, $name->[1]) or die "$name->[1]: $!";
+ while (not eof(DATA)) {
+ my $exp = read_expression(\*DATA);
+ scheme_eval($exp, $env) if defined $exp;
+ }
+ close(DATA);
+
+ return Null;
+ },
+ 'zero?' => sub {
+ my ($args) = @_;
+ local $^W = 0;
+
+ die "zero? needs exactly one argument"
+ if do_length($args) != 1;
+
+ my $value = car($args);
+ die "argument to zero? must be a number"
+ if $value->[0] ne 'integer'
+ and $value->[0] ne 'float';
+
+ ($value->[1] == 0) ? True : False;
+ },
+ 'odd?' => sub {
+ my ($args) = @_;
+
+ die "odd? needs exactly one argument"
+ if do_length($args) != 1;
+
+ my $value = car($args);
+ die "argument to odd? must be an integer"
+ if $value->[0] ne 'integer';
+
+ ($value->[1] % 2) ? True : False;
+ },
+ 'even?' => sub {
+ my ($args) = @_;
+
+ die "even? needs exactly one argument"
+ if do_length($args) != 1;
+
+ my $value = car($args);
+ die "argument to even? must be an integer"
+ if $value->[0] ne 'integer';
+
+ ($value->[1] % 2) ? False : True;
+ },
+ 'remainder' => sub {
+ my ($args) = @_;
+ die "remainder needs exactly two arguments"
+ if do_length($args) != 2;
+
+ my ($v1, $v2) = (car($args), car(cdr($args)));
+ die "remainder needs integer arguments"
+ if $v1->[0] ne 'integer'
+ or $v2->[0] ne 'integer';
+ die "remainder: divide by zero"
+ if $v2->[1] == 0;
+
+ return [ 'integer', $v1->[1] % $v2->[1] ];
+ },
+ 'quotient' => sub {
+ my ($args) = @_;
+ die "quotient needs exactly two arguments"
+ if do_length($args) != 2;
+
+ my ($v1, $v2) = (car($args), car(cdr($args)));
+ die "quotient needs integer arguments"
+ if $v1->[0] ne 'integer'
+ or $v2->[0] ne 'integer';
+ die "quotient: divide by zero"
+ if $v2->[1] == 0;
+
+ return [ 'integer', $v1->[1] / $v2->[1] ];
+ },
+ '+' => sub {
+ my ($args) = @_;
+ my ($is_float, $result) = (0, Math::BigInt->new('0'));
+
+ while ($args->[0] eq 'pair') {
+ my $term = car($args);
+ if ( $term->[0] eq 'integer'
+ or $term->[0] eq 'float')
+ {
+ local $^W = 0;
+
+ if ($term->[0] eq 'float') {
+ if (!$is_float) {
+ $result = Math::BigFloat->new($result);
+ }
+ $is_float = 1;
+ }
+
+ $result += $term->[1];
+ }
+ else {
+ die "arguments to + must be numeric";
+ }
+
+ $args = cdr($args);
+ }
+
+ return [ $is_float ? 'float' : 'integer', $result ];
+ },
+ '-' => sub {
+ my ($args) = @_;
+ my $is_float = 0;
+ local $^W = 0;
+
+ die "- needs at least one argument"
+ if not($args->[0] eq 'pair');
+ my $term = car($args);
+ my $result = (
+ ($term->[0] eq 'integer')
+ ? Math::BigInt->new($term->[1]) :
+ ($term->[0] eq 'float')
+ ? ( ($is_float = 1), Math::BigFloat->new($term->[1]) ) :
+ die "arguments to - must be numeric"
+ );
+ $args = cdr($args);
+
+ if ($args->[0] eq 'empty') {
+ if ($is_float) {
+ return [ 'float', Math::BigFloat->new('0') - $result ];
+ }
+ else {
+ return [ 'integer', Math::BigInt->new('0') - $result ];
+ }
+ }
+
+ while ($args->[0] eq 'pair') {
+ $term = car($args);
+ if ( $term->[0] eq 'integer'
+ or $term->[0] eq 'float')
+ {
+ local $^W = 0;
+
+ if ($term->[0] eq 'float') {
+ if (!$is_float) {
+ $result = Math::BigFloat->new($result);
+ }
+ $is_float = 1;
+ }
+
+ $result -= $term->[1];
+ }
+ else {
+ die "arguments to - must be numeric";
+ }
+
+ $args = cdr($args);
+ }
+
+ return [ $is_float ? 'float' : 'integer', $result ];
+ },
+ '*' => sub {
+ my ($args) = @_;
+ my ($is_float, $result) = (0, Math::BigInt->new('1'));
+
+ while ($args->[0] eq 'pair') {
+ my ($term) = (car($args));
+ if ( $term->[0] eq 'integer'
+ or $term->[0] eq 'float')
+ {
+ local $^W = 0;
+
+ if ($term->[0] eq 'float') {
+ if (!$is_float) {
+ $result = Math::BigFloat->new($result);
+ }
+ $is_float = 1;
+ }
+
+ $result *= $term->[1];
+ }
+ else {
+ die "arguments to * must be numeric";
+ }
+
+ $args = cdr($args);
+ }
+
+ return [ $is_float ? 'float' : 'integer', $result ];
+ },
+ '/' => sub {
+ my ($args) = @_;
+ my $is_float = 0;
+ local $^W = 0;
+
+ die "/ needs at least one argument"
+ if not($args->[0] eq 'pair');
+ my $term = car($args);
+ my $result = (
+ ($term->[0] eq 'integer')
+ ? Math::BigInt->new($term->[1]) :
+ ($term->[0] eq 'float')
+ ? ( ($is_float = 1), Math::BigFloat->new($term->[1]) ) :
+ die "arguments to / must be numeric"
+ );
+ $args = cdr($args);
+
+ if ($args->[0] eq 'empty') {
+ return [ float => (Math::BigFloat->new('1')) / $result ];
+ }
+
+ while ($args->[0] eq 'pair') {
+ $term = car($args);
+ if ( $term->[0] eq 'integer'
+ or $term->[0] eq 'float')
+ {
+ local $^W = 0;
+
+ if ($term->[0] eq 'float') {
+ if (!$is_float) {
+ $result = Math::BigFloat->new($result);
+ }
+ $is_float = 1;
+ }
+
+ $result /= $term->[1];
+ }
+ else {
+ die "arguments to / must be numeric";
+ }
+
+ $args = cdr($args);
+ }
+
+ return [ $is_float ? 'float' : 'integer', $result ];
+ }
+};
+
+my $special_forms = {
+ 'define' => sub {
+ my ($args, $env, $symbol) = @_;
+
+ die "define requires a symbol followed by a scheme form"
+ if do_length($args) != 2
+ or ($symbol = car($args), $symbol->[0] ne 'symbol');
+
+ $env->[0]{ $symbol->[1] } = scheme_eval(car(cdr($args)), $env);
+
+ return Null;
+ },
+ 'set!' => sub {
+ my ($args, $env, $symbol, $what, $value) = @_;
+
+ die "set! requires a symbol followed by a scheme form"
+ if do_length($args) != 2
+ or ($symbol = car($args), $symbol->[0] ne 'symbol');
+
+ $value = scheme_eval(car(cdr($args)), $env);
+ if (defined($what = lookup($symbol->[1], $env))) {
+ $what->[1]{ $symbol->[1] } = $value;
+ }
+ else {
+ $env->[0]{ $symbol->[1] } = $value;
+ }
+
+ return Null;
+ },
+ 'begin' => sub {
+ my ($args, $env) = @_;
+
+ @_ = ($args, $env);
+ goto &scheme_sequence;
+ },
+ 'if' => sub {
+ my ($args, $env) = @_;
+
+ my $cond = scheme_eval(car($args), $env);
+ if (False == $cond) {
+ return Null if do_length($args) < 3;
+ return scheme_eval(car(cdr(cdr($args))), $env);
+ }
+
+ die "if: missing true clause" if do_length($args) < 2;
+ @_ = (car(cdr($args)), $env);
+ goto &scheme_eval;
+ },
+ 'not' => sub {
+ my ($args, $env) = @_;
+ die "not requires exactly one argument" if do_length($args) != 1;
+
+ (False == (scheme_eval(car($args), $env))) ? False : True;
+ },
+ 'and' => sub {
+ my ($args, $env) = @_;
+
+ while ($args->[0] eq 'pair') {
+ return False if False == (scheme_eval(car($args), $env));
+ $args = cdr($args);
+ }
+
+ return True;
+ },
+ 'or' => sub {
+ my ($args, $env) = @_;
+
+ while ($args->[0] eq 'pair') {
+ return True if False != (scheme_eval(car($args), $env));
+ $args = cdr($args);
+ }
+
+ return False;
+ },
+ 'lambda' => sub {
+ my ($args, $env) = @_;
+
+ die "lambda needs an argument list and a procedure body"
+ if do_length($args) < 2;
+
+ return [ 'procedure', car($args), cdr($args), $env ];
+ },
+ 'let' => sub {
+ my ($args, $env) = @_;
+
+ die "let needs a list of bindings and a body"
+ if do_length($args) < 2;
+
+ my ($names, $values);
+ $names = do_map(
+ car($args),
+ sub {
+ my ($form) = @_;
+ my ($name) = car($form);
+
+ die "let: symbol required"
+ if $name->[0] ne 'symbol';
+ $name;
+ }
+ );
+ $values = do_map(
+ car($args),
+ sub {
+ my ($form) = @_;
+ scheme_eval(car(cdr($form)), $env);
+ }
+ );
+
+ @_ = (cdr($args), [ layer($names, $values), @{$env} ]);
+ goto &scheme_sequence;
+ },
+ 'let*' => sub {
+ my ($args, $env) = @_;
+
+ die "let* needs a list of bindings and a body"
+ if do_length($args) < 2;
+
+ my ($curenv) = ($env);
+ for (my $bind = car($args) ; $bind->[0] eq 'pair' ; $bind = cdr($bind)) {
+ my ($name, $form) = (car(car($bind)), car(cdr(car($bind))));
+ my ($value) = (scheme_eval($form, $curenv));
+
+ die "let*: symbol required" if $name->[0] ne 'symbol';
+ $curenv = [ { $name->[1] => $value }, @{$curenv} ];
+ }
+
+ @_ = (cdr($args), $curenv);
+ goto &scheme_sequence;
+ },
+ 'letrec' => sub {
+ my ($args, $env) = @_;
+
+ die "letrec needs a list of bindings and a body" if do_length($args) < 2;
+
+ my ($newlayer) = ({});
+ my ($newenv) = ([ $newlayer, @{$env} ]);
+ for (my $bind = car($args) ; $bind->[0] eq 'pair' ; $bind = cdr($bind)) {
+ my ($name, $form) = (car(car($bind)), car(cdr(car($bind))));
+ my ($value) = (scheme_eval($form, $newenv));
+
+ die "letrec: symbol required" if $name->[0] ne 'symbol';
+ $newlayer->{ $name->[1] } = $value;
+ }
+
+ @_ = (cdr($args), $newenv);
+ goto &scheme_sequence;
+ },
+ 'quote' => sub {
+ my ($args, $env) = @_;
+
+ die "quote needs exactly one argument" if do_length($args) != 1;
+ return car($args);
+ },
+ 'quit' => sub {
+ exit 0;
+ }
+};
+
+sub scheme_sequence {
+ my ($seq, $env) = @_;
+ my $result = Null;
+
+ while ($seq->[0] eq 'pair') {
+ $result = scheme_eval(car($seq), $env);
+ $seq = cdr($seq);
+ }
+
+ return $result;
+}
+
+sub scheme_eval {
+ my ($item, $env, $what) = @_;
+
+ if ($item->[0] eq 'pair') {
+ my $toapply = car($item);
+
+ if ($toapply->[0] eq 'symbol') {
+ if (defined($what = $special_forms->{ $toapply->[1] })) {
+ @_ = (cdr($item), $env);
+ goto &$what;
+ }
+ }
+
+ my $args = do_map(cdr($item), \&scheme_eval, $env);
+
+ $what = scheme_eval(car($item), $env);
+ die "procedure or primitive required"
+ if $what->[0] ne 'primitive'
+ and $what->[0] ne 'procedure';
+
+ if ($what->[0] eq 'primitive') {
+ @_ = ($args, $env);
+ goto &{ $what->[1] };
+ }
+ return scheme_sequence($what->[2],
+ [ layer($what->[1], $args), @{ $what->[3] } ]);
+ }
+ elsif ($item->[0] eq 'symbol') {
+ die "undefined symbol $item->[1]"
+ if not defined($what = lookup($item->[1], $env));
+
+ return $what->[0];
+ }
+
+ return $item;
+}
+
+MAIN: {
+ my $global = {};
+ my $primtyped = {};
+
+ while (my ($pname, $code) = each %$primitives) {
+ $primtyped->{$pname} = [ 'primitive', $code ];
+ }
+
+ print "> ";
+ while (defined(my $res = read_expression(\*STDIN))) {
+ my $value = scheme_eval($res, [ $global, $primtyped ]);
+ display(\*STDOUT, $value, 0);
+ print "\n> ";
+ }
+}
+
More information about the Rt-commit
mailing list