Xref: utzoo comp.lang.perl:3027 alt.sources:2607
Path: utzoo!utgpu!cs.utexas.edu!wuarchive!psuvax1!news
From: flee@guardian.cs.psu.edu (Felix Lee)
Newsgroups: comp.lang.perl,alt.sources
Subject: Scheme in Perl? (sp?):  The Code.  Part 1 of 2.
Message-ID: <Fn$.qb93@cs.psu.edu>
Date: 19 Nov 90 07:55:09 GMT
Sender: news@cs.psu.edu (Usenet)
Followup-To: comp.lang.perl
Organization: Penn State Computer Science
Lines: 1245
Nntp-Posting-Host: guardian.cs.psu.edu

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