File Coverage

blib/lib/Language/Basic/Function.pm
Criterion Covered Total %
statement 82 105 78.1
branch 13 26 50.0
condition 2 6 33.3
subroutine 16 23 69.5
pod 0 3 0.0
total 113 163 69.3


line stmt bran cond sub pod time code
1             package Language::Basic::Function;
2             # Part of Language::Basic by Amir Karger (See Basic.pm for details)
3              
4             =pod
5              
6             =head1 NAME
7              
8             Language::Basic::Function - Package to handle user-defined and intrinsic
9             Functions in BASIC.
10              
11             =head1 SYNOPSIS
12              
13             See L for the overview of how the Language::Basic module
14             works. This pod page is more technical.
15              
16             A Function can be either an intrinsic BASIC function, like INT or CHR$,
17             or a user-defined function, like FNX (defined with the DEF command).
18              
19             =head1 DESCRIPTION
20              
21             The check_args method checks that the right number and type of function
22             arguments were input.
23              
24             The evaluate method actually calculates the value of the function, given
25             certain arguments.
26              
27             The lookup method looks up the function in the function lookup table.
28              
29             The output_perl method returns a string that's the Perl equivalent to
30             the BASIC function.
31              
32             =cut
33              
34             # Fields:
35             # arg_types - a string. If a function takes a String and two Numeric
36             # arguments, the string will be "SNN". Like in Perl, a semicolon
37             # separates required from optional arguments
38              
39 16     16   98 use strict;
  16         44  
  16         715  
40 16     16   91 use Language::Basic::Common;
  16         25  
  16         13258  
41              
42             # sub-packages
43             {
44             package Language::Basic::Function::Intrinsic;
45             package Language::Basic::Function::Defined;
46             }
47              
48             # Lookup table for functions
49             my %Table;
50              
51             # This sub puts the function in the lookup table
52             sub new {
53 171     171 0 237 my ($class, $name) = @_;
54              
55 171         552 my $self = {
56             "name" => $name,
57             } ;
58              
59             # Put this sub in lookup table
60 171         435 $Table{$name} = $self;
61              
62 171 100       851 my $type = ($name =~ /\$$/) ? "String" : "Numeric";
63             # Create a new subclass object, & return it
64 171         461 my $subclass = $class . "::$type";
65 171         659 bless $self, $subclass;
66             } # end sub Language::Basic::Function::new
67              
68             # Lookup a function by name in the function table.
69             # This will (in theory) never be called before new has been called
70             # for function $name
71             sub lookup {
72 54     54 0 88 my $name = shift;
73 54         506 return $Table{$name};
74             } # end sub Language::Basic::Variable::lookup
75              
76             # Check argument number and type. Exit_Error if there's a problem.
77             sub check_args {
78 12     12 0 23 my ($self, $arglist) = @_;
79 12         19 my @args = @{$arglist->{"arguments"}};
  12         37  
80             # Test for several errors at once
81 12         23 my $error = "";
82              
83             # Handle optional args
84 12         21 my ($min_types, $max_types);
85 12         34 my $types = $self->{"arg_types"};
86 12 100       60 if ($types =~ s/(.*);/$1/) {
87 3         8 $min_types = length($1);
88             } else {
89 9         26 $min_types = length($types);
90             }
91 12         24 $max_types = length($types);
92              
93 12 50 33     273 $error .= ("Wrong number of arguments to function\n")
94             unless @args <= $max_types && @args >= $min_types;
95             # Now check each argument type
96 12         196 foreach my $type (split (//, $types)) {
97 19 50       84 my $arg = shift @args or last; # may be optional args
98             # This should never happen, hence die, not Exit_Error
99 19 50       160 ref($arg) =~ /(String|Numeric)$/ or
100             die "Error in LBF::Defined::check_args";
101 19         53 my $atype = substr($1,0,1);
102 19 50       82 if ($atype ne $type) {
103 0 0       0 $error .= $type eq "N" ?
104             "String argument given, Numeric required.\n" :
105             "Numeric argument given, String required.\n";
106             }
107             }
108 12         42 chomp($error); # Exit_Error will add last \n back in.
109 12 50       133 Exit_Error($error) if $error;
110             } # end sub Language::Basic::Variable::check_args
111              
112             =head2
113              
114             Class Language::Basic::Function::Intrinsic
115              
116             This class handles intrinsic BASIC functions.
117              
118             =cut
119              
120             #
121             # Fields:
122             # subroutine - a ref to a sub that implements the BASIC routine in Perl
123             # (assuming the args are in @_)
124             {
125             package Language::Basic::Function::Intrinsic;
126             @Language::Basic::Function::Intrinsic::ISA = qw(Language::Basic::Function);
127 16     16   1367 use Language::Basic::Common;
  16         728  
  16         25296  
128              
129             =pod
130              
131             The initialize method sets up BASIC's supported functions at the beginning
132             of the program. The all-important @Init holds a ref for each function
133             to an array holding:
134             - the function name,
135             - the number and type of arguments (in a Perl function prototype-like style),
136             - a subref that performs the equivalent of the BASIC function, and
137             - a string for the output_perl method. That string is either the name of an
138             equivalent Perl function, like "ord" for BASIC's "ASC", or (if there is no
139             exact equivalent) a BLOCK that performs the same action.
140             Adding intrinsic BASIC functions therefore involves adding to this array.
141              
142             =cut
143              
144             sub initialize {
145             # The type is an N or S for each Numeric or String argument the
146             # function takes.
147             # funcstring is a string that gives the perl equivalent to the
148             # BASIC function. (Used for output_perl) If it's just a word, then perl
149             # and BASIC have exactly equivalent functions, which makes the function
150             # call much easier. Otherwise, it's something in {} that will become
151             # a sub.
152             # TODO it would be pretty sexy to have the subref and the funcstring
153             # do the same thing (i.e., create the sub with an eval of funcstring).
154             # Only reason so far I can think of not to is Exit_Error call in CHR$.
155             # But I could create an Exit_Error routine in output perl script!
156 0     0   0 my @Init = (
157             # Numeric functions...
158 1     1   5 ["ASC", "S", sub {ord(shift)}, "ord" ],
159 0     0   0 ["INT", "N", sub {int(shift)}, "int" ],
160 0     0   0 ["LEN", "S", sub {length(shift)}, "length" ],
161             # Don't use the arg. BASIC passes in
162 0     0   0 ["RND", "N", sub {rand()}, "{rand()}" ],
163             ["VAL", "S", sub {0+shift;}, "{0+shift;}"],
164              
165             # and String functions...
166             ['CHR$', "N",
167             sub {
168 1     1   2 my $a=shift;
169 1 50 33     9 if ($a>127 || $a<0) {Exit_Error("Arg. to CHR\$ must be < 127")}
  0         0  
170 1         5 chr($a);
171             }, "chr"
172             ],
173              
174             ['MID$', "SN;N",
175             sub {
176 25     25   34 my ($str, $index, $length) = @_;
177 25         32 $index--; # BASIC strings index from 1!
178 25 50       139 return (defined $length ?
179             substr($str, $index, $length) :
180             substr($str, $index) );
181             },
182 0     0   0 join("\n\t",
183             "{",
184             'my ($str, $index, $length) = @_;',
185             '$index--;',
186             'return (defined $length ? ',
187             ' substr($str, $index, $length)',
188             ' : substr($str, $index) );')
189             . "\n}"
190             ],
191 21     21   833 ['STR$', "N", sub {'' . shift;}, "{'' . shift;}"],
192             );
193              
194             # Initialize intrinsic functions
195 21         95 foreach (@Init) {
196 168         299 my ($name, $arg_types, $subref, $perl_sub) = @$_;
197 168         541 my $func = new Language::Basic::Function::Intrinsic ($name);
198             # Now set up the Function object with the function definition etc.
199 168         618 $func->define($arg_types, $subref, $perl_sub);
200             }
201             } # end sub Language::Basic::Function::Intrinsic::initialize
202              
203             # This sub defines a function, i.e. says what it does with its arguments
204             sub define {
205             # $subref is a sub ref which "translates" the BASIC function into Perl
206             # arg_types is a string containing an N or S for each Numeric or String
207             # argument the function takes
208             # perlsub is a string which is the perl equivalent of the basic function
209 168     168   251 my ($self, $arg_types, $subref, $perl_sub) = @_;
210 168         866 $self->{"subroutine"} = $subref;
211 168         264 $self->{"arg_types"} = $arg_types;
212 168         645 $self->{"perl_sub"} = $perl_sub;
213             } # end sub Language::Basic::Function::Intrinsic::define
214              
215             sub evaluate {
216             # Note that number & type of args has already been checked
217 27     27   160 my ($self, @args) = @_;
218             # Put this in an eval to find errors?
219 27         33 return &{$self->{"subroutine"}} (@args);
  27         98  
220             } # end sub Language::Basic::Function::Intrinsic::evaluate
221              
222             # output the function name
223             sub output_perl {
224 0     0   0 my $self = shift;
225 0         0 my $prog = &Language::Basic::Program::current_program;
226              
227             # If it's a basic function that translates to an intrinsic function,
228             # just return the function
229 0         0 my $perl_sub = $self->{"perl_sub"};
230 0 0       0 return $perl_sub unless $perl_sub =~ /^\{/;
231              
232             # Otherwise, it's more complicated
233 0         0 my $name = $self->{"name"};
234             # Use ucfirst(lc) for intrinsic functions so we don't get
235             # messed up with real intrinsic functions
236 0         0 $name = ucfirst(lc($name));
237 0         0 $name =~ s/\$$/_str/;
238             # It's a BASIC intrinsic function w/ a perl equivalent
239 0         0 $name .= "_bas";
240              
241             # Note that we're going to have to add sub description at the
242             # end of the perl script
243 0         0 $prog->need_sub($name, $perl_sub);
244              
245 0         0 return $name;
246             } # end sub Language::Basic::Function::Intrinsic::output_perl
247              
248             package Language::Basic::Function::Intrinsic::String;
249             @Language::Basic::Function::Intrinsic::String::ISA =
250             qw(Language::Basic::Function::Intrinsic Language::Basic::Function::String);
251             package Language::Basic::Function::Intrinsic::Numeric;
252             @Language::Basic::Function::Intrinsic::Numeric::ISA =
253             qw(Language::Basic::Function::Intrinsic Language::Basic::Function::Numeric);
254             } # end package Language::Basic::Function::Intrinsic
255              
256             ######################################################################
257              
258             =head2
259              
260             Class Language::Basic::Function::Defined
261              
262             This class handles functions defined by the user in DEF statements.
263              
264             =cut
265              
266             #
267             # Fields:
268             # variables - the function parameters. (LB::Variable::Scalar objects)
269             # expression - an arithmetic expression. When the function parameters
270             # are correctly set, evaluating this expression will yield the
271             # value of the function
272             {
273             package Language::Basic::Function::Defined;
274             @Language::Basic::Function::Defined::ISA = qw(Language::Basic::Function);
275 16     16   887 use Language::Basic::Common;
  16         30  
  16         22385  
276              
277             # This sub declares a function, i.e. says how many arguments it has
278             sub declare {
279             # $arglist is a ref to a list of LB::Variable::Lvalues, which are the
280             # arguments to the Function. (E.g., X in DEF FN(X))
281             # $exp is an LB::Expression which, when evaluated on the arguments,
282             # will implement the function
283 3     3   7 my ($self, $arglistref) = @_;
284 3         4 my $types; # Each arg is S (String) or N (Numeric)
285              
286 3         8 foreach my $arg (@$arglistref) {
287 4 50       37 ref($arg) =~ /(String|Numeric)$/ or die "Error in LBF::Defined::define";
288 4         18 $types .= substr($1,0,1);
289             }
290 3         18 $self->{"arg_types"} = $types;
291              
292 3         13 $self->{"arguments"} = $arglistref;
293             } # end sub Language::Basic::Function::Defined::define
294              
295             # This sub defines a function, i.e. says what it does with its arguments
296             # Just involves setting the function's "expression" field.
297             sub define {
298 3     3   8 my ($self, $exp) = @_;
299 3         13 $self->{"expression"} = $exp;
300             }
301              
302             # Actually evaluate the function on its arguments
303             # Set each parameter (in "variables" field) to the value given in the
304             # arguments, then evaluate the expression.
305             # Just in case user has a function FN(X) and uses X elsewhere in the
306             # program, save the value of X just before we set X based on the argument.
307             # This is a poor man's version of variable scoping.
308             sub evaluate {
309             # Note that number & type of args has already been checked
310 7     7   12 my ($self, @args) = @_;
311 7 50       20 Exit_Error("Function is not defined!") unless defined $self->{"expression"};
312              
313 7         9 my @save_vars;
314 7         10 foreach (@{$self->{"arguments"}}) {
  7         18  
315 8         23 my $var = $_->variable;
316 8         16 my $arg = shift @args;
317 8         21 push @save_vars, $var->value;
318 8         22 $var->set($arg);
319             }
320              
321 7         38 my $value = $self->{"expression"}->evaluate;
322              
323             # Now restore the values of the function parameters that we may have
324             # changed.
325 7         11 foreach (@{$self->{"arguments"}}) {
  7         48  
326 8         20 my $var = $_->variable;
327 8         15 my $save = shift @save_vars;
328 8         53 $var->set($save);
329             }
330              
331 7         22 return $value;
332             } # end sub Language::Basic::Function::Defined::evaluate
333              
334             # output the function name
335             sub output_perl {
336 0     0     my $self = shift;
337 0           my $name = $self->{"name"};
338 0           $name = lc($name);
339             # First "string", then "function"
340 0           $name =~ s/\$$/_str/;
341 0           $name =~ s/^fn(.*)/$1_fun/;
342 0           return $name;
343             } # end sub Language::Basic::Function::Defined::output_perl
344              
345             package Language::Basic::Function::Defined::String;
346             @Language::Basic::Function::Defined::String::ISA =
347             qw(Language::Basic::Function::Defined Language::Basic::Function::String);
348             package Language::Basic::Function::Defined::Numeric;
349             @Language::Basic::Function::Defined::Numeric::ISA =
350             qw(Language::Basic::Function::Defined Language::Basic::Function::Numeric);
351             } # end package Language::Basic::Function::Defined
352              
353             {
354             # set ISA for "return type" classes
355             package Language::Basic::Function::Numeric;
356             @Language::Basic::Function::Numeric::ISA = qw
357             (Language::Basic::Function Language::Basic::Numeric);
358             package Language::Basic::Function::String;
359             @Language::Basic::Function::String::ISA = qw
360             (Language::Basic::Function Language::Basic::String);
361             }
362             1; # end package Language::Basic::Function