Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/DataItem.pm @ 12511:1c41c70a24da draft default tip
<int-e> mkx ../bin/tio//<<<"$@" sed \'s=.*##==\' | tr @- ++ | base64 -d 2>/dev/null | cat <(printf "\\x1f\\x8b\\x08\\x00\\x00\\x00\\x00\\x00\\x00\\x00") - | gzip -dq 2>/dev/null | LC_CTYPE=C sed -zE \'s=.*\\xFF\\xFF(.*)\\xFF\\xFF.*=\\1=\'
author | HackEso <hackeso@esolangs.org> |
---|---|
date | Sun, 04 Aug 2024 19:18:25 +0100 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;