|
996
|
1 package Language::INTERCAL::SymbolTable;
|
|
|
2
|
|
|
3 # Symbol table; it is separate from the parser because we have one symbol
|
|
|
4 # table per object, which can have many parsers.
|
|
|
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/SymbolTable.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
17
|
|
|
18 use Carp;
|
|
|
19 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
20
|
|
|
21 sub new {
|
|
|
22 @_ == 1 or croak "Usage: new Language::INTERCAL::SymbolTable";
|
|
|
23 my ($class) = @_;
|
|
|
24 bless {
|
|
|
25 symbols => [''],
|
|
|
26 symbolindex => {},
|
|
|
27 }, $class;
|
|
|
28 }
|
|
|
29
|
|
|
30 sub find {
|
|
|
31 @_ == 2 || @_ == 3
|
|
|
32 or croak "Usage: SYMBOLTABLE->find(STRING[, SKIP_CREATION])";
|
|
|
33 my ($table, $symbol, $skip) = @_;
|
|
|
34 $symbol = uc $symbol;
|
|
|
35 if (! exists $table->{symbolindex}{$symbol}) {
|
|
|
36 return 0 if $skip;
|
|
|
37 $table->{symbolindex}{$symbol} = @{$table->{symbols}};
|
|
|
38 push @{$table->{symbols}}, $symbol;
|
|
|
39 }
|
|
|
40 $table->{symbolindex}{$symbol};
|
|
|
41 }
|
|
|
42
|
|
|
43 sub symbol {
|
|
|
44 @_ == 2 or croak "Usage: SYMBOLTABLE->symbol(NUMBER)";
|
|
|
45 my ($table, $symbol) = @_;
|
|
|
46 return '' if $symbol !~ /^\d+$/ || $symbol >= @{$table->{symbols}};
|
|
|
47 $table->{symbols}[$symbol];
|
|
|
48 }
|
|
|
49
|
|
|
50 sub max {
|
|
|
51 @_ == 1 or croak "Usage: SYMBOLTABLE->max";
|
|
|
52 my ($table) = @_;
|
|
|
53 scalar @{$table->{symbols}} - 1;
|
|
|
54 }
|
|
|
55
|
|
|
56 sub read {
|
|
|
57 @_ == 2 or croak "Usage: SYMBOLTABLE->read(FILEHANDLE)";
|
|
|
58 my ($table, $fh) = @_;
|
|
|
59
|
|
|
60 my $slist = $table->{symbols};
|
|
|
61 $fh->read_binary(pack('v', scalar @$slist));
|
|
|
62 for (my $symbol = 1; $symbol < @$slist; $symbol++) {
|
|
|
63 my $sym = $slist->[$symbol];
|
|
|
64 $fh->read_binary(pack('v/a*', $sym));
|
|
|
65 }
|
|
|
66
|
|
|
67 $table;
|
|
|
68 }
|
|
|
69
|
|
|
70 sub write {
|
|
|
71 @_ == 2 or croak "Usage: write Language::INTERCAL::SymbolTable(FILEHANDLE)";
|
|
|
72 my ($class, $fh) = @_;
|
|
|
73
|
|
|
74 my $nsymbols = unpack('v', $fh->write_binary(2)) || 0;
|
|
|
75 my @symbols = ('');
|
|
|
76 my %symbolindex = ();
|
|
|
77 for (my $symbol = 1; $symbol < $nsymbols; $symbol++) {
|
|
|
78 my $nlen = unpack('v', $fh->write_binary(2));
|
|
|
79 my $name = $fh->write_binary($nlen);
|
|
|
80 $symbolindex{$name} = @symbols;
|
|
|
81 push @symbols, $name;
|
|
|
82 }
|
|
|
83
|
|
|
84 bless {
|
|
|
85 symbols => \@symbols,
|
|
|
86 symbolindex => \%symbolindex,
|
|
|
87 }, $class;
|
|
|
88 }
|
|
|
89
|
|
|
90 1;
|
