#!/usr/bin/perl

###
###Date:         28 Nov 90 10:48:56 GMT
###From:         flee@dictionopolis.cs.psu.edu (Felix Lee)
###Subject:      Recursive types in Perl.
###Organization: Penn State Computer Science
###Newsgroups:   comp.lang.perl
###Message-ID:   <F-ade_g3@cs.psu.edu>
###Nntp-Posting-Host: dictionopolis.cs.psu.edu
###
###
###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
###

# Recursive types in Perl.  $Revision: 1.1 $

# This is an implementation of two recursive types in Perl:
# Vectors and Tables.

# Vectors and Tables can be carried around like any scalar
# value in Perl.  They're distinguished from other scalar
# values by a special prefix,
#	"\0*v-" for Vectors, and
#	"\0*t-" for Tables.
# If you happen to have a string that starts with one of
# those values, then it may be misinterpreted.  This is an
# unavoidable flaw.

# XXX assumes you haven't mucked with $[.

package recurse;

# $recurse'error
#   Subroutine to call when a typecheck error occurs.

$error = "recurse'die_with_prejudice";

sub recurse'die_with_prejudice {
	local($where, $what) = @_;
	die "** recurse: invalid arg to $where: $what\n";
}


# &isV($x)
#   Return 1 if $x is a Vector, 0 otherwise.

sub main'isV {
	@_[0] =~ /^\0\*v-/ || 0;
}

# &V(@value)
#   Create a new Vector with the given value.

sub main'V {
	local(*v) = local($z) = @ZV ? pop @ZV : "ZV" . ++$ZV;
	@v = @_;
	"\0*v-" . $z;
}

# &Vref("name")
#   Create a Vector that's a reference to @name.

sub main'Vref {
	if (@_[0] =~ /'/) {
		"\0*v-" . @_[0];
	} else {
		"\0*v-" . (caller)[0] . "'" . @_[0];
	}
}

# &Vfree($v)
#   Reclaim the storage occupied by Vector v.

sub main'Vfree {
	return do $error('Vfree', @_[0]) if @_[0] !~ /^\0\*v-/;
	local($z) = $';
	push(@ZV, $z) if $z =~ /^ZV\d/;
	local(*v) = $z;
	@v = ();
}

# &Vval($v)
#   Return Vector v as a list.
#   (In a scalar context, return the length.)
# &Vval($v, $index, ...)
#   Return a slice of Vector v.

sub main'Vval {
	return do $error('Vval', @_[0]) if @_[0] !~ /^\0\*v-/;
	local(*v) = $';
	shift @_;
	@_ ? @v[@_] : @v;
}

# &Vset($v, ($index, $value), ...)
#   Set some values in Vector v.

sub main'Vset {
	return do $error('Vset', @_[0]) if @_[0] !~ /^\0\*v-/;
	local(*v) = $';
	shift @_;
	@v[shift @_] = shift @_ while @_;
}

# &Vsplice($v, $start, $length, $value, ...)
#   Replace a segment of Vector v with the given values
#   and return the old value.

sub main'Vsplice {
	return do $error('Vsplice', @_[0]) if @_[0] !~ /^\0\*v-/;
	local(*v) = $';
	shift @_;
	splice(@v, @_);
}

# &Vpush($v, $value, ...)
#   Append the given values to Vector v.

sub main'Vpush {
	return do $error('Vpush', @_[0]) if @_[0] !~ /^\0\*v-/;
	local(*v) = $';
	shift @_;
	push(@v, @_);
}

# &Vpop($v)
#   Remove and return the last element of Vector v.

sub main'Vpop {
	return do $error('Vpop', @_[0]) if @_[0] !~ /^\0\*v-/;
	local(*v) = $';
	pop @v;
}

# &Vshift($v)
#   Remove and return the first element of Vector v.

sub main'Vshift {
	return do $error('Vshift', @_[0]) if @_[0] !~ /^\0\*v-/;
	local(*v) = $';
	shift @v;
}

# &Vunshift($v, $value, ...)
#   Prepend the given values to Vector v.

sub main'Vunshift {
	return do $error('Vunshift', @_[0]) if @_[0] !~ /^\0\*v-/;
	local(*v) = $';
	shift @_;
	unshift(@v, @_);
}



# &isT($x)
#   Return 1 if $x is a Table, 0 otherwise.

sub main'isT {
	@_[0] =~ /\0\*t-/ || 0;
}

# &T(%value)
#   Return a new Table with the given value.

sub main'T {
	local(*t) = local($z) = @ZT ? pop @ZT : "\ZT" . ++$ZT;
	%t = @_;
	"\0*t-" . $z;
}

# &Tref("name")
#   Return a Table that's a reference to %name.

sub main'Tref {
	if (@_[0] =~ /'/) {
		"\0*t-" . @_[0];
	} else {
		"\0*t-" . (caller)[0] . "'" . @_[0];
	}
}

# &Tfree($t)
#   Reclaim the storage occupied by Table t.

sub main'Tfree {
	return do $error('Tfree', @_[0]) if @_[0] !~ /^\0\*t-/;
	local($z) = $';
	push(@ZT, $z) if $z =~ /^ZT\d/;
	local(*t) = $z;
	%t = ();
}

# &Tset($t, ($key, $value), ...)
#   Set some (key, value) pairs in Table t.

sub main'Tset {
	return do $error('Tset', @_[0]) if @_[0] !~ /^\0\*t-/;
	local(*t) = $';
	shift @_;
	$t{shift @_} = shift @_ while @_;
}

# &Tdelete($t, $key, ...)
#   Delete some pairs from Table t.

sub main'Tdelete {
	return do $error('Tdelete', @_[0]) if @_[0] !~ /^\0\*t-/;
	local(*t) = $';
	shift @_;
	delete $t{shift @_} while @_;
}

# &Tval($t)
#   Return Table t as a list.
# &Tval($t, $key, ...)
#   Return a slice of Table t.

sub main'Tval {
	return do $error('Tval', @_[0]) if @_[0] !~ /^\0\*t-/;
	local(*t) = $';
	shift @_;
	@_ ? @t{@_} : %t;
}

# &Tkeys($t)
#   Return a list of the keys of Table t.

sub main'Tkeys {
	return do $error('Tkeys', @_[0]) if @_[0] !~ /^\0\*t-/;
	local(*t) = $';
	keys %t;
}

# &Tvalues($t)
#   Return a list of the values of Table t.

sub main'Tvalues {
	return do $error('Tvalues', @_[0]) if @_[0] !~ /^\0\*t-/;
	local(*t) = $';
	values %t;
}

# &Teach($t)
#   Return the next (key, value) pair from Table t.

sub main'Teach {
	return do $error('Teach', @_[0]) if @_[0] !~ /^\0\*t-/;
	local(*t) = $';
	each %t;
}

1;
