|
996
|
1 package Language::INTERCAL::DoubleOhSeven;
|
|
|
2
|
|
|
3 # Special version of Language::INTERCAL::Numbers used for "double-oh-seven"
|
|
|
4 # registers
|
|
|
5
|
|
|
6 # This file is part of CLC-INTERCAL
|
|
|
7
|
|
|
8 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
9
|
|
|
10 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
11 # and distribute it is granted provided that the conditions set out in the
|
|
|
12 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
13
|
|
|
14 use strict;
|
|
|
15 use vars qw($VERSION $PERVERSION);
|
|
|
16 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/DoubleOhSeven.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
17
|
|
|
18 use Carp;
|
|
|
19 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
20 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP splatname);
|
|
|
21 use Language::INTERCAL::Numbers '1.-94.-2';
|
|
|
22 use Language::INTERCAL::ReadNumbers '1.-94.-2', qw(roman_type roman_name);
|
|
|
23 use Language::INTERCAL::Charset '1.-94.-2', qw(charset charset_name);
|
|
|
24 use Language::INTERCAL::ArrayIO '1.-94.-2', qw(iotype iotype_name);
|
|
|
25 use vars qw(@ISA);
|
|
|
26 @ISA = qw(Language::INTERCAL::Numbers::Spot);
|
|
|
27
|
|
|
28 my %types = (
|
|
|
29 base => [2, \&_code_base, undef],
|
|
|
30 charset => [0, \&_code_charset, \&_decode_charset],
|
|
|
31 comefrom => [0, \&_code_comefrom, undef],
|
|
|
32 crawlhorror => [1, \&_code_crawlhorror, undef],
|
|
|
33 iotype => [0, \&_code_iotype, \&_decode_iotype],
|
|
|
34 roman => [0, \&_code_roman, \&_decode_roman],
|
|
|
35 splat => [1000, \&_code_splat, \&_decode_splat],
|
|
|
36 spot => [0, undef, undef],
|
|
|
37 symbol => [0, \&_code_symbol, \&_decode_symbol],
|
|
|
38 zeroone => [0, \&_code_zeroone, undef],
|
|
|
39 );
|
|
|
40
|
|
|
41 sub new {
|
|
|
42 @_ == 3 || @_ == 4
|
|
|
43 or croak "Usage: Language::INTERCAL::DoubleOhSeven" .
|
|
|
44 "->new(TYPE, OBJECT [,VALUE])";
|
|
|
45 my ($class, $type, $object, @value) = @_;
|
|
|
46 exists $types{$type} or faint(SP_SPECIAL, "(type $type)");
|
|
|
47 @value = ($types{$type}[0]) unless @value;
|
|
|
48 return Language::INTERCAL::Numbers::Spot->new(@value)
|
|
|
49 if ! defined $types{$type}[1];
|
|
|
50 @value = &{$types{$type}[1]}($object, @value);
|
|
|
51 # note, we don't use SUPER here, rather we rebless later
|
|
|
52 my $num = Language::INTERCAL::Numbers::Spot->new(@value);
|
|
|
53 $num->{doubleohseven} = {
|
|
|
54 object => $object,
|
|
|
55 type => $types{$type}[1],
|
|
|
56 typename => $type,
|
|
|
57 decode => $types{$type}[2],
|
|
|
58 };
|
|
|
59 bless $num, $class;
|
|
|
60 }
|
|
|
61
|
|
|
62 sub type {
|
|
|
63 @_ == 1 or croak "Usage: DOUBLEOHSEVEN->type";
|
|
|
64 my ($num) = @_;
|
|
|
65 $num->{doubleohseven}{typename};
|
|
|
66 }
|
|
|
67
|
|
|
68 sub print {
|
|
|
69 @_ == 1 or croak "Usage: DOUBLEOHSEVEN->print";
|
|
|
70 my ($num) = @_;
|
|
|
71 my $d = $num->{doubleohseven};
|
|
|
72 $d->{decode} or return $num->SUPER::print;
|
|
|
73 &{$d->{decode}}($d->{object}, $num->number);
|
|
|
74 }
|
|
|
75
|
|
|
76 sub _assign {
|
|
|
77 @_ == 2 or croak "Usage: DOUBLEOHSEVEN->assign(VALUE)";
|
|
|
78 my ($num, $value) = @_;
|
|
|
79 exists $num->{doubleohseven} or faint(SP_NOSPECIAL);
|
|
|
80 $num->{doubleohseven}{type} or faint(SP_NOSPECIAL);
|
|
|
81 $value =
|
|
|
82 &{$num->{doubleohseven}{type}}($num->{doubleohseven}{object}, $value);
|
|
|
83 $num->SUPER::_assign($value);
|
|
|
84 $num;
|
|
|
85 }
|
|
|
86
|
|
|
87 sub _get_number {
|
|
|
88 my ($value, $translate, $splat) = @_;
|
|
|
89 faint(SP_NOASSIGN, '(undef)', 'Not a number') if ! defined $value;
|
|
|
90 return $value->spot->number
|
|
|
91 if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
|
|
|
92 return $value
|
|
|
93 if ! ref $value && defined $value && $value =~ /^\d+$/;
|
|
|
94 if ($translate) {
|
|
|
95 if (ref $value) {
|
|
|
96 my @num = ();
|
|
|
97 if (ref $value eq 'ARRAY') {
|
|
|
98 @num = map { _get_number($_, $translate) } @$value;
|
|
|
99 } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::Arrays')) {
|
|
|
100 @num = map { $_->spot->number } $value->as_list;
|
|
|
101 } else {
|
|
|
102 faint(SP_NOASSIGN, $value, 'Not a number');
|
|
|
103 }
|
|
|
104 $value = pack('C*', @num);
|
|
|
105 }
|
|
|
106 my $t = &{$translate}($value);
|
|
|
107 defined $t or faint($splat, $value);
|
|
|
108 return $t;
|
|
|
109 }
|
|
|
110 faint(SP_NOASSIGN, $value, 'Not a number');
|
|
|
111 }
|
|
|
112
|
|
|
113 sub _decode {
|
|
|
114 my ($value, $code) = @_;
|
|
|
115 my $nv = $code->($value);
|
|
|
116 return "?$nv" if defined $nv && $nv ne '';
|
|
|
117 "#$value";
|
|
|
118 }
|
|
|
119
|
|
|
120 sub _code_base {
|
|
|
121 my ($object, $value) = @_;
|
|
|
122 $value = _get_number($value);
|
|
|
123 $value < 2 || $value > 7
|
|
|
124 and faint(SP_BASE, $value);
|
|
|
125 $value;
|
|
|
126 }
|
|
|
127
|
|
|
128 sub _code_charset {
|
|
|
129 my ($object, $value) = @_;
|
|
|
130 _get_number($value, \&charset, SP_CHARSET);
|
|
|
131 }
|
|
|
132
|
|
|
133 sub _decode_charset {
|
|
|
134 my ($object, $value) = @_;
|
|
|
135 _decode($value, \&charset_name);
|
|
|
136 }
|
|
|
137
|
|
|
138 sub _code_comefrom {
|
|
|
139 my ($object, $value) = @_;
|
|
|
140 $value = _get_number($value);
|
|
|
141 $value < 0 || $value > 3
|
|
|
142 and faint(SP_NOASSIGN, $value,
|
|
|
143 'come from value must be between 0 and 3');
|
|
|
144 $value;
|
|
|
145 }
|
|
|
146
|
|
|
147 sub _code_crawlhorror {
|
|
|
148 my ($object, $value) = @_;
|
|
|
149 $object or faint(SP_CONTEXT, 'missing grammar');
|
|
|
150 my $c = _get_number($value);
|
|
|
151 $c < 1 || $c > $object->num_parsers
|
|
|
152 and faint(SP_NOASSIGN, $value, 'grammar number out of range');
|
|
|
153 $c;
|
|
|
154 }
|
|
|
155
|
|
|
156 sub _code_iotype {
|
|
|
157 my ($object, $value) = @_;
|
|
|
158 _get_number($value, \&iotype, SP_IOTYPE);
|
|
|
159 }
|
|
|
160
|
|
|
161 sub _decode_iotype {
|
|
|
162 my ($object, $value) = @_;
|
|
|
163 _decode($value, \&iotype_name);
|
|
|
164 }
|
|
|
165
|
|
|
166 sub _code_roman {
|
|
|
167 my ($object, $value) = @_;
|
|
|
168 _get_number($value, \&roman_type, SP_ROMAN);
|
|
|
169 }
|
|
|
170
|
|
|
171 sub _decode_roman {
|
|
|
172 my ($object, $value) = @_;
|
|
|
173 _decode($value, \&roman_name);
|
|
|
174 }
|
|
|
175
|
|
|
176 sub _code_splat {
|
|
|
177 my ($object, $value) = @_;
|
|
|
178 _get_number($value, \&_splat_type, SP_INVSPLAT);
|
|
|
179 }
|
|
|
180
|
|
|
181 sub _splat_type {
|
|
|
182 my ($code) = @_;
|
|
|
183 defined splatname($code) ? $code : 1000;
|
|
|
184 }
|
|
|
185
|
|
|
186 sub _decode_splat {
|
|
|
187 my ($object, $value) = @_;
|
|
|
188 $value < 1000 ? $value : undef;
|
|
|
189 }
|
|
|
190
|
|
|
191 sub _code_symbol {
|
|
|
192 my ($object, $value) = @_;
|
|
|
193 $object or faint(SP_CONTEXT, 'symbol without grammar');
|
|
|
194 _get_number($value, sub { $object->symboltable->find(@_) }, SP_SYMBOL);
|
|
|
195 }
|
|
|
196
|
|
|
197 sub _decode_symbol {
|
|
|
198 my ($object, $value) = @_;
|
|
|
199 _decode($value, sub { $object->symboltable->symbol(@_) } );
|
|
|
200 }
|
|
|
201
|
|
|
202 sub _code_zeroone {
|
|
|
203 my ($object, $value) = @_;
|
|
|
204 $value = _get_number($value);
|
|
|
205 $value < 0 || $value > 1
|
|
|
206 and faint(SP_NOASSIGN, $value, 'value must be 0 or 1');
|
|
|
207 $value;
|
|
|
208 }
|
|
|
209
|
|
|
210 1;
|
