|
996
|
1 package Language::INTERCAL::DataItem;
|
|
|
2
|
|
|
3 # Base class for all data items (Arrays, Numbers, Whirlpool)
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/DataItem.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
19 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
20 use vars qw(@EXPORT);
|
|
|
21 @EXPORT = qw(_make_subscripts);
|
|
|
22
|
|
|
23 # note: _make_subscripts is exported, not accessed by inheriting it,
|
|
|
24 # because we sometimes want to call it without an object
|
|
|
25
|
|
|
26 sub _make_subscripts {
|
|
|
27 my ($di, $subscripts, $zero_ok) = @_;
|
|
|
28 return () if ! defined $subscripts;
|
|
|
29 if (ref $subscripts) {
|
|
|
30 if (UNIVERSAL::isa($subscripts, 'Language::INTERCAL::Arrays')) {
|
|
|
31 $subscripts = [ $subscripts->as_list() ];
|
|
|
32 } elsif (UNIVERSAL::isa($subscripts, 'Language::INTERCAL::Numbers')) {
|
|
|
33 $subscripts = [ $subscripts->number() ];
|
|
|
34 } elsif (ref $subscripts ne 'ARRAY') {
|
|
|
35 faint(SP_ARRAY, "Subscripts aren't numbers");
|
|
|
36 }
|
|
|
37 } else {
|
|
|
38 $subscripts = [$subscripts];
|
|
|
39 }
|
|
|
40 my @subscripts = ();
|
|
|
41 $zero_ok ||= $di->{zero_ok} if $di;
|
|
|
42 my $min = $zero_ok ? 0 : 1;
|
|
|
43 for my $s (@$subscripts) {
|
|
|
44 if (ref $s) {
|
|
|
45 UNIVERSAL::isa($s, 'Language::INTERCAL::Numbers')
|
|
|
46 or faint(SP_ARRAY, "Subscript is not a number");
|
|
|
47 $s = $s->number;
|
|
|
48 $s < $min || $s > 0xffff
|
|
|
49 and faint(SP_ARRAY, "Subscript out of range");
|
|
|
50 push @subscripts, $s;
|
|
|
51 } else {
|
|
|
52 $s =~ /^\d+$/
|
|
|
53 or faint(SP_ARRAY, "Subscript is not a number");
|
|
|
54 $s < $min || $s > 0xffff
|
|
|
55 and faint(SP_ARRAY, "Subscript out of range");
|
|
|
56 push @subscripts, $s;
|
|
|
57 }
|
|
|
58 }
|
|
|
59 if ($di) {
|
|
|
60 if (! exists $di->{subscripts}) {
|
|
|
61 faint(SP_NOARRAY) if @subscripts;
|
|
|
62 return ();
|
|
|
63 }
|
|
|
64 faint(SP_NODIM) unless @{$di->{subscripts}};
|
|
|
65 @subscripts == @{$di->{subscripts}}
|
|
|
66 or faint(SP_SUBSIZE, scalar @subscripts,
|
|
|
67 scalar @{$di->{subscripts}});
|
|
|
68 for (my $i = 0; $i < @subscripts; $i++) {
|
|
|
69 $subscripts[$i] >= $min
|
|
|
70 or faint(SP_SUBSCRIPT, $subscripts[$i], 'too small');
|
|
|
71 $subscripts[$i] <= $di->{subscripts}[$i]
|
|
|
72 or faint(SP_SUBSCRIPT, $subscripts[$i],
|
|
|
73 "is greater than $di->{subscripts}[$i]");
|
|
|
74 }
|
|
|
75 }
|
|
|
76 @subscripts;
|
|
|
77 }
|
|
|
78
|
|
|
79 sub use {
|
|
|
80 if (@_ == 2) {
|
|
|
81 my ($di, $subs) = @_;
|
|
|
82 if ($di->{overload} && ! $di->{in_overload}) {
|
|
|
83 $di->{in_overload} = 1;
|
|
|
84 my $r = &{$di->{overload}}($subs);
|
|
|
85 delete $di->{in_overload};
|
|
|
86 return $r;
|
|
|
87 }
|
|
|
88 my @s = _make_subscripts($di, $subs);
|
|
|
89 return $di if ! @s;
|
|
|
90 return $di->_get(\@s);
|
|
|
91 }
|
|
|
92 if (@_ == 3) {
|
|
|
93 my ($di, $subs, $value) = @_;
|
|
|
94 if ($di->{overload} && ! $di->{in_overload}) {
|
|
|
95 $di->{in_overload} = 1;
|
|
|
96 my $r = &{$di->{overload}}($subs, $value);
|
|
|
97 delete $di->{in_overload};
|
|
|
98 return $r;
|
|
|
99 }
|
|
|
100 my @s = _make_subscripts($di, $subs);
|
|
|
101 return $di->_assign($value) if ! @s;
|
|
|
102 return $di->_store(\@s, $value);
|
|
|
103 }
|
|
|
104 croak "Usage: DATA_ITEM->use(SUBSCRIPTS [, VALUE])";
|
|
|
105 }
|
|
|
106
|
|
|
107 sub assign {
|
|
|
108 @_ == 2 or croak "Usage: DATA_ITEM->assign(VALUE)";
|
|
|
109 my ($di, $value) = @_;
|
|
|
110 if ($di->{overload} && ! $di->{in_overload}) {
|
|
|
111 $di->{in_overload} = 1;
|
|
|
112 my $r = &{$di->{overload}}([], $value);
|
|
|
113 delete $di->{in_overload};
|
|
|
114 return $r;
|
|
|
115 }
|
|
|
116 return $di->_assign($value);
|
|
|
117 }
|
|
|
118
|
|
|
119 sub value {
|
|
|
120 @_ == 1 or croak "Usage: DATA_ITEM->value";
|
|
|
121 my ($di) = @_;
|
|
|
122 if ($di->{overload} && ! $di->{in_overload}) {
|
|
|
123 $di->{in_overload} = 1;
|
|
|
124 my $r = &{$di->{overload}}([]);
|
|
|
125 delete $di->{in_overload};
|
|
|
126 return $r;
|
|
|
127 }
|
|
|
128 return $di;
|
|
|
129 }
|
|
|
130
|
|
|
131 sub store {
|
|
|
132 @_ == 3 or croak "Usage: DATA_ITEM->store(SUBSCRIPTS, VALUE)";
|
|
|
133 my ($di, $subs, $value) = @_;
|
|
|
134 if ($di->{overload} && ! $di->{in_overload}) {
|
|
|
135 $di->{in_overload} = 1;
|
|
|
136 my $r = &{$di->{overload}}($subs, $value);
|
|
|
137 delete $di->{in_overload};
|
|
|
138 return $r;
|
|
|
139 }
|
|
|
140 return $di->_store($subs, $value);
|
|
|
141 }
|
|
|
142
|
|
|
143 sub get {
|
|
|
144 @_ == 2 or croak "Usage: DATA_ITEM->get(SUBSCRIPTS)";
|
|
|
145 my ($di, $subs) = @_;
|
|
|
146 if ($di->{overload} && ! $di->{in_overload}) {
|
|
|
147 $di->{in_overload} = 1;
|
|
|
148 my $r = &{$di->{overload}}($subs);
|
|
|
149 delete $di->{in_overload};
|
|
|
150 return $r;
|
|
|
151 }
|
|
|
152 return $di->_get($subs);
|
|
|
153 }
|
|
|
154
|
|
|
155 sub overload {
|
|
|
156 @_ == 2 || @_ == 3
|
|
|
157 or croak "Usage: DATAITEM->overload(SUBSCRIPTS [,CODE])";
|
|
|
158 my ($di, $subs, $code) = @_;
|
|
|
159 defined $code && ref $code ne 'CODE'
|
|
|
160 and croak "CODE is not a code reference";
|
|
|
161 if ($subs && @$subs) {
|
|
|
162 $di->get($subs)->overload(undef, $code);
|
|
|
163 } else {
|
|
|
164 $di->{overload} = $code;
|
|
|
165 }
|
|
|
166 $di;
|
|
|
167 }
|
|
|
168
|
|
|
169 sub get_overload {
|
|
|
170 @_ == 2 or croak "Usage: DATAITEM->get_overload(SUBSCRIPTS)";
|
|
|
171 my ($di, $subs) = @_;
|
|
|
172 if ($subs && @$subs) {
|
|
|
173 return $di->get($subs)->get_overload(undef);
|
|
|
174 } else {
|
|
|
175 return $di->{overload};
|
|
|
176 }
|
|
|
177 }
|
|
|
178
|
|
|
179 sub bits {
|
|
|
180 @_ == 1 or croak "Usage: NUMBER->bits";
|
|
|
181 my ($num) = @_;
|
|
|
182 $num->{bits};
|
|
|
183 }
|
|
|
184
|
|
|
185 1;
|
