Mercurial > repo

comparison interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/ArrayIO.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::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;