[alt.sources] Scheme in Perl?

flee@guardian.cs.psu.edu (Felix Lee) (11/19/90)

Just what you've all been waiting for, a Scheme interpreter written in
Perl.  See the Blurb, in a separate article (in comp.lang.perl).

After unpacking parts 1 and 2, you should
	cat sp.pl.part1 sp.pl.part2 > sp.pl
--
Felix Lee	flee@cs.psu.edu

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  sp.pl.part1
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'sp.pl.part1' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'sp.pl.part1'\"
else
echo shar: Extracting \"'sp.pl.part1'\" \(23839 characters\)
sed "s/^X//" >'sp.pl.part1' <<'END_OF_FILE'
X#!/usr/bin/perl
X# Scheme in Perl? (sp?)
X# Public domain. No strings attached.
X
X($version) = '$Revision: 2.6 $' =~ /: (\d+\.\d+)/;
X
X#------
X#-- Basic data types.
X#------
X
X# There are three places that know about data type representation:
X# 1. The &TYPE function.
X# 2. The basic functions for that type in this section.
X# 3. The equivalence routines (eq?, eqv?, and equal?).
X# Any change in representation needs to look at all these.
X
X%TYPEname = ();
X
Xsub TYPES {
X	local($k);
X	for ($k = 0; $k < @_; $k += 2) {
X		@_[$k] = $k;
X		$TYPEname{@_[$k]} = @_[$k + 1];
X	}
X}
X&TYPES( $T_NONE,	'nothing',
X	$T_NIL,		'a null list',
X	$T_BOOLEAN,	'a boolean',
X	$T_NUMBER,	'a number',
X	$T_CHAR,	'a character',
X	$T_STRING,	'a string',
X	$T_PAIR,	'a pair',
X	$T_VECTOR,	'a vector',
X	$T_TABLE,	'a table',
X	$T_SYMBOL,	'a symbol',
X	$T_INPUT,	'an input port',
X	$T_OUTPUT,	'an output port',
X	$T_FORM,	'a special form',
X	$T_SUBR,	'a built-in procedure',
X	# Some derived types.  See &CHKtype.
X	$T_LIST,	'a list',
X	$T_PROCEDURE,	'a procedure',
X	$T_ANY,		'anything');
X
X# Scheme object -> type.
Xsub TYPE {
X	local($_) = @_;
X	if    (/^$/)	{ $T_NIL; }
X	elsif (/^[01]/)	{ $T_BOOLEAN; }
X	elsif (/^N/)	{ $T_NUMBER; }
X	elsif (/^C/)	{ $T_CHAR; }
X	elsif (/^Z'S/)	{ $T_STRING; }
X	elsif (/^Z'P/)	{ $T_PAIR; }
X	elsif (/^Z'V/)	{ $T_VECTOR; }
X	elsif (/^Z'T/)	{ $T_TABLE; }
X	elsif (/^Y/)	{ $T_SYMBOL; }
X	elsif (/^FORM/)	{ $T_FORM; }
X	elsif (/^SUBR/)	{ $T_SUBR; }
X	elsif (/^Z'IP/)	{ $T_INPUT; }
X	elsif (/^Z'OP/)	{ $T_OUTPUT; }
X	else		{ $T_NONE; }
X}
X
X#-- More derived types.
X
X# A closure is a vector that looks like
X#	#(CLOSURE env listarg nargs arg... code...)
X# See &lambda and &applyN.
X$CLOSURE = &Y('CLOSURE');
X
X# A promise is a vector that looks like
X#	#(PROMISE env forced? value code...)
X# See &delay and &force.
X$PROMISE = &Y('PROMISE');
X
X#-- Booleans.
X
X# Scheme booleans and Perl booleans are designed to be equivalent.
X
X$NIL = '';
X$TRUE = 1;
X$FALSE = 0;
X
X#-- Numbers.
X
X# Perl number -> Scheme number.
Xsub N {
X	'N' . @_[0];
X}
X
X# Scheme number -> Perl number.
Xsub Nval {
X	&ERRbad_type(@_[0], $T_NUMBER) if @_[0] !~ /^N/;
X	$';
X}
X
X#-- Characters.
X
X# Perl character -> Scheme character.
Xsub C {
X	'C' . @_[0];
X}
X
X# Scheme character -> Perl character.
Xsub Cval {
X	&ERRbad_type(@_[0], $T_CHAR) if @_[0] !~ /^C/;
X	$';
X}
X
X#-- Strings.
X# Strings are encapsulated so that eqv? works properly.
X
X# Perl string -> Scheme string.
Xsub S {
X	local($sip) = @_;
X	local(*s) = local($z) = "Z'S" . ++$Z'S;
X	$s = $sip;
X	$z;
X}
X
X# Scheme string -> Perl string.
Xsub Sval {
X	&ERRbad_type(@_[0], $T_STRING) if @_[0] !~ /^Z'S/;
X	local(*s) = @_;
X	$s;
X}
X
X# Scheme string <= start, length, new Perl string.
Xsub Sset {
X	&ERRbad_type(@_[0], $T_STRING) if @_[0] !~ /^Z'S/;
X	local(@sip) = @_;
X	local(*s, $p, $l, $n) = @sip;
X	substr($s, $p, $l) = $n;
X}
X
X#-- Pairs and lists.
X
X# Perl vector (A, D) -> Scheme pair (A . D).
Xsub P {
X	local(@sip) = @_;
X	local(*p) = local($z) = "Z'P" . ++$Z'P;
X	@p = @sip;
X	$z;
X}
X
X# Scheme pair (A . D) -> Perl list (A, D).
Xsub Pval {
X	&ERRbad_type(@_[0], $T_PAIR) if @_[0] !~ /^Z'P/;
X	local(*p) = @_;
X	@p;
X}
X
X# Scheme pair (sexp0 . sexp1) <= index, new Scheme value.
Xsub Pset {
X	&ERRbad_type(@_[0], $T_PAIR) if @_[0] !~ /^Z'P/;
X	local(@sip) = @_;
X	local(*p, $k, $n) = @sip;
X	@p[$k] = $n;
X}
X
X# Perl vector -> Scheme list.
Xsub L {
X	local(@v) = @_;
X	local($list) = $NIL;
X	$list = pop @v, pop @v if @v > 2 &&  @v[$#v - 1] eq '.';
X	$list = &P(pop @v, $list) while @v;
X	$list;
X}
X
X# Scheme list -> Perl vector.  XXX Doesn't do improper or recursive lists.
Xsub Lval {
X	local($list) = @_;
X	local($x, @v);
X	while ($list ne $NIL) {
X		($x, $list) = &Pval($list);
X		push(@v, $x);
X	}
X	@v;
X}
X
X#-- Vectors.
X
X# Perl vector -> Scheme vector.
Xsub V {
X	local(@sip) = @_;
X	local(*v) = local($z) = "Z'V" . ++$Z'V;
X	@v = @sip;
X	$z;
X}
X
X# Scheme vector -> Perl vector.
Xsub Vval {
X	&ERRbad_type(@_[0], $T_VECTOR) if @_[0] !~ /^Z'V/;
X	local(*v) = @_;
X	@v;
X}
X
X# Scheme vector <= start, length, new Perl vector.
Xsub Vset {
X	&ERRbad_type(@_[0], $T_VECTOR) if @_[0] !~ /^Z'V/;
X	local(@sip) = @_;
X	local(*v, $s, $l, @n) = @sip;
X	splice(@v, $s, $l, @n);
X}
X
X#-- Tables.
X
X# XXX Tables could use a "default value".
X
X# -> Scheme table.
Xsub T {
X	"Z'T" . ++$Z'T;
X}
X
X# Scheme table, Scheme symbol -> Scheme value.
Xsub Tval {
X	&ERRbad_type(@_[0], $T_TABLE) if @_[0] !~ /^Z'T/;
X	&ERRbad_type(@_[1], $T_SYMBOL) if @_[1] !~ /^Y/;
X	local(*t) = @_;
X	$t{$'};
X}
X
X# Scheme table <= Perl string, new Scheme value.
Xsub Tset {
X	&ERRbad_type(@_[0], $T_TABLE) if @_[0] !~ /^Z'T/;
X	&ERRbad_type(@_[1], $T_SYMBOL) if @_[1] !~ /^Y/;
X	local(@sip) = @_;
X	local(*t) = @sip;
X	$t{$'} = @sip[2];
X}
X
X# Scheme table -> Perl vector of keys.
Xsub Tkeys {
X	&ERRbad_type(@_[0], $T_TABLE) if @_[0] !~ /^Z'T/;
X	local(*t) = @_;
X	keys %t;
X}
X
X#-- Symbols.
X
X%OBLIST = ();
X$OBLIST = &REF("Z'Toblist", 'OBLIST');
X
X# Perl string -> Scheme symbol.
Xsub Y {
X	'Y' . @_[0];
X}
X
X# Scheme symbol -> Perl string.
Xsub Yname {
X	&ERRbad_type(@_[0], $T_SYMBOL) if @_[0] !~ /^Y/;
X	$';
X}
X
X# Scheme symbol -> global Scheme value.
Xsub Yval {
X	&ERRbad_type(@_[0], $T_SYMBOL) if @_[0] !~ /^Y/;
X	$OBLIST{$'};
X}
X
X# Scheme symbol <= new global Scheme value.
Xsub Yset {
X	&ERRbad_type(@_[0], $T_SYMBOL) if @_[0] !~ /^Y/;
X	$OBLIST{$'} = @_[1];
X}
X
X# Perl string symbol name <= new global Scheme value.
Xsub DEF {
X	$OBLIST{@_[0]} = @_[1];
X}
X
X# Create an aliased object.
Xsub REF {
X	local(@sip) = @_;
X	local($a, $b) = @sip;
X	eval "*$a = *$b" || die "ALIAS: $@.\n";
X	$a;
X}
X
X&SUBR0('global-environment');
Xsub global_environment {
X	$OBLIST;
X}
X
X#-- Input and output ports.
X
X%IPbuffer = ();
X
X# Perl string filename -> Scheme input port.
Xsub IP {
X	local($f) = @_;
X	local($z) = "Z'IP" . ++$Z'IP;
X	open($z, "< $f\0") || return $NIL;
X	$IPbuffer{$z} = '';
X	$z;
X}
X
X# Scheme input port -> Perl filehandle.
Xsub IPval {
X	&ERRbad_type(@_[0], $T_INPUT) if @_[0] !~ /^Z'IP/;
X	@_[0];
X}
X
X# Scheme input port => Perl string.
Xsub IPget {
X	&ERRbad_type(@_[0], $T_INPUT) if @_[0] !~ /^Z'IP/;
X	local($ip) = @_;
X	local($_) = $IPbuffer{$ip};
X	$_ ne '' ? ($IPbuffer{$ip} = '') : ($_ = <$ip>);
X	$_;
X}
X
X# Like &IPget, but skip leading whitespace and comments.
Xsub IPgetns {
X	&ERRbad_type(@_[0], $T_INPUT) if @_[0] !~ /^Z'IP/;
X	local($ip) = @_;
X	local($_) = $IPbuffer{$ip};
X	$_ ne '' ? ($IPbuffer{$ip} = '') : ($_ = <$ip>);
X	$_ = <$ip> while $_ ne '' && /^\s*;|^\s*$/;
X	s/^\s+//;
X	$_;
X}
X
X# Scheme input port <= Perl string.
Xsub IPput {
X	&ERRbad_type(@_[0], $T_INPUT) if @_[0] !~ /^Z'IP/;
X	$IPbuffer{@_[0]} .= @_[1];
X}
X
X# Perl string filename -> Scheme output port.
Xsub OP {
X	local($f) = @_;
X	local($z) = "Z'OP" . ++$Z'OP;
X	open($z, "> $f\0") || return $NIL;
X	$z;
X}
X
X# Scheme output port -> Perl filehandle.
Xsub OPval {
X	&ERRbad_type(@_[0], $T_OUTPUT) if @_[0] !~ /^Z'OP/;
X	@_[0];
X}
X
X# Scheme output port <= Perl string.
Xsub OPput {
X	&ERRbad_type(@_[0], $T_OUTPUT) if @_[0] !~ /^Z'OP/;
X	local(@sip) = @_;
X	local($fh) = shift @sip;
X	print $fh @sip;
X}
X
Xsub IOinit {
X	open($stdin  = "Z'IPstdin",  "<& STDIN");
X	open($stdout = "Z'OPstdout", ">& STDOUT");
X	open($stderr = "Z'OPstderr", ">& STDERR");
X	select($stderr); $| = 1;
X	$ttyin  = &IP('/dev/tty');
X	$ttyout = &OP('/dev/tty');
X}
X
Xsub IOshutdown {
X	close($stdin);
X	close($stdout);
X	close($stderr);
X	close($ttyin);
X	close($ttyout);
X}
X
X&SUBR0('standard-input');  sub standard_input  { $stdin;  }
X&SUBR0('standard-output'); sub standard_output { $stdout; }
X&SUBR0('standard-error');  sub standard_error  { $stderr; }
X&SUBR0('terminal-input');  sub terminal_input  { $ttyin;  }
X&SUBR0('terminal-output'); sub terminal_output { $ttyout; }
X
X#-- Special forms.
X
X# Define Scheme special form <= name.
Xsub FORM {
X	local($sub) = local($name) = @_[0];
X	$sub =~ tr/->?!*/_2PIX/;
X	&DEF($name, 'FORM' . $sub);
X}
X
X# Scheme special form -> Perl subroutine name.
Xsub FORMval {
X	&ERRbad_type(@_[0], $T_FORM) if @_[0] !~ /^FORM/;
X	$';
X}
X
X#-- Builtin functions (subrs).
X
X%SUBRmin = ();
X%SUBRmax = ();
X%SUBRtypes = ();
X
X# Define Scheme builtin <= name, minargs, maxargs, type list.
Xsub SUBR {
X	local(@sip) = @_;
X	local($name, $min, $max, @types) = @sip;
X	local($sub) = $name;
X	$sub =~ tr/->?!*/_2PIX/;
X	$SUBRmin{$sub} = $min;
X	$SUBRmax{$sub} = $max;
X	$SUBRtypes{$sub} = pack('L*', @types);
X	&DEF($name, 'SUBR' . $sub);
X}
X
X# Scheme builtin function -> Perl sub name, minargs, maxargs, type list.
Xsub SUBRval {
X	&ERRbad_type(@_[0], $T_SUBR) if @_[0] !~ /^SUBR/;
X	($', $SUBRmin{$'}, $SUBRmax{$'}, unpack('L*', $SUBRtypes{$'}));
X}
X
X# Some convenient aliases...
Xsub SUBR0 { &SUBR(shift, 0, 0); }
Xsub SUBR1 { &SUBR(shift, 1, 1, @_); }
Xsub SUBR2 { &SUBR(shift, 2, 2, @_); }
Xsub SUBR3 { &SUBR(shift, 3, 3, @_); }
Xsub SUBRN { &SUBR(shift, 0, -1, @_); }
X
X# A convenient macro...
Xsub CMP_SUBR {
X	local(@sip) = @_;
X	local($name, $longname, $type, $acc, $cmp) = @sip;
X	local($s) = &SUBR($longname, 0, -1, $type);
X	&DEF($name, $s);
X	eval 'sub ' . (&SUBRval($s))[0] . ' {
X		local(@sip) = @_;
X		local($r) = 1;
X		for (; $r && @sip > 1; shift @sip) {
X			$r = '.$acc.'(@sip[0]) '.$cmp.' '.$acc.'(@sip[1]);
X		}
X		$r;
X	}';
X}
X
X#-- Miscellany.
X
X&SUBR0('*show-memory-use');
Xsub Xshow_memory_use {
X	print $stderr 'memory use: s', $Z'S+0, ' p', $Z'P+0, ' v', $Z'V+0;
X	print $stderr ' t', $Z'T+0, ' ip', $Z'IP+0, ' op', $Z'OP+0;
X	print $stderr "\n";
X}
X
X#------
X#-- Environments and frames.
X#------
X
X# @ENVcurrent is a Perl vector that gets modified in place, for efficiency.
X# $ENVcache is a Scheme vector that's a copy of the current environment.
X
X@ENVcurrent = ();
X$ENVcache = $FALSE;
X@ENVstack = ();
X
X# Returns the current environment.
Xsub ENVcurrent {
X	$ENVcache = &V(@ENVcurrent) if ! $ENVcache;
X	$ENVcache;
X}
X
X# Push to a new environment.
Xsub ENVpush {
X	local($new) = @_;
X	push(@ENVstack, $ENVcache || &V(@ENVcurrent));
X	@ENVcurrent = &Vval($new);
X	$ENVcache = $new;
X}
X
X# Pop to the old environment.
Xsub ENVpop {
X	$ENVcache = pop @ENVstack;
X	@ENVcurrent = &Vval($ENVcache);
X}
X
X# Pop to the global environment.
Xsub ENVreset {
X	@ENVstack = ();
X	$ENVcache = $FALSE;
X	@ENVcurrent = ();
X}
X
X# Get a value from the current environment.
Xsub ENVval {
X	local($sym) = @_;
X	local($x);
X	for $f (@ENVcurrent) {
X		return $x if defined($x = &Tval($f, $sym));
X	}
X	defined($x = &Yval($sym)) || &ERRunbound($sym);
X	$x;
X}
X
X# Set a value in the current environment.
Xsub ENVset {
X	local(@sip) = @_;
X	local($sym, $val) = @sip;
X	local($x);
X	for $f (@ENVcurrent) {
X		return &Tset($f, $sym, $val) if defined($x = &Tval($f, $sym));
X	}
X	return &Yset($sym, $val);
X}
X
X# Push a new frame onto the current environment.
Xsub ENVpush_frame {
X	$ENVcache = $FALSE;
X	unshift(@ENVcurrent, &T());
X}
X
X# Remove the top frame from the current environment.
Xsub ENVpop_frame {
X	$ENVcache = $FALSE;
X	shift @ENVcurrent;
X}
X
X# Bind new values in the top frame of the current environment.
Xsub ENVbind {
X	local(@syms) = @_;
X	local(@vals) = splice(@syms, @syms / 2, @syms / 2);
X	if (@ENVcurrent == 0) {
X		&Yset(shift @syms, shift @vals) while @syms;
X	} else {
X		local($t) = @ENVcurrent[0];
X		&Tset($t, shift @syms, shift @vals) while @syms;
X	}
X}
X
X&DEF('current-environment', &SUBR0('ENVcurrent'));
X
X#------
X#-- Error handling.
X#------
X
Xsub ERR {
X	print $stderr '** ', @_, "\n";
X	goto TOP;
X}
X
Xsub ERRbad_type {
X	local(@sip) = @_;
X	local($it, $what) = @sip;
X	$what = $TYPEname{$what} || "type $what";
X	print $stderr "** Internal type error, $it is not $what.\n";
X	goto TOP;
X}
X
Xsub ERRtype {
X	local(@sip) = @_;
X	local($it, $what, $where) = @_;
X	$what = $TYPEname{$what} || "type $what";
X	print $stderr "** Type error, ";
X	print $stderr "in $where, " if $where ne '';
X	&write($it);
X	print " is not $what.\n";
X	goto TOP;
X}
X
Xsub CHKtype {
X	local(@sip) = @_;
X	local($t0) = &TYPE(@sip[0]);
X	local($t1) = @sip[1];
X	&ERRtype(@_) unless
X		$t1 == $T_ANY ||
X		$t0 == $t1 ||
X		($t1 == $T_LIST &&
X			($t0 == $T_PAIR || $t0 == $T_NIL)) ||
X		($t1 == $T_PROCEDURE &&
X			($t0 == $T_SUBR || $t0 == $T_VECTOR))
X		;
X}
X
Xsub ERRdomain {
X	local(@sip) = @_;
X	local($where) = shift @sip;
X	print $stderr "** Domain error, ";
X	print $stderr "in $where, " if $where ne '';
X	print $stderr @sip, "\n";
X	goto TOP;
X}
X
Xsub ERRunbound {
X	local($sym) = @_;
X	print $stderr '** Symbol ', &Yname($sym), " is unbound.\n";
X	goto TOP;
X}
X
X#------
X#-- Booleans.
X#------
X
X&DEF('t', $TRUE);
X&DEF('nil', $FALSE);
X
X&SUBR1('boolean?');
Xsub booleanP {
X	@_[0] eq $TRUE || @_[0] eq $FALSE;
X}
X
X&SUBR1('not');
Xsub not {
X	@_[0] ? $FALSE : $TRUE;
X}
X
X#------
X#-- Equivalence.
X#------
X
X# Perl ($x eq $y) means the same thing as Scheme (eq? x y).
X
X&SUBR2('eq?');
Xsub eqP {
X	@_[0] eq @_[1];
X}
X
X&SUBR2('eqv?');
Xsub eqvP {
X	return $TRUE if @_[0] eq @_[1];
X	local(@sip) = @_;
X	local($t) = &TYPE(@sip[0]);
X	if ($t != &TYPE(@sip[1])) {
X		$FALSE;
X	} elsif ($t == $T_NUMBER) {
X		&Nval(@sip[0]) == &Nval(@sip[1]);
X	} elsif ($t == $T_STRING) {
X		&Sval(@sip[0]) eq '' && &Sval(@sip[1]) eq '';
X	} elsif ($t == $T_VECTOR) {
X		&Vval(@sip[0]) == 0 && &Vval(@sip[1]) == 0;
X	} else {
X		$FALSE;
X	}
X}
X
X# XXX Fails to terminate for recursive types.
X&SUBR2('equal?');
Xsub equalP {
X	return $TRUE if @_[0] eq @_[1];
X	local(@sip) = @_;
X	local($t) = &TYPE(@sip[0]);
X	if ($t != &TYPE(@sip[1])) {
X		$FALSE;
X	} elsif ($t == $T_STRING) {
X		&Sval(@sip[0]) eq &Sval(@sip[1]);
X	} elsif ($t == $T_PAIR) {
X		local($a0, $d0) = &Pval(@sip[0]);
X		local($a1, $d1) = &Pval(@sip[1]);
X		&equalP($a0, $a1) && &equalP($d0, $d1);
X	} elsif ($t == $T_VECTOR) {
X		local(@v) = &Vval(@sip[0]);
X		local(@u) = &Vval(@sip[1]);
X		return $FALSE if @v != @u;
X		while (@v) {
X			return $FALSE if ! &equalP(shift @v, shift @u);
X		}
X		$TRUE;
X	} else {
X		&eqvP(@sip[0], @sip[1]);
X	}
X}
X
X#------
X#-- Pairs and lists.
X#------
X
X&SUBR1('pair?');
Xsub pairP {
X	&TYPE(@_[0]) == $T_PAIR;
X}
X
X&DEF('cons', &SUBR2('P'));
X
X&SUBR1('car');
Xsub car {
X# XXX Patchlevel 41 broke something; &car(&car($x)) doesn't work if this
X# XXX line is uncommented.
X#	&CHKtype(@_[0], $T_PAIR, 'car');
X	(&Pval(@_[0]))[0];
X}
X
X&SUBR1('cdr', $T_PAIR);
Xsub cdr {
X# XXX See comment for car.
X#	&CHKtype(@_[0], $T_PAIR, 'cdr');
X	(&Pval(@_[0]))[1];
X}
X
X&SUBR2('set-car!', $T_PAIR);
Xsub set_carI {
X	&Pset(@_[0], 0, @_[1]);
X}
X
X&SUBR2('set-cdr!', $T_PAIR);
Xsub set_cdrI {
X	&Pset(@_[0], 1, @_[1]);
X}
X
X&SUBR1('caar'); sub caar { &car(&car(@_[0])); }
X&SUBR1('cadr'); sub cadr { &car(&cdr(@_[0])); }
X&SUBR1('cdar'); sub cdar { &cdr(&car(@_[0])); }
X&SUBR1('cddr'); sub cddr { &cdr(&cdr(@_[0])); }
X
X# XXX caaar and friends.
X
X&SUBR1('null?');
Xsub nullP {
X	@_[0] eq $NIL;
X}
X
X&DEF('list', &SUBRN('L'));
X
X&SUBR1('length', $T_LIST);
Xsub length {
X	local($p) = @_;
X	local($n) = 0;
X	$n += 1, $p = &cdr($p) while $p ne $NIL;
X	&N($n);
X}
X
X&SUBRN('append');
Xsub append {
X	local(@v) = @_;
X	local($p) = pop @v;
X	for $a (reverse @v) {
X		&CHKtype($a, $T_LIST, 'append');
X		for $b (reverse &Lval($a)) {
X			$p = &P($b, $p);
X		}
X	}
X	$p;
X}
X
X&SUBR1('reverse', $T_LIST);
Xsub reverse {
X	&L(reverse(&Lval(@_[0])));
X}
X
X&SUBR2('list-tail', $T_LIST, $T_NUMBER);
Xsub list_tail {
X	local(@sip) = @_;
X	local($p) = @sip[0];
X	local($k) = &Nval(@sip[1]);
X	$p = &cdr($p) while $k--;
X	$p;
X}
X
X&SUBR2('list-ref', $T_LIST, $T_NUMBER);
Xsub list_ref {
X	local(@sip) = @_;
X	local(@v) = &Lval(@sip[0]);
X	local($n) = &Nval(@sip[1]);
X	0 < $n && $n < @v ? @v[$n] : $NIL;	# XXX error?
X}
X
X&SUBR1('last-pair', $T_LIST);
Xsub last_pair {
X	local($p) = @_;
X	local($d);
X	$p = $d while &TYPE($d = &cdr($p)) == $T_PAIR;
X	$p;
X}
X
X&SUBR2('memq', $T_ANY, $T_LIST);
Xsub memq {
X	local(@sip) = @_;
X	local($x, $p) = @sip;
X	local($a, $d);
X	for (; $p ne $NIL; $p = $d) {	# XXX improper lists
X		($a, $d) = &Pval($p);
X		return $p if $x eq $a;
X	}
X	return $FALSE;
X}
X
X&SUBR2('memv', $T_ANY, $T_LIST);
Xsub memv {
X	local(@sip) = @_;
X	local($x, $p) = @sip;
X	local($a, $d);
X	for (; $p ne $NIL; $p = $d) {	# XXX improper lists
X		($a, $d) = &Pval($p);
X		return $p if &eqvP($x, $a);
X	}
X	return $FALSE;
X}
X
X&SUBR2('member', $T_ANY, $T_LIST);
Xsub member {
X	local(@sip) = @_;
X	local($x, $p) = @sip;
X	local($a, $d);
X	for (; $p ne $NIL; $p = $d) {	# XXX improper lists
X		($a, $d) = &Pval($p);
X		return $p if &equalP($x, $a);
X	}
X	return $FALSE;
X}
X
X&SUBR2('assq', $T_ANY, $T_LIST);
Xsub assq {
X	local(@sip) = @_;
X	local($x, $p) = @_;
X	local($a);
X	while ($p ne $NIL) {	# XXX improper lists
X		($a, $p) = &Pval($p);
X		return $a if $x eq &car($a);
X	}
X	return $FALSE;
X}
X
X&SUBR2('assv', $T_ANY, $T_LIST);
Xsub assv {
X	local(@sip) = @_;
X	local($x, $p) = @_;
X	local($a);
X	while ($p ne $NIL) {	# XXX improper lists
X		($a, $p) = &Pval($p);
X		return $a if &eqvP($x, &car($a));
X	}
X	return $FALSE;
X}
X
X&SUBR2('assoc', $T_ANY, $T_LIST);
Xsub assoc {
X	local(@sip) = @_;
X	local($x, $p) = @_;
X	local($a);
X	while ($p ne $NIL) {	# XXX improper lists
X		($a, $p) = &Pval($p);
X		return $a if &equalP($x, &car($a));
X	}
X	return $FALSE;
X}
X
X#------
X#-- Symbols.
X#------
X
X&SUBR1('symbol?');
Xsub symbolP {
X	&TYPE(@_[0]) == $T_SYMBOL;
X}
X
X&SUBR1('symbol->string', $T_SYMBOL);
Xsub symbol_2string {
X	&S(&Yname(@_[0]));
X}
X
X&SUBR1('string->symbol', $T_STRING);
Xsub string_2symbol {
X	&Y(&Sval(@_[0]));
X}
X
X#------
X#-- Numbers.
X#------
X
X&SUBR1('number?');
Xsub numberP {
X	&TYPE(@_[0]) == $T_NUMBER;
X}
X
X&SUBR1('complex?');
Xsub complexP {
X	&TYPE(@_[0]) == $T_NUMBER;
X}
X
X&SUBR1('real?');
Xsub realP {
X	&TYPE(@_[0]) == $T_NUMBER;
X}
X
X&SUBR1('rational?');
Xsub rationalP {
X	&integerP(@_[0]);
X}
X
X&SUBR1('integer?');
Xsub integerP {
X	return $FALSE if &TYPE(@_[0]) != $T_NUMBER;
X	local($n) = &Nval(@_[0]);
X	$n == int($n);
X}
X
X&SUBR1('zero?', $T_NUMBER);
Xsub zeroP {
X	&Nval(@_[0]) == 0;
X}
X
X&SUBR1('positive?', $T_NUMBER);
Xsub positiveP {
X	&Nval(@_[0]) > 0;
X}
X
X&SUBR1('negative?', $T_NUMBER);
Xsub negativeP {
X	&Nval(@_[0]) < 0;
X}
X
X&SUBR1('odd?', $T_NUMBER);
Xsub oddP {
X	&integerP(@_[0]) && (&Nval(@_[0]) & 1) == 1;
X}
X
X&SUBR1('even?', $T_NUMBER);
Xsub evenP {
X	&integerP(@_[0]) && (&Nval(@_[0]) & 1) == 0;
X}
X
X&CMP_SUBR('=', 'number-eq?', $T_NUMBER, '&Nval', '==');
X&CMP_SUBR('<', 'number-lt?', $T_NUMBER, '&Nval', '<');
X&CMP_SUBR('>', 'number-gt?', $T_NUMBER, '&Nval', '>');
X&CMP_SUBR('<=', 'number-le?', $T_NUMBER, '&Nval', '<=');
X&CMP_SUBR('>=', 'number-ge?', $T_NUMBER, '&Nval', '>=');
X
X&SUBR('max', 1, -1, $T_NUMBER);
Xsub max {
X	local(@sip) = @_;
X	local($x) = &Nval(shift @sip);
X	for (; @sip; shift @sip) {
X		$x = &Nval(@sip[0]) if &Nval(@sip[0]) > $x;
X	}
X	&N($x);
X}
X
X&SUBR('min', 1, -1, $T_NUMBER);
Xsub min {
X	local(@sip) = @_;
X	local($x) = &Nval(shift @sip);
X	for (; @sip; shift @sip) {
X		$x = &Nval(@sip[0]) if &Nval(@sip[0]) < $x;
X	}
X	&N($x);
X}
X
X&DEF('+', &SUBRN('add', $T_NUMBER));
Xsub add {
X	local(@sip) = @_;
X	local($x) = 0;
X	$x += &Nval(shift @sip) while @sip;
X	&N($x);
X}
X
X&DEF('-', &SUBR('subtract', 1, -1, $T_NUMBER));
Xsub subtract {
X	local(@sip) = @_;
X	local($x) = &Nval(shift @sip);
X	$x = -$x if !@sip;
X	$x -= &Nval(shift @sip) while @sip;
X	&N($x);
X}
X
X&DEF('*', &SUBRN('multiply', $T_NUMBER));
Xsub multiply {
X	local(@sip) = @_;
X	local($x) = 1;
X	$x *= &Nval(shift @sip) while @sip;
X	&N($x);
X}
X
X&DEF('/', &SUBR('divide', 1, -1, $T_NUMBER));
Xsub divide {
X	local(@sip) = @_;
X	local($x) = &Nval(shift @sip);
X	if (@sip == 0) {
X		&ERRdomain('/', 'division by zero.') if $x == 0;
X		$x = 1 / $x;
X	} else {
X		local($y);
X		while (@sip) {
X			$y = &Nval(shift @sip);
X			&ERRdomain('/', 'division by zero.') if $y == 0;
X			$x /= $y;
X		}
X	}
X	&N($x);
X}
X
X&DEF('1+', &SUBR1('inc', $T_NUMBER));
Xsub inc {
X	&N(&Nval(@_[0]) + 1);
X}
X
X&DEF('-1+', &SUBR1('dec', $T_NUMBER));
Xsub dec {
X	&N(&Nval(@_[0]) - 1);
X}
X
X&SUBR1('abs', $T_NUMBER);
Xsub abs {
X	local($x) = &Nval(@_[0]);
X	&N($x > 0 ? $x : -$x);
X}
X
X&SUBR2('quotient', $T_NUMBER, $T_NUMBER);
Xsub quotient {
X	local(@sip) = @_;
X	local($y) = &Nval(@sip[1]);
X	&ERRdomain('quotient', 'division by zero.') if $y == 0;
X	&N(int(&Nval(@sip[0]) / $y));
X}
X
X&SUBR2('remainder', $T_NUMBER, $T_NUMBER);
Xsub remainder {
X	local(@sip) = @_;
X	local($x) = &Nval(@sip[0]);
X	local($y) = &Nval(@sip[1]);
X	&ERRdomain('remainder', 'division by zero.') if $y == 0;
X	&N($x - $y * int($x / $y));
X}
X
X&SUBR2('modulo', $T_NUMBER, $T_NUMBER);
Xsub modulo {
X	local(@sip) = @_;
X	local($x) = &Nval(@sip[0]);
X	local($y) = &Nval(@sip[1]);
X	&ERRdomain('modulo', 'division by zero.') if $y == 0;
X	local($r) = $x - $y * int($x / $y);
X	$r += $y if ($y < 0 && $r > 0) || ($y > 0 && $r < 0);
X	&N($r);
X}
X
X# XXX SUBR numerator, denominator (rationals)
X
X# XXX SUBR gcd, lcm
X
X&SUBR1('floor', $T_NUMBER);
Xsub floor {
X	local($n) = &Nval(@_[0]);
X	if ($n == int($n)) {
X		&N($n);
X	} else {
X		$n < 0 ? &N($n - 1) : &N($n);
X	}
X}
X
X&SUBR1('ceiling', $T_NUMBER);
Xsub ceiling {
X	local($n) = &Nval(@_[0]);
X	if ($n == int($n)) {
X		&N($n);
X	} else {
X		$n < 0 ? &N($n) : &N($n + 1);
X	}
X}
X
X&SUBR1('truncate', $T_NUMBER);
Xsub truncate {
X	&N(int(&Nval(@_[0])));
X}
X
X&SUBR1('round', $T_NUMBER);
Xsub round {
X	local($n) = &Nval(@_[0]);
X	if ($n + .5 == int($n + .5)) {
X		if ($n < 0) {
X			1 & (-$n - .5) ? &N($n - .5) : &N($n + .5);
X		} else {
X			1 & ($n + .5) ? &N($n - .5) : &N($n + .5);
X		}
X	} else {
X		$n < 0 ? &N(int($n - .5)) : &N(int($n + .5));
X	}
X}
X
X# XXX SUBR rationalize
X
X&SUBR1('exp', $T_NUMBER);
Xsub exp {
X	&N(exp(&Nval(@_[0])));
X}
X
X&SUBR1('log', $T_NUMBER);
Xsub log {
X	local($x) = &Nval(@_[0]);
X	&ERRdomain('log', 'singularity at zero.') if $x == 0;
X	&N(log($x));
X}
X
X&SUBR1('sin', $T_NUMBER);
Xsub sin {
X	&N(sin(&Nval(@_[0])));
X}
X
X&SUBR1('cos', $T_NUMBER);
Xsub cos {
X	&N(cos(&Nval(@_[0])));
X}
X
X&SUBR1('tan', $T_NUMBER);
Xsub tan {
X	local($x) = &Nval(@_[0]);
X	&N(sin($x)/cos($x));	# XXX domain error
X}
X
X&SUBR1('asin', $T_NUMBER);
Xsub asin {
X	local($x) = &Nval(@_[0]);
X	&ERRdomain('asin', $x, ' is not in [-1, 1].') if $x < -1 || $x > 1;
X	&N(atan2($x, sqrt(1 - $x * $x)));
X}
X
X&SUBR1('acos', $T_NUMBER);
Xsub acos {
X	local($x) = &Nval(@_[0]);
X	&ERRdomain('acos', $x, ' is not in [-1, 1].') if $x < -1 || $x > 1;
X	&N(atan2(sqrt(1 - $x * $x), $x));
X}
X
X&SUBR('atan', 1, 2, $T_NUMBER, $T_NUMBER);
Xsub atan {
X	local(@sip) = @_;
X	local($x) = &Nval(@_[0]);
X	local($y) = @_ > 1 ? &Nval(@_[1]) : 1;
X	&N(atan2($x, $y));	# XXX domain error
X}
X
X&SUBR1('sqrt', $T_NUMBER);
Xsub sqrt {
X	&N(sqrt(&Nval(@_[0])));	# XXX domain error
X}
X
X&SUBR2('expt', $T_NUMBER, $T_NUMBER);
Xsub expt {
X	local(@sip) = @_;
X	local($x) = &Nval(@_[0]);
X	local($y) = &Nval(@_[1]);
X	if ($x == 0 && $y == 0) {
X		&N(1);	# required in R3RS.
X	} else {
X		&N($x ** $y);	# XXX domain error.
X	}
X}
X
X# XXX SUBR make-rectangular, make-polar, real-part, imag-part,
X# XXX SUBR magnitude, angle
X# XXX SUBR exact->inexact, inexact->exact
X
X# XXX SUBR number->string, string->number
X
X#------
X#-- Characters.
X#------
X
X&SUBR1('char?');
Xsub charP {
X	&TYPE(@_[0]) == $T_CHAR;
X}
X
X&CMP_SUBR('char=?', 'char-eq?', $T_CHAR, '&Cval', 'eq');
X&CMP_SUBR('char<?', 'char-lt?', $T_CHAR, '&Cval', 'lt');
X&CMP_SUBR('char>?', 'char-gt?', $T_CHAR, '&Cval', 'gt');
X&CMP_SUBR('char<=?', 'char-le?', $T_CHAR, '&Cval', 'le');
X&CMP_SUBR('char>=?', 'char-ge?', $T_CHAR, '&Cval', 'ge');
X
Xsub ciCval {
X	local($_) = &Cval(@_[0]);
X	tr/A-Z/a-z/;
X	$_;
X}
X&CMP_SUBR('char-ci=?', 'char-ci-eq?', $T_CHAR, '&ciCval', 'eq');
X&CMP_SUBR('char-ci<?', 'char-ci-lt?', $T_CHAR, '&ciCval', 'lt');
X&CMP_SUBR('char-ci>?', 'char-ci-gt?', $T_CHAR, '&ciCval', 'gt');
X&CMP_SUBR('char-ci<=?', 'char-ci-le?', $T_CHAR, '&ciCval', 'le');
X&CMP_SUBR('char-ci>=?', 'char-ci-ge?', $T_CHAR, '&ciCval', 'ge');
X
X&SUBR1('char-alphabetic?', $T_CHAR);
Xsub char_alphabeticP {
X	&Cval(@_[0]) =~ /[a-zA-Z]/ ? $TRUE : $FALSE;
X}
X
X&SUBR1('char-numeric?', $T_CHAR);
Xsub char_numericP {
X	&Cval(@_[0]) =~ /[0-9]/ ? $TRUE : $FALSE;
X}
X
X&SUBR1('char-whitespace?', $T_CHAR);
Xsub char_whitespaceP {
X	&Cval(@_[0]) =~ /\s/ ? $TRUE : $FALSE;
X}
X
X&SUBR1('char-upper-case?', $T_CHAR);
Xsub char_upper_caseP {
X	&Cval(@_[0]) =~ /[A-Z]/ ? $TRUE : $FALSE;
X}
X
X&SUBR1('char-lower-case?', $T_CHAR);
Xsub char_lower_caseP {
X	&Cval(@_[0]) =~ /[a-z]/ ? $TRUE : $FALSE;
X}
X
X&SUBR1('char->integer', $T_CHAR);
Xsub char_2integer {
X	&N(ord(&Cval(@_[0])));
X}
X
X&SUBR1('integer->char', $T_NUMBER);
Xsub integer_2char {
X	&C(sprintf("%c", &Nval(@_[0])));
X}
X
X&SUBR1('char-upcase', $T_CHAR);
Xsub char_upcase {
X	local($c) = &Cval(@_[0]);
X	$c =~ tr/a-z/A-Z/;
X	&C($c);
X}
X
X&SUBR1('char-downcase', $T_CHAR);
Xsub char_downcase {
X	local($c) = &Cval(@_[0]);
X	$c =~ tr/A-Z/a-z/;
X	&C($c);
X}
X
END_OF_FILE
if test 23839 -ne `wc -c <'sp.pl.part1'`; then
    echo shar: \"'sp.pl.part1'\" unpacked with wrong size!
fi
# end of 'sp.pl.part1'
fi
echo shar: End of shell archive.
exit 0

flee@guardian.cs.psu.edu (Felix Lee) (11/19/90)

Just what you've all been waiting for, a Scheme interpreter written in
Perl.  See the Blurb, in a separate article (in comp.lang.perl).

After unpacking parts 1 and 2, you should
	cat sp.pl.part1 sp.pl.part2 > sp.pl
--
Felix Lee	flee@cs.psu.edu

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  sp.pl.part2
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'sp.pl.part2' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'sp.pl.part2'\"
else
echo shar: Extracting \"'sp.pl.part2'\" \(20760 characters\)
sed "s/^X//" >'sp.pl.part2' <<'END_OF_FILE'
X#------
X#-- Strings.
X#------
X
X&SUBR1('string?');
Xsub stringP {
X	&TYPE(@_[0]) == $T_STRING;
X}
X
X&SUBR('make-string', 1, 2, $T_NUMBER, $T_CHAR);
Xsub make_string {
X	local(@sip) = @_;
X	local($c) = @sip > 1 ? &Cval(@sip[1]) : '.';
X	&S($c x &Nval(@sip[0]));
X}
X
X&SUBR1('string-length', $T_STRING);
Xsub string_length {
X	&N(length(&Sval(@_[0])));
X}
X
X&SUBR2('string-ref', $T_STRING, $T_NUMBER);
Xsub string_ref {
X	&C(substr(&Sval(@_[0]), &Nval(@_[1]), 1));
X}
X
X&SUBR3('string-set!', $T_STRING, $T_NUMBER, $T_CHAR);
Xsub string_setI {
X	&Sset(@_[0], &Nval(@_[1]), 1, &Cval(@_[2]));	# XXX domain error.
X	$TRUE;
X}
X
X&CMP_SUBR('string=?', 'string-eq?', $T_STRING, '&Sval', 'eq');
X&CMP_SUBR('string<?', 'string-lt?', $T_STRING, '&Sval', 'lt');
X&CMP_SUBR('string>?', 'string-gt?', $T_STRING, '&Sval', 'gt');
X&CMP_SUBR('string<=?', 'string-le?', $T_STRING, '&Sval', 'le');
X&CMP_SUBR('string>=?', 'string-ge?', $T_STRING, '&Sval', 'ge');
X
Xsub ciSval {
X	local($_) = &Sval(@_[0]);
X	tr/A-Z/a-z/;
X	$_;
X}
X&CMP_SUBR('string-ci=?', 'string-ci-eq?', $T_STRING, '&ciSval', 'eq');
X&CMP_SUBR('string-ci<?', 'string-ci-lt?', $T_STRING, '&ciSval', 'lt');
X&CMP_SUBR('string-ci>?', 'string-ci-gt?', $T_STRING, '&ciSval', 'gt');
X&CMP_SUBR('string-ci<=?', 'string-ci-le?', $T_STRING, '&ciSval', 'le');
X&CMP_SUBR('string-ci>=?', 'string-ci-ge?', $T_STRING, '&ciSval', 'ge');
X
X&SUBR3('substring', $T_STRING, $T_NUMBER, $T_NUMBER);
Xsub substring {
X	local(@sip) = @_;
X	local($p) = &Nval(@sip[1]);
X	&S(substr(&Sval(@sip[0]), $p, &Nval(@sip[2]) - $p));
X}
X
X&SUBRN('string-append', $T_STRING);
Xsub string_append {
X	local(@sip) = @_;
X	local($s) = '';
X	$s .= &Sval(shift @sip) while @sip;
X	&S($s);
X}
X
X&SUBR1('string->list', $T_STRING);
Xsub string_2list {
X	local(@sip) = @_;
X	local($p) = $NIL;
X	for $c (reverse split(//, &Sval(@sip[0]))) {
X		$p = &P(&C($c), $p);
X	}
X	$p;
X}
X
X&SUBR1('list->string', $T_LIST);
Xsub list_2string {
X	local($p) = @_;
X	local($s) = '';
X	local($a);
X	while ($p ne $NIL) {	# XXX improper lists.
X		($a, $p) = &Pval($p);
X		&CHKtype($a, $T_CHAR, 'list->string');
X		$s = $s . &Cval($a);
X	}
X	&S($s);
X}
X
X&SUBR1('string-copy', $T_STRING);
Xsub string_copy {
X	&S(&Sval(@_[0]));
X}
X
X&SUBR2('string-fill!', $T_STRING, $T_CHAR);
Xsub string_fillI {
X	local(@sip) = @_;
X	local($s, $c) = @sip;
X	local($len) = length(&Sval($s));
X	&Sset($s, 0, $len, &Cval($c) x $len);
X	$TRUE;
X}
X
X#------
X#-- Vectors.
X#------
X
X&SUBR1('vector?');
Xsub vectorP {
X	&TYPE(@_[0]) == $T_VECTOR;
X}
X
X&SUBR('make-vector', 1, 2, $T_NUMBER);
Xsub make_vector {
X	local(@sip) = @_;
X	local($n) = &Nval(@sip[0]);
X	local($x) = @sip > 1 ? @sip[1] : $FALSE;
X	local(@v);
X	$#v = $n - 1;
X	for $k (@v) { $k = $x; }
X	&V(@v);
X}
X
X&DEF('vector', &SUBRN('V'));
X
X&SUBR1('vector-length', $T_VECTOR);
Xsub vector_length {
X	&N(&Vval(@_[0]) + 0);
X}
X
X&SUBR2('vector-ref', $T_VECTOR, $T_NUMBER);
Xsub vector_ref {
X	(&Vval(@_[0]))[&Nval(@_[1])];
X}
X
X&SUBR3('vector-set!', $T_VECTOR, $T_NUMBER, $T_ANY);
Xsub vector_setI {
X	&Vset(@_[0], &Nval(@_[1]), 1, @_[2]);
X}
X
X&SUBR1('vector-copy', $T_VECTOR);
Xsub vector_copy {
X	&V(&Vval(@_[0]));
X}
X
X&SUBR1('vector->list', $T_VECTOR);
Xsub vector_2list {
X	&L(&Vval(@_[0]));
X}
X
X&SUBR1('list->vector', $T_LIST);
Xsub list_2vector {
X	&V(&Lval(@_[0]));	# XXX improper lists.
X}
X
X#------
X#-- Tables.  (extension)
X#------
X
X&SUBR1('table?');
Xsub tableP {
X	&TYPE(@_[0]) == $T_TABLE;
X}
X
X&DEF('make-table', &SUBR0('T'));
X
X&SUBR3('table-set!', $T_TABLE, $T_SYMBOL);
Xsub table_setI {
X	&Tset(@_[0], @_[1], @_[2]);
X	$TRUE;
X}
X
X&SUBR2('table-ref', $T_TABLE, $T_SYMBOL);
Xsub table_ref {
X	&Tval(@_[0], @_[1]);
X}
X
X&SUBR1('table-keys', $T_TABLE);
Xsub table_keys {
X	local(@v) = &Tkeys(@_[0]);
X	for $k (@v) {
X		$k = &Y($k);
X	}
X	&V(@v);
X}
X
X#------
X#-- Syntactic keywords, special forms.
X#------
X
X$ARROW = &Y('=>');
X$ELSE = &Y('else');
X$QUOTE = &Y('quote');
X$QUASIQUOTE = &Y('quasiquote');
X$UNQUOTE = &Y('unquote');
X$UNQUOTE_SPLICING = &Y('unquote-splicing');
X
X&FORM('quote');
Xsub quote {
X	@_[0];
X}
X
X# XXX wrote quasiquote in a delirium.  it may not work correctly.
X&FORM('quasiquote');
Xsub quasiquote {
X	&QQ(@_[0], 0);
X}
X
Xsub QQ {
X	local(@sip) = @_;
X	local($it, $n) = @sip;
X	local($t) = &TYPE($it);
X	if ($t == $T_VECTOR) {
X		return &QQvector($it, $n);
X	} elsif ($t == $T_PAIR) {
X		return &QQlist($it, $n);
X	} else {
X		return $it;
X	}
X}
X
Xsub QQvector {
X	local(@sip) = @_;
X	local($it, $n) = @sip;
X	return &list_2vector(&QQlist(&vector_2list($it), $n));
X}
X
Xsub QQlist {
X	local(@sip) = @_;
X	local($it, $n) = @sip;
X	local($a, $d) = &Pval($it);
X	if ($a eq $QUASIQUOTE) {
X		return &L($QUASIQUOTE, &QQ(&car($d), $n + 1));
X	} elsif ($a eq $UNQUOTE) {
X		return $n == 0
X			? &eval(&car($d))
X			: &L($UNQUOTE, &QQ(&car($d), $n - 1));
X	}
X
X	if (&pairP($a) && &car($a) eq $UNQUOTE_SPLICING) {
X		$a = ($n == 0)
X			? &eval(&cadr($a))
X			: &L($UNQUOTE_SPLICING, &QQ(&cadr($a), $n - 1));
X	} else {
X		$a = &L(&QQ($a, $n));
X	}
X	if ($d ne $NIL) {
X		return &append($a, &QQ($d, $n));
X	} else {
X		return $a;
X	}
X}
X
X&FORM('delay');
Xsub delay {
X	&V($PROMISE, $NIL, $NIL, &ENVcurrent(), @_);
X}
X
X&FORM('lambda');
Xsub lambda {
X	local(@code) = @_;
X	local($args) = shift @code;
X	local($a, @syms);
X	while (&pairP($args)) {
X		($a, $args) = &Pval($args);
X		&CHKtype($a, $T_SYMBOL, 'lambda');
X		push(@syms, $a);
X	}
X	&CHKtype($args, $T_SYMBOL, 'lambda') if $args ne $NIL;
X	&V($CLOSURE, &ENVcurrent(), $args, &N(@syms + 0), @syms, @code);
X}
X
X# XXX named let form
X&FORM('let');
Xsub let {
X	local(@code) = @_;
X	local(@bindings) = &Lval(shift @code);
X	local(@syms, @vals);
X	for $x (@bindings) {
X		push(@syms, &car($x));
X		push(@vals, &eval(&cadr($x)));
X	}
X	&ENVpush_frame();
X	&ENVbind(@syms, @vals);
X	local($x) = &begin(@code);
X	&ENVpop_frame();
X	$x;
X}
X
X&FORM('let*');
Xsub letX {
X	local(@code) = @_;
X	local(@bindings) = &Lval(shift @code);
X	local($x);
X	&ENVpush(&ENVcurrent());
X	for $b (@bindings) {
X		$x = &eval(&cadr($b));
X		&ENVpush_frame();
X		&ENVbind(&car($b), $x);
X	}
X	$x = &begin(@code);
X	&ENVpop();
X	$x;
X}
X
X&FORM('letrec');
Xsub letrec {
X	local(@code) = @_;
X	local(@bindings) = &Lval(shift @code);
X	local($x, @syms, @vals);
X	for $x (@bindings) {
X		push(@syms, &car($x));
X	}
X	&ENVpush_frame();
X	&ENVbind(@syms, @syms);
X	for $x (@bindings) {
X		push(@vals, &eval(&cadr($x)));
X	}
X	&ENVbind(@syms, @vals);
X	local($x) = &begin(@code);
X	&ENVpop_frame();
X	$x;
X}
X
X&FORM('do');
Xsub do {
X	local(@code) = @_;
X	local($bindings) = shift @code;
X	local($y, $v, $n, @syms, @vals, @nexts);
X	for $x (&Lval($bindings)) {
X		($y, $v, $n) = &Lval($x);
X		if (defined $n) {
X			unshift(@syms, $y);
X			unshift(@vals, &eval($v));
X			unshift(@nexts, $n);
X		} else {
X			push(@syms, $y);
X			push(@vals, &eval($v));
X		}
X	}
X	&ENVpush_frame();
X	&ENVbind(@syms, @vals);
X
X	$#syms = $#nexts;
X
X	local($test, @exit) = &Lval(shift @code);
X
X	while (!&eval($test)) {
X		&begin(@code);
X	} continue {
X		@vals = ();
X		for $x (@nexts) {
X			push(@vals, &eval($x));
X		}
X		&ENVbind(@syms, @vals);
X	}
X	local($x) = &begin(@exit);
X	&ENVpop_frame();
X	$x;
X}
X
X&FORM('set!');
Xsub setI {
X	&CHKtype(@_[0], $T_SYMBOL, 'set!');
X	# XXX argcount, syntax error.
X	# XXX error if unbound?
X	&ENVset(@_[0], &eval(@_[1]));
X	$TRUE;
X}
X
X&FORM('define');
Xsub define {
X	local(@sip) = @_;
X	local($sym) = shift @sip;
X	local($t) = &TYPE($sym);
X	if ($t == $T_SYMBOL) {
X		&ENVbind($sym, &eval(@sip[0]));
X	} elsif ($t == $T_PAIR) {
X		local($args);
X		($sym, $args) = &Pval($sym);
X		&CHKtype($sym, $T_SYMBOL, 'define');
X		&ENVbind($sym, &lambda($args, @sip));
X	} else {
X		&ERRtype($sym, 'a symbol or a pair', 'define');
X	}
X	$TRUE;
X}
X
X&FORM('begin');
Xsub begin {
X	local(@sip) = @_;
X	local($x) = $NIL;
X	$x = &eval(shift @sip) while @sip;
X	$x;
X}
X
X&FORM('and');
Xsub and {
X	local(@sip) = @_;
X	local($x) = $TRUE;
X	$x = &eval(shift @sip) while $x && @sip;
X	$x;
X}
X
X&FORM('or');
Xsub or {
X	local(@sip) = @_;
X	local($x) = $FALSE;
X	$x = &eval(shift @sip) while !$x && @sip;
X	$x;
X}
X
X&FORM('if');
Xsub if {
X	# XXX argcount, syntax error.
X	if (&eval(@_[0])) {
X		&eval(@_[1]);
X	} elsif (@_[2] ne '') {
X		&eval(@_[2]);
X	} else {
X		$NIL;
X	}
X}
X
X&FORM('cond');
Xsub cond {
X	local(@sip) = @_;
X	local($a, $d, $x);
X	for $it (@sip) {
X		&CHKtype($it, $T_PAIR, 'cond');
X		($a, $d) = &Pval($it);
X		if ($a eq $ELSE || ($x = &eval($a))) {
X			&CHKtype($it, $T_PAIR, 'cond');
X			local(@v) = &Lval($d);
X			if (@v[0] eq $ARROW) {
X				# XXX syntax error, @v > 2;
X				return &applyN(&eval(@v[1]), $x);
X			} else {
X				return &begin(@v);
X			}
X		}
X	}
X	return $NIL;
X}
X
X&FORM('case');
Xsub case {
X	local(@sip) = @_;
X	local($x) = &eval(shift @sip);
X	local($a, $d);
X	for $it (@sip) {
X		&CHKtype($it, $T_PAIR, 'case');
X		($a, $d) = &Pval($it);
X		if ($a eq $ELSE || &memv($x, $a)) {	# XXX pair? $a
X			&CHKtype($d, $T_PAIR, 'case');
X			return &begin(&Lval($d));
X		}
X	}
X	return $NIL;
X}
X
X&FORM('*time-execution');
Xsub Xtime_execution {
X	local(@code) = @_;
X	local($x);
X	local($u0, $s0, $cu0, $cs0, $t0);
X	local($u1, $s1, $cu1, $cs1, $t1);
X	$t0 = time;
X	($u0, $s0, $cu0, $cs0) = times;
X	$x = &begin(@code);
X	($u1, $s1, $cu1, $cs1) = times;
X	$t1 = time;
X	printf $stderr "\ntimes: %.3f user, %.3f system, %d:%02d real.\n",
X		$u1 - $u0 + $cu1 - $cu1,
X		$s1 - $s0 + $cs1 - $cu1,
X		($t1 - $t0) / 60, ($t1 - $t0) % 60;
X}
X
X#------
X#-- Input and output ports.
X#------
X
X@IPstack = ();
X@OPstack = ();
X
X$IPcurrent = $stdin;
X$OPcurrent = $stdout;
X
X# Restore I/O to a sane state.
Xsub IOreset {
X	@IPstack = ();
X	@OPstack = ();
X	$IPcurrent = $stdin;
X	$OPcurrent = $stdout;
X	select(&OPval($stdout));
X	$| = 1;
X}
X
X&SUBR1('input-port?');
Xsub input_portP {
X	&TYPE(@_[0]) == $T_INPUT;
X}
X
X&SUBR1('output-port?');
Xsub output_portP {
X	&TYPE(@_[0]) == $T_OUTPUT;
X}
X
X&SUBR0('current-input-port');
Xsub current_input_port {
X	$IPcurrent;
X}
X
X&SUBR0('current-output-port');
Xsub current_output_port {
X	$OPcurrent;
X}
X
X&SUBR2('with-input-from-file', $T_STRING, $T_PROCEDURE);
Xsub with_input_from_file {
X	local(@sip) = @_;
X	local($f) = &IP(&Sval(@sip[0]));
X	return $NIL if !$f;	# XXX open error
X
X	push(@IPstack, $IPcurrent);
X	$IPcurrent = $f;
X	local($x) = &applyN(@sip[1]);
X	$IPcurrent = pop @IPstack;
X	close(&IPval($f));
X	$x;
X}
X
X&SUBR2('with-output-to-file', $T_STRING, $T_PROCEDURE);
Xsub with_output_to_file {
X	local(@sip) = @_;
X	local($f) = &OP(&Sval(@sip[0]));
X	return $NIL if !$f;	# XXX open error.
X
X	push(@OPstack, $OPcurrent);
X	$OPcurrent = $f;
X	local($x) = &applyN(@sip[1]);
X	$OPcurrent = pop @OPstack;
X	close(&OPval($f));
X	$x;
X}
X
X&SUBR1('open-input-file', $T_STRING);
Xsub open_input_file {
X	&IP(&Sval(@_[0]));	# XXX open error.
X}
X
X&SUBR1('open-output-file', $T_STRING);
Xsub open_output_file {
X	&OP(&Sval(@_[0]));	# XXX open error.
X}
X
X&SUBR1('close-input-port', $T_INPUT);
Xsub close_input_port {
X	close(&IPval(@_[0]));	# XXX should destroy port.
X	&IPget(@_[0]);	# flush the input buffer.
X	$TRUE;
X}
X
X&SUBR1('close-output-port', $T_OUTPUT);
Xsub close_output_port {
X	close(&OPval(@_[0]));	# XXX should destroy port.
X	$TRUE;
X}
X
X#------
X#-- Input.
X#------
X
X$EOF = &Y('#EOF');	# eof object.
X
X&SUBR1('eof-object?');
Xsub eof_objectP {
X	@_[0] eq $EOF;
X}
X
X&SUBR('read-char', 0, 1, $T_INPUT);
Xsub read_char {
X	local($ip) = @_ ? @_ : $IPcurrent;
X	local($_) = &IPget($ip);
X	return $EOF if $_ eq '';
X	local($c) = substr($_, 0, 1);
X	&IPput($ip, substr($_, 1, length - 1));
X	&C($c);
X}
X
X&SUBR('char-ready?', 0, 1, $T_INPUT);
Xsub char_readyP {
X	local($ip) = @_ ? @_ : $IPcurrent;
X	$IPbuffer{$ip} ne '';	# XXX shouldn't refer to IPbuffer directly.
X}
X
X&SUBR('read-line', 0, 1, $T_INPUT);	# (extension)
Xsub read_line {
X	local($ip) = @_ ? @_ : $IPcurrent;
X	local($_) = &IPget($ip);
X	$_ eq '' ? $EOF : &S($_);
X}
X
X&SUBR('read', 0, 1, $T_INPUT);
Xsub read {
X	local($ip) = @_ ? @_ : $IPcurrent;
X	local($_) = &IPgetns($ip);
X
X	if ($_ eq '') {
X		$EOF;
X	} elsif (/^\(/) {
X		&IPput($ip, $');
X		&L(&RDvec($ip));
X	} elsif (/^'/) {
X		&IPput($ip, $');
X		&P($QUOTE, &P(&read($ip), $NIL));
X	} elsif (/^`/) {
X		&IPput($ip, $');
X		&P($QUASIQUOTE, &P(&read($ip), $NIL));
X	} elsif (/^,@/) {
X		&IPput($ip, $');
X		&P($UNQUOTE_SPLICING, &P(&read($ip), $NIL));
X	} elsif (/^,/) {
X		&IPput($ip, $');
X		&P($UNQUOTE, &P(&read($ip), $NIL));
X	} elsif (/^"/) {
X		&IPput($ip, $');
X		&S(&RDstring($ip));
X	} elsif (/^#\(/) {
X		&IPput($ip, $');
X		&V(&RDvec($ip));
X	} elsif (/^(#\\\w\w+)\s*/) {
X		local($x) = $1;
X		&IPput($ip, $');
X		&RDtoken($x);
X	} elsif (/^#\\([\0-\377])\s*/) {
X		local($c) = $1;
X		&IPput($ip, $');
X		&C($c);
X	} elsif (/^([^()"',\s]+)\s*/) {
X		local($x) = $1;
X		&IPput($ip, $');
X		&RDtoken($x);
X	} else {
X		&ERR("failure in READ, can't understand $_");
X	}
X}
X
Xsub RDtoken {
X	local($_) = @_;
X	$_ =~ tr/A-Z/a-z/;
X
X	if    (/^\.$/)		{ '.'; }	# read hack.
X	elsif (/^#t$/)		{ $TRUE; }
X	elsif (/^#f$/)		{ $FALSE; }
X	elsif (/^#\\space$/)	{ &C(' '); }
X	elsif (/^#\\newline$/)	{ &C("\n"); }
X	elsif (/^#\\tab$/)	{ &C("\t"); }
X
X	elsif (/^#/) {
X		&ERR("read, bad token $_");
X	} elsif (/^[-+]?(\d+\.?\d*|\d*\.\d+)(e[-+]?\d+)?$/) {
X		&N($_ + 0);
X	} elsif (/^[-+]?(\d+)\/(\d+)$/) {
X		&N($1 / $2);
X	} else {
X		&Y($_);
X	}
X}
X
Xsub RDvec {
X	local($ip) = @_;
X	local($_, @v);
X	while (($_ = &IPgetns($ip)) ne '') {
X		&IPput($ip, $'), last if /^\)\s*/;
X		&IPput($ip, $_);
X		push(@v, &read($ip));
X	}
X	if ($_ eq '') {
X		&ERR("EOF while reading list or vector.");
X	}
X	return @v;
X}
X
Xsub RDstring {
X	local($ip) = @_;
X	local($s) = "";
X	$_ = &IPget($ip);
X	while ($_ ne '') {
X		&IPput($ip, $'), last if /^"\s*/;
X		if (/^\\([\0-\377])/) {
X			$s .= $1; $_ = $';
X		} elsif (/^[^"\\]+/) {
X			$s .= $&; $_ = $';
X		} else {
X			$s .= $_; $_ = '';
X		}
X		$_ = &IPget($ip) if $_ eq '';
X	}
X	return $s;
X}
X
X#------
X#-- Output.
X#------
X
X&SUBR('newline', 0, 1, $T_OUTPUT);
Xsub newline {
X	&OPput(@_ ? @_[0] : $OPcurrent, "\n");
X}
X
X&SUBR('write-char', 1, 2, $T_CHAR, $T_OUTPUT);
Xsub write_char {
X	&OPput(@_ > 1 ? @_[1] : $OPcurrent, &Cval(@_[0]));
X}
X
X$WRquoted = 0;
X%WRmark = ();
X
X&SUBR('write', 1, 2, $T_ANY, $T_OUTPUT);
Xsub write {
X	$WRquoted = 1;
X	&WR(@_);
X}
X
X&SUBR('display', 1, 2, $T_ANY, $T_OUTPUT);
Xsub display {
X	$WRquoted = 0;
X	&WR(@_);
X}
Xsub WR {
X	local(@sip) = @_;
X	local($fh) = &OPval(@_ > 1 ? @_[1] : $OPcurrent);
X	local($oldfh) = select($fh);
X	%WRmark = ();
X	&WR1(@_[0]);
X	select($oldfh);
X	$TRUE;
X}
X
Xsub WR1 {
X	local($it) = @_;
X	local($t) = &TYPE($it);
X	if    ($t == $T_NIL)	{ print '()'; }
X	elsif ($t == $T_BOOLEAN){ print $it ? '#t' : '#f'; }
X	elsif ($t == $T_NUMBER)	{ print &Nval($it); }
X	elsif ($t == $T_CHAR)	{ &WRchar($it); }
X	elsif ($t == $T_SYMBOL)	{ print &Yname($it); }
X	elsif ($t == $T_STRING)	{ &WRstring($it); }
X	elsif ($t == $T_VECTOR)	{ &WRvector($it); }
X	elsif ($t == $T_TABLE)	{ &WRtable($it); }
X	elsif ($t == $T_PAIR)	{ &WRlist($it); }
X
X	elsif ($t == $T_INPUT) {
X		print '#<input port ', &IPval($it), '>';
X	} elsif ($t == $T_OUTPUT) {
X		print '#<output port ', &OPval($it), '>';
X	} elsif ($t == $T_SUBR) {
X		print '#<built-in ', (&SUBRval($it))[0], '>';
X	} elsif ($t == $T_FORM) {
X		print '#<keyword ', (&FORMval($it))[0], '>';
X	} else {
X		print "#<strange object: $it>";
X	}
X}
X
Xsub WRstring {
X	local($s) = &Sval(@_[0]);
X	if (!$WRquoted) {
X		print $s;
X	} else {
X		$s =~ s/\\/\\\\/g;
X		$s =~ s/"/\\"/g;
X		print '"', $s, '"';
X	}
X}
X
Xsub WRchar {
X	local($c) = &Cval(@_[0]);
X	if    (!$WRquoted)	{ print $c; }
X	elsif ($c eq ' ')	{ print '#\space'; }
X	elsif ($c eq "\n")	{ print '#\newline'; }
X	elsif ($c eq "\t")	{ print '#\tab'; }
X	else			{ print "#\\$c"; }
X}
X
X# XXX Can't read a written table.
Xsub WRtable {
X	local($it) = @_;
X	return print '{...}' if $WRmark{$it};
X	$WRmark{$it} += 3;	# strong bias against printing tables again.
X
X	print '{';
X	local(@keys) = &Tkeys($it);
X	if (@keys) {
X		local($k) = pop @keys;
X		print $k, ' => ';
X		&WR1(&Tval($it, &Y($k)));
X	}
X	for $k (@keys) {
X		print ', ', $k, ' => ';
X		&WR1(&Tval($it, &Y($k)));
X	}
X	print '}';
X
X	$WRmark{$it} -= 3;
X}
X
Xsub WRvector {
X	local($it) = @_;
X	return print '#(...)' if $WRmark{$it};
X	++$WRmark{$it};
X
X	local(@v) = &Vval($it);
X	print '#(';
X	&WR1(shift @v) if @v;
X	while (@v) {
X		print ' ';
X		&WR1(shift @v);
X	}
X	print ')';
X
X	--$WRmark{$it};
X}
X
Xsub WRlist {
X	local($it) = @_;
X	return print '(...)' if $WRmark{$it};
X	local(%save) = %WRmark;
X	++$WRmark{$it};
X
X	local($a, $d) = &Pval($it);
X	print "(";
X	&WR1($a);
X	while ($d ne $NIL) {
X		if ($WRmark{$d}) {
X			print ' ...';
X			last;
X		} elsif (&TYPE($d) != $T_PAIR) {
X			print ' . ';
X			&WR1($d);
X			last;
X		} else {
X			++$WRmark{$d};
X			($a, $d) = &Pval($d);
X			print ' ';
X			&WR1($a);
X		}
X	}
X	print ')';
X
X	%WRmark = %save;
X}
X
X#------
X#-- Control features.
X#------
X
X# XXX SUBR call-with-current-continuation
X
X&SUBR1('procedure?');
Xsub procedureP {
X	local($it) = @_;
X	local($t) = &TYPE($it);
X	$t == $T_SUBR ||
X	($t == $T_VECTOR && (&Vval($it))[0] eq $CLOSURE);
X}
X
X&SUBR1('force');
Xsub force {
X	&ERRtype(@_[0], 'a promise', 'force') if &TYPE(@_[0]) ne $T_VECTOR;
X	local($thunk) = @_;
X	local($k, $forced, $val, $env, @code) = &Vval($thunk);
X	&ERRtype($thunk, 'a promise', 'force') if $k ne $PROMISE;
X	if (!$forced) {
X		&ENVpush($env);
X		$val = &begin(@code);
X		&ENVpop();
X		&Vset($thunk, 1, 2, $TRUE, $val);
X	}
X	$val;
X}
X
X&SUBRN('apply');
Xsub apply {
X	local(@sip) = @_;
X	local($f, @args) = @_;
X	&CHKtype(@args[$#args], $T_LIST, 'apply');
X	push(@args, &Lval(pop @args));
X	&applyN($f, @args);
X}
X
Xsub applyN {
X	local(@args) = @_;
X	local($f) = shift @args;
X	local($t) = &TYPE($f);
X
X	if ($t == $T_SUBR) {
X		local($f, $min, $max, @t) = &SUBRval($f);
X		if (@args < $min) {
X			&ERR("Error, $f needs at least $min arguments.");
X		} elsif ($max >= 0 && @args > $max) {
X			&ERR("Error, $f wants at most $max arguments.");
X		}
X		if ($max < 0 && @t[0]) {
X			for $x (@args) {
X				&CHKtype($x, @t[0], $f);
X			}
X		} elsif (@t) {
X			local($k) = $#t < $#args ? $#t : $#args;
X			for (; $k >= 0; --$k) {
X				&CHKtype(@args[$k], @t[$k], $f);
X			}
X		}
X		return do $f (@args);
X
X	} elsif ($t == $T_VECTOR) {
X		local($k, $env, $nsym, $n, @code) = &Vval($f);
X		&ERRtype($f, $T_PROCEDURE, 'applyN') if $k ne $CLOSURE;
X		$n = &Nval($n);
X		if (@args < $n) {
X			&ERR('not enough args to procedure.');
X		} elsif (@args > $n && $nsym eq $NIL) {
X			&ERR('too many args to procedure.');
X		}
X		&ENVpush($env);
X		&ENVpush_frame();
X		if ($n > 0) {
X			&ENVbind(splice(@code, 0, $n), splice(@args, 0, $n));
X		}
X		if ($nsym ne $NIL) {
X			&ENVbind($nsym, &L(@args));
X		}
X		local($x) = &begin(@code);
X		&ENVpop();
X		return $x;
X
X	} else {
X		&ERRtype($f, $T_PROCEDURE, 'applyN');
X	}
X}
X
X&SUBRN('map');
Xsub map {
X	local(@lists) = @_;
X	local($f) = &eval(shift @lists);
X	local(@result, @args, $a);
X	&CHKtype($f, $T_PROCEDURE, 'map');
X	# XXX CHKtype lists. and all lists must be same length.
X	while (@lists[0] ne $NIL) {
X		@args = ();
X		for $x (@lists) {
X			($a, $x) = &Pval($x);
X			push(@args, $a);
X		}
X		push(@result, &applyN($f, @args));
X	}
X	&L(@result);
X}
X
X&SUBRN('for-each');
Xsub for_each {
X	local(@lists) = @_;
X	local($f) = &eval(shift @lists);
X	local(@args, $a);
X	&CHKtype($f, $T_PROCEDURE, 'for-each');
X	# XXX CHKtype lists. and all lists must be same length.
X	while (@lists[0] ne $NIL) {
X		@args = ();
X		for $x (@lists) {
X			($a, $x) = &Pval($x);
X			push(@args, $a);
X		}
X		&applyN($f, @args);
X	}
X	$TRUE;
X}
X
X
Xsub eval {
X	local($it) = @_;
X	local($t) = &TYPE($it);
X
X	if ($t == $T_SYMBOL) {
X		return &ENVval($it);
X	} elsif ($t != $T_PAIR) {
X		return $it;
X	}
X
X	local($f, $args) = &Pval($it);
X
X	$t = &TYPE($f);
X	if ($t == $T_SYMBOL) {
X		$f = &ENVval($f);
X		$t = &TYPE($f);
X	} elsif ($t == $T_PAIR) {
X		$f = &eval($f);
X		$t = &TYPE($f);
X	}
X
X	if ($t == $T_FORM) {
X		$f = &FORMval($f);
X		return do $f (&Lval($args));
X	}
X
X	if ($t != $T_SUBR && $t != $T_VECTOR) {
X		&ERRtype(&car(@_[0]), $T_PROCEDURE, 'eval');
X	}
X
X	local(@args) = &Lval($args);
X	for $a (@args) { $a = &eval($a); }
X	&applyN($f, @args);
X}
X
X#------
X#-- User interface.
X#------
X
X&SUBR1('load', $T_STRING);
Xsub load {
X	local($f) = &Sval(@_[0]);
X	local($ip) = &IP($f . '.sp') || &IP($f) ||
X		&ERR("load, neither $f nor $f.sp found.");
X
X	print $stderr "Loading $f...\n";
X
X	local($x, $y);
X	while (($x = &read($ip)) ne $EOF) {
X		$y = &eval($x);
X	}
X	close(&IPval($ip));
X
X	$y;
X}
X
X# XXX SUBR transcript-on, transcript-off
X
X&SUBR('exit', 0, 1, $T_NUMBER);
Xsub exit {
X	local($x) = @_ ? &Nval(@_[0]) : 0;
X	&DB'prof_dump if defined &DB'prof_dump;
X	exit $x;
X}
X
X&SUBR0('sp-version');
Xsub sp_version {
X	&N($version);
X}
X
Xsub repl {
X	local($x);
X	while {
X		print "> ";
X		$x = &read();
X		$x ne $EOF;
X	} {
X		$x = &eval($x);
X		print "\n";
X		&write($x);
X		print "\n";
X	}
X}
X
X#------
X#-- Main program.
X#------
X
Xsub catch_interrupt {
X	print $stderr "Interrupt\n";
X	goto TOP;	# Not quite a safe thing to do.
X}
X
X$# = '%.15g';	# the default, %.20g, is a little too many digits.
X
XINIT:;
X
X&IOinit();
X
X$TOPjmp = 0;
X
XTOP:;
X
X&IOreset();
X&ENVreset();
X
Xif ($TOPjmp) {
X	print $stderr "\nContinuing from top...\n";
X} else {
X	$TOPjmp = 1;
X	print $stderr "Scheme in Perl? (sp?)\n";
X	print $stderr "  version $version\n";
X}
X
Xif (! @ARGV) {
X	$SIG{'INT'} = 'catch_interrupt';
X	&repl();
X} else {
X	$dodump = (@ARGV[0] eq '-D') && shift @ARGV;
X	for $x (@ARGV) {
X		&load(&S($x));
X	}
X	if ($dodump) {
X		&IOshutdown();
X		dump INIT;
X	}
X}
X
X&exit();
END_OF_FILE
if test 20760 -ne `wc -c <'sp.pl.part2'`; then
    echo shar: \"'sp.pl.part2'\" unpacked with wrong size!
fi
# end of 'sp.pl.part2'
fi
echo shar: End of shell archive.
exit 0