[comp.lang.perl] Scheme in Perl?

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

0.  Scheme in Perl?

Why would anyone want to write a Scheme interpreter in Perl?  I have
no idea.  But here it is anyway.

Scheme is small, simple, and elegant; Perl is bloated, complex, and
obscene.  The wedding of the two makes an uncomfortable marriage, but
it seems to work.  Perhaps opposites attract.

I call the interpreter "sp?", for no good reason.

sp? may need Perl 3.0 patchlevel 37.  I've tried to avoid egregious
new-isms, but sp? may tickle bugs in earlier Perls.  sp? definitely
doesn't work with patchlevel 18, reason unknown.


1.  The sp? Interpreter.

If sp? does not much resemble traditional Schemes like MIT Scheme,
that is entirely my fault.  I have never written any serious
applications in Scheme.  My knowledge of Scheme is bookish, hardly
practical.  I learned Scheme from the inside out while writing sp?.

I wrote sp? using the Revised**3 Report on Scheme.  sp? is not a
complete Scheme implementation, but I included as much of R3RS as I
easily could.  Here's what's missing:

sp? is not properly tail recursive.  Tail recursive calls can exhaust
both heap and stack storage.  Adding garbage collection will save the
heap, but saving the stack requires removing internal recursion since
Perl doesn't have any sort of longjmp or throw.

sp? doesn't have call-with-current-continuation.  This also requires
removing internal recursion.

sp? has half-hearted number support.  No complex numbers, rationals,
or integers; only real numbers.  No distinction between exact and
inexact numbers.  The reader doesn't recognize full number syntax.
Adding full-hearted support will just take a little work.  Plugging in
the new bignum packages should be trivial.


2.  Structural Defects.

sp? isn't quite perfect.  The defects are few and enumerable.  Major
flaws are listed below.  Minor flaws are marked in the code with XXX.

sp? is probably buggy.  I have a small regression testing suite to
help stabilize sp?'s behavior, but it's woefully incomplete.  Major
features like lambda and let have been well tested; it's the small
things like asin and acos that are likely to fail.

sp? is a great monolith that should be fragmented.  It might be nice
to abstract a small module for recursive data types usable by other
Perl programs.  (Doing recursive data types in Perl was part of the
motivation for writing sp?.)

sp? is slower than continental drift.  Earlier versions were slower
than proton decay.  Anybody want to run some benchmarks?

sp? lacks garbage collection.  Hooray for virtual memory.

sp? doesn't have error handling.  When an error occurs, sp? prints a
cryptic message and then calls the top.  Perl doesn't do unwinding on
non-local gotos, so errors consume unrecoverable memory.

sp? lacks tracing and debugging support, making it difficult to debug
non-trivial Scheme code.

sp? needs more hooks from Scheme to Perl.  File and system services
are lacking.  Regexp/pattern matching would be nice.

sp? is inadequately documented, both internally and externally.

sp? is about due for another once-through rewrite.


3.  The Perils of Perl.

Perl may be good for rapid prototyping, but it was the wrong language
to write a Scheme interpreter in.  Most of the problem is the lack of
types in Perl.  Imposing a type system is a non-trivial task.  It took
several false starts before I settled on the current system, which is
pretty simple and relatively (ugh) fast.

Perl's aggregate datatypes are crippled by being non-recursive: you
can't have vectors of vectors or tables of vectors.  Recursive types
in Perl can be done by using references, but this is fraught with
danger.  References in Perl are a little fragile; early versions of
sp? tended to crash Perl, due to subtle synergistic interactions
(bugs).  The current incarnation of sp? is fairly robust.

Another headache was a phenomenon I call "variable suicide".  Consider
the following Perl fragment:
	sub add { local($a, $b) = @_; return $a + $b; }
	$a = 2;
	print &add(40, $a);
This prints "80", instead of "42".  It's a nasty bit of interaction
between local() and @_.  To avoid it, sp? is sprinkled with code like
	local(@sip) = @_;
	local($a, $b, $c) = @sip;

And writing some of the numeric functions like modulo and round was
much harder than it had to be.  Perl has only token number support.


4.  The Next Generation.

It's easy to find possible speed improvements in almost any section of
sp?, but I doubt the lot of them will make much difference.  sp? will
still be much much slower than useful.

Munching Scheme code some more may help.  Lambdas could be compiled to
pseudo-machine code or translated to Perl and eval'ed.

And when the Scheme code is all munched up, sp? can support proper
tail recursion and continuations.

Fuller Scheme support and better compatibility with MIT Scheme would
be nice.  Imagine sp? running EDWIN.  Imagine an editor many orders of
magnitude slower than GNU Emacs.

And sp? could use garbage collection, for those without terabytes of
virtual memory and swap space.  It would be nice if Perl itself had
garbage collection.  Garbage collection is actually quite urgent with
I/O ports, since each stranded I/O port may claim one file descriptor.
64 file descriptors can be exhausted quite quickly.

Don't expect any of this anytime soon.  I'm done playing with sp? for
now.  Feel free to muck with sp? yourself.  Bug me if you come up with
anything interesting.

Next time, a Perl compiler...  Turn your nasty, slow Perl programs
into nasty, slow C programs.
--
Felix Lee	flee@cs.psu.edu

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

lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (11/20/90)

Madness.

Larry

tchrist@convex.COM (Tom Christiansen) (11/20/90)

In article <Fu+vkb93@cs.psu.edu> flee@guardian.cs.psu.edu (Felix Lee) writes:
> Perl's aggregate datatypes are crippled by being non-recursive: you
> can't have vectors of vectors or tables of vectors.  Recursive types
> in Perl can be done by using references, but this is fraught with
> danger. 

    Perl isn't about nested data structures.  It prefers flat data
    structures.  Perl is more like a chainsaw than a jig saw.  Or think of
    Perl as a bigger hammer.  It lets you treat everything like a nail, and
    get away with it most of the time.  But sometimes not.

                                Larry Wall in 7577@jpl-devvax.JPL.NASA.GOV

Sounds like you're the "sometimes not" case.

Of course, there's also this to consider :-)

    The trick is to use Perl's strengths rather than its weaknesses.

				Larry Wall in 8225@jpl-devvax.JPL.NASA.GOV

You might also check out Larry's excellent response to Don Libes in 
<8497@jpl-devvax.JPL.NASA.GOV>.  It's kind of an "apologia pro perl"
that describes Perl's weaknesses.  This is one of them.

> Another headache was a phenomenon I call "variable suicide".  Consider
> the following Perl fragment:
> 	sub add { local($a, $b) = @_; return $a + $b; }
> 	$a = 2;
> 	print &add(40, $a);
> This prints "80", instead of "42".  It's a nasty bit of interaction
> between local() and @_.  To avoid it, sp? is sprinkled with code like
> 	local(@sip) = @_;
> 	local($a, $b, $c) = @sip;

This is truly unsettling to me.  I hope Larry declares it a bug and fixes
it.  Or declares both of us confused. To me a program shouldn't have to
know anything about a library routine's choice identifiers.

Your scheme stuff sounds like a significant piece of work, and probably a
great program as well.  If I'd ever need Scheme, I'll be sure to check it out.

--tom

schwartz@groucho.cs.psu.edu (Scott Schwartz) (11/20/90)

lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) writes:

   Madness.

Just a day in the life here at PSU.  Hey Felix, can I have my copy of
R3RS back now?  I'll trade you _Common Lispcraft_ for it....

domo@tsa.co.uk (Dominic Dunlop) (11/20/90)

In article <10463@jpl-devvax.JPL.NASA.GOV> lwall@jpl-devvax.JPL.NASA.GOV
(Larry Wall) writes:
> Madness.

Maybe.  Until somebody tells me what Scheme is, I won't be able to make
a judgement.
-- 
Dominic Dunlop

lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (11/21/90)

In article <108984@convex.convex.com> tchrist@convex.COM (Tom Christiansen) writes:
: In article <Fu+vkb93@cs.psu.edu> flee@guardian.cs.psu.edu (Felix Lee) writes:
: > Another headache was a phenomenon I call "variable suicide".  Consider
: > the following Perl fragment:
: > 	sub add { local($a, $b) = @_; return $a + $b; }
: > 	$a = 2;
: > 	print &add(40, $a);
: > This prints "80", instead of "42".  It's a nasty bit of interaction
: > between local() and @_.  To avoid it, sp? is sprinkled with code like
: > 	local(@sip) = @_;
: > 	local($a, $b, $c) = @sip;
: 
: This is truly unsettling to me.  I hope Larry declares it a bug and fixes
: it.  Or declares both of us confused. To me a program shouldn't have to
: know anything about a library routine's choice identifiers.

It's definitely a bug.  The trouble is that there's an easy but expensive
fix, and a hard but inexpensive fix, and I'm like the donkey stuck between
two bales of hay.  I suppose I should do the easy one as a stopgap...

Larry

jim@math.psu.edu (Jim Duncan) (11/21/90)

In article <F!$=v=93@cs.psu.edu> schwartz@groucho.cs.psu.edu (Scott Schwartz) writes:

   lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) writes:

      Madness.

   Just a day in the life here at PSU.  Hey Felix, can I have my copy of
   R3RS back now?  I'll trade you _Common Lispcraft_ for it....


Just wait till you see my perl interpreter written in perl.

	Jim

--
   Jim Duncan <jim@math.psu.edu> Penn State Math Dept Systems Administrator
    ``Computers are like Old Testament gods; lots of rules and no mercy.''
						Joseph Campbell

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

>Maybe.  Until somebody tells me what Scheme is, I won't be able to
>make a judgement.

I've mostly written a short introduction to Scheme that I might post
sometime after Thanksgiving.  Basically, Scheme is a Lisp dialect that
has a number of simple yet remarkably powerful features.
--
Felix Lee	flee@cs.psu.edu

oz@yunexus.yorku.ca (Ozan Yigit) (11/23/90)

In article <108984@convex.convex.com> tchrist@convex.COM
(Tom Christiansen) writes:

>Your scheme stuff sounds like a significant piece of work, and probably a
>great program as well.  If I'd ever need Scheme, I'll be sure to check it out.

While scheme-in-perl is interesting as an exercise in absurdity :-), you
really ought to check out a serious R^nRS scheme implementation if you
want scheme. There are excellent implementations out there. Easily
accessible ones would be elk, xscheme, fools-lisp, Scheme->C, siod, etc.
for example. [some of these are not very hard to extend with facilities
similar to that of perl ;-)]

oz
---
Where the stream runneth smoothest,   | Internet: oz@nexus.yorku.ca 
the water is deepest.  - John Lyly    | UUCP: utzoo/utai!yunexus!oz