|
996
|
1 package Language::INTERCAL::SharkFin;
|
|
|
2
|
|
|
3 # Special version of Language::INTERCAL::Arrays used for "Shark Fin"
|
|
|
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/SharkFin.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);
|
|
|
21 use Language::INTERCAL::Arrays '1.-94.-2';
|
|
|
22 use vars qw(@ISA);
|
|
|
23 @ISA = qw(Language::INTERCAL::Arrays::Tail);
|
|
|
24
|
|
|
25 my %types = (
|
|
|
26 vector => [\&_code_vector, \&_decode_vector],
|
|
|
27 );
|
|
|
28
|
|
|
29 sub new {
|
|
|
30 @_ == 3 || @_ == 4
|
|
|
31 or croak "Usage: Language::INTERCAL::SharkFin->new(TYPE, OBJECT [,VALUE])";
|
|
|
32 my ($class, $type, $object, @value) = @_;
|
|
|
33 exists $types{$type} or faint(SP_SPECIAL, "(type $type)");
|
|
|
34 my $arr;
|
|
|
35 if (@value) {
|
|
|
36 @value = &{$types{$type}[0]}($object, @value);
|
|
|
37 # note, we don't use SUPER here, rather we rebless later
|
|
|
38 $arr = Language::INTERCAL::Arrays::Tail->from_list(\@value);
|
|
|
39 } else {
|
|
|
40 $arr = Language::INTERCAL::Arrays::Tail->new([]);
|
|
|
41 }
|
|
|
42 $arr->{sharkfin} = {
|
|
|
43 object => $object,
|
|
|
44 type => $types{$type}[0],
|
|
|
45 typename => $type,
|
|
|
46 decode => $types{$type}[1],
|
|
|
47 };
|
|
|
48 bless $arr, $class;
|
|
|
49 }
|
|
|
50
|
|
|
51 sub type {
|
|
|
52 @_ == 1 or croak "Usage: SHARKFIN->type";
|
|
|
53 my ($arr) = @_;
|
|
|
54 $arr->{sharkfin}{typename};
|
|
|
55 }
|
|
|
56
|
|
|
57 sub _assign {
|
|
|
58 @_ == 2 or croak "Usage: SHARKFIN->assign(VALUE)";
|
|
|
59 my ($arr, $value) = @_;
|
|
|
60 exists $arr->{sharkfin} or faint(SP_NOSPECIAL);
|
|
|
61 $arr->{sharkfin}{type} or faint(SP_NOSPECIAL);
|
|
|
62 my @value = &{$arr->{sharkfin}{type}}($arr->{sharkfin}{object}, $value);
|
|
|
63 $arr->SUPER::_assign(@value ? [scalar @value] : []);
|
|
|
64 for (my $i = 1; $i <= @value; $i++) {
|
|
|
65 $arr->_store([$i], $value[$i - 1]);
|
|
|
66 }
|
|
|
67 $arr;
|
|
|
68 }
|
|
|
69
|
|
|
70 sub _get_number {
|
|
|
71 my ($value) = @_;
|
|
|
72 return $value->spot->number
|
|
|
73 if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
|
|
|
74 return $value
|
|
|
75 if ! ref $value && defined $value && $value =~ /^\d+$/;
|
|
|
76 faint(SP_INVARRAY, 'Not a number');
|
|
|
77 }
|
|
|
78
|
|
|
79 sub _get_vector {
|
|
|
80 my ($value) = @_;
|
|
|
81 return $value->spot->number
|
|
|
82 if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
|
|
|
83 return $value
|
|
|
84 if ! ref $value && defined $value && $value =~ /^\d+$/;
|
|
|
85 return (unpack('C*', $value), 0)
|
|
|
86 if ! ref $value && defined $value;
|
|
|
87 return ( map { _get_number($_) } @$value )
|
|
|
88 if ref $value eq 'ARRAY';
|
|
|
89 faint(SP_INVARRAY, 'Not a number');
|
|
|
90 }
|
|
|
91
|
|
|
92 sub _code_vector {
|
|
|
93 my ($object, $value) = @_;
|
|
|
94 if (ref $value) {
|
|
|
95 return ( map { _get_vector($_) } @$value )
|
|
|
96 if ref $value eq 'ARRAY';
|
|
|
97 return ( $value->spot->number )
|
|
|
98 if UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
|
|
|
99 return ((map { $_->spot->number } $value->tail->as_list))
|
|
|
100 if UNIVERSAL::isa($value, 'Language::INTERCAL::Arrays');
|
|
|
101 faint(SP_NOARRAY, "Not an array");
|
|
|
102 }
|
|
|
103 if (defined $value) {
|
|
|
104 return (unpack('C*', $value));
|
|
|
105 }
|
|
|
106 faint(SP_NOARRAY, "Not an array");
|
|
|
107 }
|
|
|
108
|
|
|
109 sub _decode_vector {
|
|
|
110 my ($object, $value) = @_;
|
|
|
111 my @list = map { $_->number } $value->as_list;
|
|
|
112 pop @list while @list && $list[-1] == 0;
|
|
|
113 my $list = pack('C*', @list);
|
|
|
114 $list =~ s/([\\'])/\\$1/g;
|
|
|
115 $list = "'$list'" if $list =~ /['\s\\]/;
|
|
|
116 $list;
|
|
|
117 }
|
|
|
118
|
|
|
119 sub print {
|
|
|
120 @_ == 1 or croak "Usage: SHARKFIN->print";
|
|
|
121 my ($arr) = @_;
|
|
|
122 my $s = $arr->{sharkfin};
|
|
|
123 return &{$s->{decode}}($s->{object}, $arr) if $s->{decode};
|
|
|
124 $arr->SUPER::print;
|
|
|
125 }
|
|
|
126
|
|
|
127 sub range {
|
|
|
128 @_ == 3 or croak "Usage: SHARKFIN->range(START, LEN)";
|
|
|
129 my ($arr, $start, $len) = @_;
|
|
|
130 # we just rebless it to a Tail and use their range()
|
|
|
131 bless $arr, 'Language::INTERCAL::Arrays::Tail';
|
|
|
132 $arr->range($start, $len);
|
|
|
133 }
|
|
|
134
|
|
|
135 1;
|
