Acorn User 10/AU_CD10.iso/Updates/Perl/Non-RPC/!Perl/riscos/RISCOS/SWI.pm

Text File | 1998-07-26 | 10KB | 287 lines

package RISCOS::SWI;

require Exporter;
use Carp;
use strict;

use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK @in @out $string2num $num2string
         $num2string_mask $string2num_mask);
$VERSION = 0.07;
@ISA = qw(Exporter);
@EXPORT = qw(swi swix kernelswi regmask SWINumberFromString SWINumberToString);
@EXPORT_OK = qw(&V_Flag &C_Flag &Z_Flag &N_Flag &XOS_Bit);

# 0.04
# Tidied up error handling on SWINumberToString (ie it can now return undef)
# 0.05
# Prototypes
# Can now return register 15 (but not 'PC' - hmm).
# Can do block
# 0.06
# Added SWI number in hex for SWINumberToString if SWI is 'User' or 'XUser'
# and decode on OS_WriteI
# 0.07
# foreach rather than shift in regmask

for my $i (0..9) { $in[$i] = 1<<$i; $out[$i] = 1<<(31-$i); }
$out[15] = 1 << 21;    # PC out is hardcoded

sub V_Flag ()    {return 1 << 28;}
sub C_Flag ()    {return 1 << 29;}
sub Z_Flag ()    {return 1 << 30;}
sub N_Flag ()    {return 1 << 31;}
sub XOS_Bit ()    {return 1 << 17;}

sub regmask {
    my $ir = shift;
    my $or = shift;
    my $block = shift;
    my $mask = 0;
    if (defined $ir) { foreach (@$ir) { $mask |= $in[$_]; } }
    if (defined $or) { foreach (@$or) { $mask |= $out[$_]; } }
    if (defined $block)
    {
        if ($block & 0xFFFFFFF0) {
        carp "Block register $block out of range 0-15" if $^W;
        $block &= 0xF;
        }
        $mask |= 1 << 11;
        $mask |= $block << 12;
    }
    $mask;
}

$string2num_mask = regmask ([1]);
$_ = 'XOS_SWINumberFromString';        # Can't pass in a string constant
$string2num =  swix ('XOS_SWINumberFromString', $string2num_mask, $_);

sub SWINumberFromString ($) {
    my $name = shift;
    if ($name =~ /^(X?)OS_WriteI\+(.+)/) {
    my $base = $1 ? (1 << 17 + 256) : 256;
    my $num = $2;
    return $base + $num unless $num =~ /^"(.)"/;
    return $base + ord $1;
    } elsif ($name =~ /^X?User \((.+)\)$/) {
    my $num = $2;
    return ($num =~ /^&(.+)/) ? oct "0x$1" : $num;
    }

    RISCOS::SWI::swix(57, $string2num_mask, $name);
}

$num2string = SWINumberFromString ('XOS_SWINumberToString');
$num2string_mask = regmask([0..2],[2]);

sub SWINumberToString ($) {
    return undef unless defined (my $num = shift);
    my $len = 'xxxx';
    my $buffer = ' ' x 255;

    return undef
      unless defined RISCOS::SWI::swix($num2string, $num2string_mask, 0+$num,
                       $buffer, 255, $len);

    $len = unpack('i', $len) - 1;    # Interpret the result as an integer
    $buffer = substr($buffer, 0, $len);
    $buffer = sprintf "$buffer (&%06X)", $num if ($buffer =~ /^X?User$/);
    $buffer;
}

sub swi {
    my $result = &swix;
    croak (sprintf "Unexpected OS error number &%X: $^E", $^E)
      unless defined $result;
    0 + $result;            # To be consistent with perl5.001
}

$num2string && $string2num;    # True if we got the SWIs

__END__

=head1 NAME

RISCOS::SWI -- perl interface to SWI calls

=head1 SYNOPSIS

    use RISCOS::SWI;
    $number = RISCOS::SWI::swix ('OS_SWINumberFromString', regmask([1]), $name);
    @regs = unpack 'I10', kernelswi ('OS_File', 5, $filename);

=head1 DESCRIPTION

This module provides a SWI interface for perl. There are two alternative
interfaces supported - B<kernelswi> and B<swi>/B<swix>. Both take the SWI to
call as the first parameter, which can be specified by name or number. Although
calling a SWI by name makes for highly readable code, the name lookup itself
often takes longer than the actual SWI, so for production code it is wise to
perform the name lookup once at initialisation using C<SWINumberFromString> and
cache the number in a variable.

C<kernelswi> and C<swix> both automatically call the C<X> (error returning)
version of the SWI, return undefined on error and copy the error block number
and message to C<$^E>. C<swi> calls C<swix>, but will terminate the script with
the error number and message if an error occurs.

For both interfaces registers are initialised from perl variables according to
the following rules:

=over 4

=item the undefined value is passed as zero

=item "numbers" are passed as integers

=item "strings" are passed as pointers to the strings - perl automatically adds
a C<"\0"> at the end to create null terminated strings.

Overwriting the contents alters the variable's value - it is up to the script to
ensure that the perl scalar value is made long enough before calling the SWI.
Note also that B<string constants> are treated as B<read only> so attempting to
call

    $number = RISCOS::SWI::swix ('OS_SWINumberFromString', regmask([1]),
                 'OS_SWINumberFromString');

would cause a fatal runtime error.

=back

"strings" and "numbers" are in quotes because the internals rely on perl's flags
to determine whether a scalar is a number or string. The trouble comes when perl
has been implicitly converting between the two and thinks that the result of
S<C<6*7> is C<"42">>, which it will try to pass in as a pointer to a string.
The work around is to add zero to parameters that must be numeric, and
concatenate C<''> to parameters that are strings:

    $number += 0;

    $string = "0";    # This may be interpreted as the number zero
    kernelswi ($swi, 0, $string . '')        # Not now.

The latter is, to quote Paul Moore, "fairly obscure magic (deliberately
invalidating the flag which says that the string has a valid numeric value, and
then using the string before perl has a chance to notice that the numeric value
is still OK), but works fine."

The two interfaces are both built into the perl binary and so are always
available, with or without this module. They differ in the method of passing in
and returning results from registers.

=over 4

=item kernelswi <name>|<number>, [<R0 value>, [<R1 value], ...

is similar to the C library function of the same name. It takes as parameters
the SWI to call and optionally up to 10 more values assigned to C<R0> - C<R9>
in order. Unassigned registers have undefined values (B<not> zero, unlike
C<BASIC>). If the SWI generates an error then undefined is returned, and C<$^E>
is set to the error number and message from the error block (I<c.f.> C<$!>). If
there is no error then C<kernelswi> returning a single scalar block of length
40, the packed return results from C<R0> - C<R9>. For example, these may be
converted to an array of integers with code of the form

    @regs = unpack 'I10', $kernelswi_result;

=item B<swix> <name>|<number>, [<mask>, [<value> ...

is similar to the alternative C veneer written by Edward Nevill and Jonathan
Roach and supplied with Acorn C versions 4 and later.

Like C<kernelswi>, S<swix> returns undefined and sets C<$^E> if an error is
generated. If there is no error, S<swix> returns the contents of C<R0>

I<mask> is a bitmask that describes the interpretation to place on the remaining
parameters. If it is omitted it is treated as zero (no parameters). Otherwise it
is best generated by the C<regmask> function. I<mask> B<must> be numeric -
string values are reserved and cause a fatal error at runtime.

=over 4

=item regmask <in>, [<out>, [<block>]]

I<in> and I<out> are references to arrays of register numbers to respectively
pass B<in>to and B<out> from the SWI. If either is undefined it is treated as
an empty array. Registers 0 to 9 can be passed in, 0 to 9 and 15 returned.

If present, I<block> is the number of register to set up to point to any
remaining parameters "left over". This provides a convenient way of generating
parameter blocks for SWIs such as C<Wimp_CreateWindow>.

=back

values follow in register number order - first values to pass in, then scalars
in which the value of registers out are returned. The script must ensure that
these scalars are at least 4 bytes long, as the assembler C<swix> veneer makes
no checks.

Although this interface seems considerably more complex than C<kernelswi>, it
does allow much greater flexibility in exactly which registers are wanted.

Integer results can be retrieved with code such as

    unpack('i', $len)

string results by dereferencing pointers

    unpack('p', $addr)

=item swi

calls C<swix>, returning C<R0 + 0> to ensure a number, or C<die>s with the
numeric and string values of C<$^E> if there was an error.

=back

C<RISCOS::SWI> also provides conversion functions between SWI names and numbers,
and symbolic constants for the 4 ARM flags and the OS 'X' bit.

=over 4

=item V_Flag

=item C_Flag

=item Z_Flag

=item N_Flag

return the bit corresponding to the position of flag in the C<PC/PSR>.

=item XOS_Bit

returns 0x20000 - which when set marks the error returning form of a SWI.

=item SWINumberToString <SWI number>

converts a SWI number to a name using the SWI C<OS_SWINumberToString>.
Returns the name of the SWI, or undefined if there was an error. Unknown
SWI numbers which the SWI C<OS_SWINumberToString> converts to 'C<User>'
or 'C<XUser>' are returned as 'C<User (&C00FEE)>' or 'C<XUser (&0B100D)>'.

=item SWINumberFromString <SWI name>

provides a full inverse to C<SWINumberToString>. "User" SWIs described above
are recognised, as are C<OS_WriteI> variants. Other SWIs numbers are
converted using the SWI C<OS_SWINumberFromString>.

=back

=head1 BUGS

C<swix> doesn't automatically ensure that scalars for return values exist and
are long enough. Additionally the current mask system doesn't allow the script
to specify whether it wants a number, string or fixed length block to be
returned, and let the perl internals convert and assign the return values
automatically. String "masks" are reserved for this purpose.

=head1 AUTHOR

Nicholas Clark <F<[e-mail]>>, based on the previous perl ports.

The C<swi> interface is C<syscall> from the perl 5.001 port. The C<kernelswi>
interface is C<syscall> from the perl 3 port.

=cut