--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/DataItem.pm	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,185 @@
+package Language::INTERCAL::DataItem;
+
+# Base class for all data items (Arrays, Numbers, Whirlpool)
+
+# This file is part of CLC-INTERCAL
+
+# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
+
+# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
+# and distribute it is granted provided that the conditions set out in the
+# licence agreement are met. See files README and COPYING in the distribution.
+
+use strict;
+use vars qw($VERSION $PERVERSION);
+($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/DataItem.pm 1.-94.-2") =~ /\s(\S+)$/;
+
+use Carp;
+use Language::INTERCAL::Exporter '1.-94.-2';
+use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
+use vars qw(@EXPORT);
+@EXPORT = qw(_make_subscripts);
+
+# note: _make_subscripts is exported, not accessed by inheriting it,
+# because we sometimes want to call it without an object
+
+sub _make_subscripts {
+    my ($di, $subscripts, $zero_ok) = @_;
+    return () if ! defined $subscripts;
+    if (ref $subscripts) {
+	if (UNIVERSAL::isa($subscripts, 'Language::INTERCAL::Arrays')) {
+	    $subscripts = [ $subscripts->as_list() ];
+	} elsif (UNIVERSAL::isa($subscripts, 'Language::INTERCAL::Numbers')) {
+	    $subscripts = [ $subscripts->number() ];
+	} elsif (ref $subscripts ne 'ARRAY') {
+	    faint(SP_ARRAY, "Subscripts aren't numbers");
+	}
+    } else {
+	$subscripts = [$subscripts];
+    }
+    my @subscripts = ();
+    $zero_ok ||= $di->{zero_ok} if $di;
+    my $min = $zero_ok ? 0 : 1;
+    for my $s (@$subscripts) {
+	if (ref $s) {
+	    UNIVERSAL::isa($s, 'Language::INTERCAL::Numbers')
+		or faint(SP_ARRAY, "Subscript is not a number");
+	    $s = $s->number;
+	    $s < $min || $s > 0xffff
+		and faint(SP_ARRAY, "Subscript out of range");
+	    push @subscripts, $s;
+	} else {
+	    $s =~ /^\d+$/
+		or faint(SP_ARRAY, "Subscript is not a number");
+	    $s < $min || $s > 0xffff
+		and faint(SP_ARRAY, "Subscript out of range");
+	    push @subscripts, $s;
+	}
+    }
+    if ($di) {
+	if (! exists $di->{subscripts}) {
+	    faint(SP_NOARRAY) if @subscripts;
+	    return ();
+	}
+	faint(SP_NODIM) unless @{$di->{subscripts}};
+	@subscripts == @{$di->{subscripts}}
+	    or faint(SP_SUBSIZE, scalar @subscripts,
+				 scalar @{$di->{subscripts}});
+	for (my $i = 0; $i < @subscripts; $i++) {
+	    $subscripts[$i] >= $min
+		or faint(SP_SUBSCRIPT, $subscripts[$i], 'too small');
+	    $subscripts[$i] <= $di->{subscripts}[$i]
+		or faint(SP_SUBSCRIPT, $subscripts[$i],
+			 "is greater than $di->{subscripts}[$i]");
+	}
+    }
+    @subscripts;
+}
+
+sub use {
+    if (@_ == 2) {
+	my ($di, $subs) = @_;
+	if ($di->{overload} && ! $di->{in_overload}) {
+	    $di->{in_overload} = 1;
+	    my $r = &{$di->{overload}}($subs);
+	    delete $di->{in_overload};
+	    return $r;
+	}
+	my @s = _make_subscripts($di, $subs);
+	return $di if ! @s;
+	return $di->_get(\@s);
+    }
+    if (@_ == 3) {
+	my ($di, $subs, $value) = @_;
+	if ($di->{overload} && ! $di->{in_overload}) {
+	    $di->{in_overload} = 1;
+	    my $r = &{$di->{overload}}($subs, $value);
+	    delete $di->{in_overload};
+	    return $r;
+	}
+	my @s = _make_subscripts($di, $subs);
+	return $di->_assign($value) if ! @s;
+	return $di->_store(\@s, $value);
+    }
+    croak "Usage: DATA_ITEM->use(SUBSCRIPTS [, VALUE])";
+}
+
+sub assign {
+    @_ == 2 or croak "Usage: DATA_ITEM->assign(VALUE)";
+    my ($di, $value) = @_;
+    if ($di->{overload} && ! $di->{in_overload}) {
+	$di->{in_overload} = 1;
+	my $r = &{$di->{overload}}([], $value);
+	delete $di->{in_overload};
+	return $r;
+    }
+    return $di->_assign($value);
+}
+
+sub value {
+    @_ == 1 or croak "Usage: DATA_ITEM->value";
+    my ($di) = @_;
+    if ($di->{overload} && ! $di->{in_overload}) {
+	$di->{in_overload} = 1;
+	my $r = &{$di->{overload}}([]);
+	delete $di->{in_overload};
+	return $r;
+    }
+    return $di;
+}
+
+sub store {
+    @_ == 3 or croak "Usage: DATA_ITEM->store(SUBSCRIPTS, VALUE)";
+    my ($di, $subs, $value) = @_;
+    if ($di->{overload} && ! $di->{in_overload}) {
+	$di->{in_overload} = 1;
+	my $r = &{$di->{overload}}($subs, $value);
+	delete $di->{in_overload};
+	return $r;
+    }
+    return $di->_store($subs, $value);
+}
+
+sub get {
+    @_ == 2 or croak "Usage: DATA_ITEM->get(SUBSCRIPTS)";
+    my ($di, $subs) = @_;
+    if ($di->{overload} && ! $di->{in_overload}) {
+	$di->{in_overload} = 1;
+	my $r = &{$di->{overload}}($subs);
+	delete $di->{in_overload};
+	return $r;
+    }
+    return $di->_get($subs);
+}
+
+sub overload {
+    @_ == 2 || @_ == 3
+	or croak "Usage: DATAITEM->overload(SUBSCRIPTS [,CODE])";
+    my ($di, $subs, $code) = @_;
+    defined $code && ref $code ne 'CODE'
+	and croak "CODE is not a code reference";
+    if ($subs && @$subs) {
+	$di->get($subs)->overload(undef, $code);
+    } else {
+	$di->{overload} = $code;
+    }
+    $di;
+}
+
+sub get_overload {
+    @_ == 2 or croak "Usage: DATAITEM->get_overload(SUBSCRIPTS)";
+    my ($di, $subs) = @_;
+    if ($subs && @$subs) {
+	return $di->get($subs)->get_overload(undef);
+    } else {
+	return $di->{overload};
+    }
+}
+
+sub bits {
+    @_ == 1 or croak "Usage: NUMBER->bits";
+    my ($num) = @_;
+    $num->{bits};
+}
+
+1;