|
996
|
1 package Language::INTERCAL::ArrayIO;
|
|
|
2
|
|
|
3 # Write/read arrays
|
|
|
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/ArrayIO.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 Language::INTERCAL::Charset::Baudot '1.-94.-2',
|
|
|
21 qw(baudot2ascii ascii2baudot);
|
|
|
22 use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
|
|
|
23 @EXPORT = ();
|
|
|
24 @EXPORT_OK = qw(iotype_default iotype iotype_name
|
|
|
25 write_array_16 read_array_16
|
|
|
26 write_array_32 read_array_32);
|
|
|
27 %EXPORT_TAGS = ();
|
|
|
28
|
|
|
29 my @iotypes;
|
|
|
30 my %iotypes;
|
|
|
31
|
|
|
32 BEGIN {
|
|
|
33 @iotypes = (
|
|
|
34 [CLC => \&_ra_clc_16, \&_ra_clc_32, \&_wa_clc_16, \&_wa_clc_32],
|
|
|
35 [C => \&_ra_c, \&_ra_c, \&_wa_c, \&_wa_c],
|
|
|
36 [1972 => \&_no_io, \&_no_io, \&_no_io, \&_no_io],
|
|
|
37 );
|
|
|
38 %iotypes = map { ($iotypes[$_ - 1][0] => $_) } (1..@iotypes);
|
|
|
39 }
|
|
|
40
|
|
|
41 use constant iotype_default => $iotypes{CLC};
|
|
|
42
|
|
|
43 sub iotype {
|
|
|
44 @_ == 1 or croak "Usage: iotype(IOTYPE)";
|
|
|
45 my ($iotype) = @_;
|
|
|
46 $iotype =~ s/\s+//g;
|
|
|
47 if ($iotype =~ /^\d+$/ && $iotype != 1972) {
|
|
|
48 return iotype_default if $iotype == 0;
|
|
|
49 return undef if $iotype < 1 || $iotype > @iotypes;
|
|
|
50 return $iotype;
|
|
|
51 } else {
|
|
|
52 $iotype = uc($iotype);
|
|
|
53 return undef if ! exists $iotypes{$iotype};
|
|
|
54 return $iotypes{$iotype};
|
|
|
55 }
|
|
|
56 }
|
|
|
57
|
|
|
58 sub iotype_name {
|
|
|
59 @_ == 1 or croak "Usage: iotype_name(IOTYPE)";
|
|
|
60 my ($iotype) = @_;
|
|
|
61 $iotype = iotype_default if $iotype < 1;
|
|
|
62 return undef if $iotype < 1 || $iotype > @iotypes;
|
|
|
63 return $iotypes[$iotype - 1][0];
|
|
|
64 }
|
|
|
65
|
|
|
66 sub read_array_16 {
|
|
|
67 @_ == 5 or croak
|
|
|
68 'Usage: read_array_16(IOTYPE, \$IOVALUE, FILEHANDLE, \@VALUES, NL';
|
|
|
69 my ($iotype, $iovalue, $fh, $values, $nl) = @_;
|
|
|
70 my $iocode = iotype($iotype) or faint(SP_IOTYPE, $iotype);
|
|
|
71 &{$iotypes[$iocode - 1][1]}($iovalue, $values, $fh, $nl);
|
|
|
72 }
|
|
|
73
|
|
|
74 sub read_array_32 {
|
|
|
75 @_ == 5 or croak
|
|
|
76 'Usage: read_array_32(IOTYPE, \$IOVALUE, FILEHANDLE, \@VALUES, NL';
|
|
|
77 my ($iotype, $iovalue, $fh, $values, $nl) = @_;
|
|
|
78 my $iocode = iotype($iotype) or faint(SP_IOTYPE, $iotype);
|
|
|
79 &{$iotypes[$iocode - 1][2]}($iovalue, $values, $fh, $nl);
|
|
|
80 }
|
|
|
81
|
|
|
82 sub _no_io {
|
|
|
83 faint(SP_FORBIDDEN, 'Array I/O');
|
|
|
84 }
|
|
|
85
|
|
|
86 sub _ra_c {
|
|
|
87 my ($iovalue, $values, $fh, $nl) = @_;
|
|
|
88 my $tape_pos = $$iovalue;
|
|
|
89 my @v = ();
|
|
|
90 for my $value (@$values) {
|
|
|
91 $tape_pos = ($tape_pos + 256 - ($value & 0xff)) & 0xff;
|
|
|
92 my $v = $tape_pos;
|
|
|
93 $v = (($v & 0x0f) << 4) | (($v & 0xf0) >> 4);
|
|
|
94 $v = (($v & 0x33) << 2) | (($v & 0xcc) >> 2);
|
|
|
95 $v = (($v & 0x55) << 1) | (($v & 0xaa) >> 1);
|
|
|
96 push @v, $v;
|
|
|
97 }
|
|
|
98 $$iovalue = $tape_pos;
|
|
|
99 $fh->read_binary(pack("C*", @v));
|
|
|
100 }
|
|
|
101
|
|
|
102 sub _ra_clc_16 {
|
|
|
103 my ($iovalue, $values, $fh, $nl) = @_;
|
|
|
104 my $value = pack("C*", grep { $_ > 0 } @$values);
|
|
|
105 $fh->read_text(baudot2ascii($value) . ($nl ? "\n" : ''));
|
|
|
106 }
|
|
|
107
|
|
|
108 sub _ra_clc_32 {
|
|
|
109 my ($iovalue, $values, $fh, $nl) = @_;
|
|
|
110 my $line = '';
|
|
|
111 my $io = 172;
|
|
|
112 for my $value (@$values) {
|
|
|
113 next if ! $value;
|
|
|
114 my $val0 = $value;
|
|
|
115 my $bits0 = 0;
|
|
|
116 my $bits1 = 0;
|
|
|
117 my $i;
|
|
|
118 for ($i = 0; $i < 8; $i++) {
|
|
|
119 $bits0 >>= 1;
|
|
|
120 $bits1 >>= 1;
|
|
|
121 $bits0 |= 0x80 if $val0 & 2;
|
|
|
122 $bits1 |= 0x80 if $val0 & 1;
|
|
|
123 $val0 >>= 2;
|
|
|
124 }
|
|
|
125 $val0 = 0;
|
|
|
126 for ($i = 0; $i < 8; $i++) {
|
|
|
127 $val0 >>= 1;
|
|
|
128 if ($io & 1) {
|
|
|
129 $val0 |= 0x80 if $bits0 & 1;
|
|
|
130 $bits0 >>= 1;
|
|
|
131 } else {
|
|
|
132 $val0 |= 0x80 if ! ($bits1 & 1);
|
|
|
133 $bits1 >>= 1;
|
|
|
134 }
|
|
|
135 $io >>= 1;
|
|
|
136 }
|
|
|
137 $line .= chr($val0);
|
|
|
138 $io = $val0;
|
|
|
139 }
|
|
|
140 $fh->read_binary($line);
|
|
|
141 }
|
|
|
142
|
|
|
143 sub write_array_16 {
|
|
|
144 @_ == 4
|
|
|
145 or croak 'Usage: write_array_16(IOTYPE, \$IOVALUE, FILEHANDLE, SIZE';
|
|
|
146 my ($iotype, $iovalue, $fh, $size) = @_;
|
|
|
147 my $iocode = iotype($iotype) or faint(SP_IOTYPE, $iotype);
|
|
|
148 &{$iotypes[$iocode - 1][3]}($iovalue, $fh, $size);
|
|
|
149 }
|
|
|
150
|
|
|
151 sub write_array_32 {
|
|
|
152 @_ == 4
|
|
|
153 or croak 'Usage: write_array_32(IOTYPE, \$IOVALUE, FILEHANDLE, SIZE';
|
|
|
154 my ($iotype, $iovalue, $fh, $size) = @_;
|
|
|
155 my $iocode = iotype($iotype) or faint(SP_IOTYPE, $iotype);
|
|
|
156 &{$iotypes[$iocode - 1][4]}($iovalue, $fh, $size);
|
|
|
157 }
|
|
|
158
|
|
|
159 sub _wa_c {
|
|
|
160 my ($iovalue, $fh, $size) = @_;
|
|
|
161 my $line = $fh->write_binary($size);
|
|
|
162 my @values = unpack("C*", $line);
|
|
|
163 my $tape_pos = $$iovalue;
|
|
|
164 for my $chr (@values) {
|
|
|
165 my $c = $chr;
|
|
|
166 $chr = (256 + $chr - $tape_pos) & 0xff;
|
|
|
167 $tape_pos = $c;
|
|
|
168 }
|
|
|
169 push @values, 256 while @values < $size;
|
|
|
170 $$iovalue = $tape_pos;
|
|
|
171 @values;
|
|
|
172 }
|
|
|
173
|
|
|
174 sub _wa_clc_16 {
|
|
|
175 my ($iovalue, $fh, $size) = @_;
|
|
|
176 my $line = $fh->write_text();
|
|
|
177 defined $line or return ();
|
|
|
178 chomp $line;
|
|
|
179 $line = ascii2baudot($line);
|
|
|
180 unpack("C*", $line);
|
|
|
181 }
|
|
|
182
|
|
|
183 sub _wa_clc_32 {
|
|
|
184 my ($iovalue, $fh, $size) = @_;
|
|
|
185 my $line = $fh->write_binary($size);
|
|
|
186 my @values = unpack("C*", $line);
|
|
|
187 my $ptr = 0;
|
|
|
188 my @val = ();
|
|
|
189 my $io = 172;
|
|
|
190 for my $datum (@values) {
|
|
|
191 my $chr = $datum;
|
|
|
192 my $chr0 = $chr;
|
|
|
193 my $bits0 = 0;
|
|
|
194 my $bits1 = 0;
|
|
|
195 for (my $i = 0; $i < 8; $i++) {
|
|
|
196 if ($io & 0x80) {
|
|
|
197 $bits0 <<= 1;
|
|
|
198 $bits0 |= 1 if $chr & 0x80;
|
|
|
199 } else {
|
|
|
200 $bits1 <<= 1;
|
|
|
201 $bits1 |= 1 if ! ($chr & 0x80);
|
|
|
202 }
|
|
|
203 $chr <<= 1;
|
|
|
204 $io <<= 1;
|
|
|
205 }
|
|
|
206 $chr = int(rand 0xffff) + 1;
|
|
|
207 for (my $i = 0; $i < 8; $i++) {
|
|
|
208 $chr <<= 2;
|
|
|
209 $chr |= 2 if $bits0 & 0x80;
|
|
|
210 $chr |= 1 if $bits1 & 0x80;
|
|
|
211 $bits0 <<= 1;
|
|
|
212 $bits1 <<= 1;
|
|
|
213 }
|
|
|
214 $datum = $chr;
|
|
|
215 $io = $chr0;
|
|
|
216 }
|
|
|
217 @values;
|
|
|
218 }
|
|
|
219
|
|
|
220 1;
|
