Mercurial > repo

comparison interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/DoubleOhSeven.pm @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
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;