flee@dictionopolis.cs.psu.edu (Felix Lee) (11/28/90)
Below, recurse.pl, a simulation of recursive types in Perl.
recurse.pl introduces Vectors and Tables, which are mostly just
encapsulations of Perl's lists and associative arrays. Vectors and
Tables are represented by strings prefixed by a magic cookie. Any
random string that just happens to have that magic cookie may be
mistaken for a Vector or a Table with strange results. This is an
unavoidable flaw. Hopefully, this will happen rarely.
I don't have any sample code that uses Vectors and Tables, because I
don't seem to have a use for them right now. I'm sure I used to have
one, but it seems to have dropped by the wayside. Well, there's
Scheme-in-Perl? (sp?), but that's not quite a sample piece of code.
sp? was useful experience in building recurse.pl. recurse.pl fell
into place quite quickly. It's very different from what I might have
done a month ago.
Given Vectors, you can build true multidimensional arrays, instead of
using the $; hack. Unfortunately, it's likely to be much slower (Perl
subroutine call overhead is quite large). But you can easily slice
the multidimensional array, which the $; hack doesn't let you do.
--
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: recurse.pl
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'recurse.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'recurse.pl'\"
else
echo shar: Extracting \"'recurse.pl'\" \(4666 characters\)
sed "s/^X//" >'recurse.pl' <<'END_OF_FILE'
X#!/usr/bin/perl
X
X# Recursive types in Perl. $Revision: 1.1 $
X
X# This is an implementation of two recursive types in Perl:
X# Vectors and Tables.
X
X# Vectors and Tables can be carried around like any scalar
X# value in Perl. They're distinguished from other scalar
X# values by a special prefix,
X# "\0*v-" for Vectors, and
X# "\0*t-" for Tables.
X# If you happen to have a string that starts with one of
X# those values, then it may be misinterpreted. This is an
X# unavoidable flaw.
X
X# XXX assumes you haven't mucked with $[.
X
Xpackage recurse;
X
X# $recurse'error
X# Subroutine to call when a typecheck error occurs.
X
X$error = "recurse'die_with_prejudice";
X
Xsub recurse'die_with_prejudice {
X local($where, $what) = @_;
X die "** recurse: invalid arg to $where: $what\n";
X}
X
X
X# &isV($x)
X# Return 1 if $x is a Vector, 0 otherwise.
X
Xsub main'isV {
X @_[0] =~ /^\0\*v-/ || 0;
X}
X
X# &V(@value)
X# Create a new Vector with the given value.
X
Xsub main'V {
X local(*v) = local($z) = @ZV ? pop @ZV : "ZV" . ++$ZV;
X @v = @_;
X "\0*v-" . $z;
X}
X
X# &Vref("name")
X# Create a Vector that's a reference to @name.
X
Xsub main'Vref {
X if (@_[0] =~ /'/) {
X "\0*v-" . @_[0];
X } else {
X "\0*v-" . (caller)[0] . "'" . @_[0];
X }
X}
X
X# &Vfree($v)
X# Reclaim the storage occupied by Vector v.
X
Xsub main'Vfree {
X return do $error('Vfree', @_[0]) if @_[0] !~ /^\0\*v-/;
X local($z) = $';
X push(@ZV, $z) if $z =~ /^ZV\d/;
X local(*v) = $z;
X @v = ();
X}
X
X# &Vval($v)
X# Return Vector v as a list.
X# (In a scalar context, return the length.)
X# &Vval($v, $index, ...)
X# Return a slice of Vector v.
X
Xsub main'Vval {
X return do $error('Vval', @_[0]) if @_[0] !~ /^\0\*v-/;
X local(*v) = $';
X shift @_;
X @_ ? @v[@_] : @v;
X}
X
X# &Vset($v, ($index, $value), ...)
X# Set some values in Vector v.
X
Xsub main'Vset {
X return do $error('Vset', @_[0]) if @_[0] !~ /^\0\*v-/;
X local(*v) = $';
X shift @_;
X @v[shift @_] = shift @_ while @_;
X}
X
X# &Vsplice($v, $start, $length, $value, ...)
X# Replace a segment of Vector v with the given values
X# and return the old value.
X
Xsub main'Vsplice {
X return do $error('Vsplice', @_[0]) if @_[0] !~ /^\0\*v-/;
X local(*v) = $';
X shift @_;
X splice(@v, @_);
X}
X
X# &Vpush($v, $value, ...)
X# Append the given values to Vector v.
X
Xsub main'Vpush {
X return do $error('Vpush', @_[0]) if @_[0] !~ /^\0\*v-/;
X local(*v) = $';
X shift @_;
X push(@v, @_);
X}
X
X# &Vpop($v)
X# Remove and return the last element of Vector v.
X
Xsub main'Vpop {
X return do $error('Vpop', @_[0]) if @_[0] !~ /^\0\*v-/;
X local(*v) = $';
X pop @v;
X}
X
X# &Vshift($v)
X# Remove and return the first element of Vector v.
X
Xsub main'Vshift {
X return do $error('Vshift', @_[0]) if @_[0] !~ /^\0\*v-/;
X local(*v) = $';
X shift @v;
X}
X
X# &Vunshift($v, $value, ...)
X# Prepend the given values to Vector v.
X
Xsub main'Vunshift {
X return do $error('Vunshift', @_[0]) if @_[0] !~ /^\0\*v-/;
X local(*v) = $';
X shift @_;
X unshift(@v, @_);
X}
X
X
X
X# &isT($x)
X# Return 1 if $x is a Table, 0 otherwise.
X
Xsub main'isT {
X @_[0] =~ /\0\*t-/ || 0;
X}
X
X# &T(%value)
X# Return a new Table with the given value.
X
Xsub main'T {
X local(*t) = local($z) = @ZT ? pop @ZT : "\ZT" . ++$ZT;
X %t = @_;
X "\0*t-" . $z;
X}
X
X# &Tref("name")
X# Return a Table that's a reference to %name.
X
Xsub main'Tref {
X if (@_[0] =~ /'/) {
X "\0*t-" . @_[0];
X } else {
X "\0*t-" . (caller)[0] . "'" . @_[0];
X }
X}
X
X# &Tfree($t)
X# Reclaim the storage occupied by Table t.
X
Xsub main'Tfree {
X return do $error('Tfree', @_[0]) if @_[0] !~ /^\0\*t-/;
X local($z) = $';
X push(@ZT, $z) if $z =~ /^ZT\d/;
X local(*t) = $z;
X %t = ();
X}
X
X# &Tset($t, ($key, $value), ...)
X# Set some (key, value) pairs in Table t.
X
Xsub main'Tset {
X return do $error('Tset', @_[0]) if @_[0] !~ /^\0\*t-/;
X local(*t) = $';
X shift @_;
X $t{shift @_} = shift @_ while @_;
X}
X
X# &Tdelete($t, $key, ...)
X# Delete some pairs from Table t.
X
Xsub main'Tdelete {
X return do $error('Tdelete', @_[0]) if @_[0] !~ /^\0\*t-/;
X local(*t) = $';
X shift @_;
X delete $t{shift @_} while @_;
X}
X
X# &Tval($t)
X# Return Table t as a list.
X# &Tval($t, $key, ...)
X# Return a slice of Table t.
X
Xsub main'Tval {
X return do $error('Tval', @_[0]) if @_[0] !~ /^\0\*t-/;
X local(*t) = $';
X shift @_;
X @_ ? @t{@_} : %t;
X}
X
X# &Tkeys($t)
X# Return a list of the keys of Table t.
X
Xsub main'Tkeys {
X return do $error('Tkeys', @_[0]) if @_[0] !~ /^\0\*t-/;
X local(*t) = $';
X keys %t;
X}
X
X# &Tvalues($t)
X# Return a list of the values of Table t.
X
Xsub main'Tvalues {
X return do $error('Tvalues', @_[0]) if @_[0] !~ /^\0\*t-/;
X local(*t) = $';
X values %t;
X}
X
X# &Teach($t)
X# Return the next (key, value) pair from Table t.
X
Xsub main'Teach {
X return do $error('Teach', @_[0]) if @_[0] !~ /^\0\*t-/;
X local(*t) = $';
X each %t;
X}
X
X1;END_OF_FILE
if test 4666 -ne `wc -c <'recurse.pl'`; then
echo shar: \"'recurse.pl'\" unpacked with wrong size!
fi
# end of 'recurse.pl'
fi
echo shar: End of shell archive.
exit 0