Scheme in Perl? (sp?): The Code. Part 1 of 2.
Felix Lee
flee at guardian.cs.psu.edu
Mon Nov 19 18:55:09 AEST 1990
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.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 at ENVcurrent = ();
X$ENVcache = $FALSE;
X at 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
More information about the Alt.sources
mailing list