Scheme in Perl? (sp?): The Code. Part 2 of 2.

[Felix Lee]

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 at 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 at IPstack = ();
X at 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