GateAOS4.pl

### Class GateAOS4: Create a AmigaOS gatestub file ############################

BEGIN {
    package GateAOS4;
    use vars qw(@ISA);
    @ISA = qw( Gate );

    sub new {
      my $proto  = shift;
      my $class  = ref($proto) || $proto;
      my $self   = $class->SUPER::new( @_ );
      bless ($self, $class);
      return $self;
    }

    sub header {
      my $self = shift;
      my $sfd  = $self->{SFD};
      
      $self->SUPER::header (@_);

      print "#undef __USE_INLINE__\n";
      print "#define _NO_INLINE\n";
      print "#define __NOLIBBASE__\n";
      print "#define __NOGLOBALIFACE__\n";
      print "#include <proto/$sfd->{basename}.h>\n";
      print "#undef _NO_INLINE\n";
      print "#undef __NOLIBBASE__\n";
      print "#undef __NOGLOBALIFACE__\n";
      print "#include <stdarg.h>\n";
      print "#include <interfaces/exec.h>\n";
      print "#include <exec/emulation.h>\n";
      print "\n";
    }

    sub function {
      my $self     = shift;
      my %params    = @_;
      my $prototype = $params{'prototype'};
      my $sfd       = $self->{SFD};

      if ($prototype->{type} eq 'function' ||
          $prototype->{type} eq 'varargs' ) {
          $self->function_proto (prototype => $prototype);
          $self->function_start (prototype => $prototype);
          for my $i (0 .. $$prototype{'numargs'} - 1 ) {
            $self->function_arg (prototype => $prototype,
                             argtype   => $$prototype{'argtypes'}[$i],
                             argname   => $$prototype{'___argnames'}[$i],
                             argreg    => $$prototype{'regs'}[$i],
                             argnum    => $i );
          }
          $self->function_end (prototype => $prototype);
          
          print "\n";

          if ($prototype->{type} eq 'function' && $prototype->{bias} != 0) {
            if (!$self->{PROTO}) {
                $self->emu_function_start (prototype => $prototype);
                for my $i (0 .. $$prototype{'numargs'} - 1 ) {
                  $self->emu_function_arg (prototype => $prototype,
                                     argtype   => $$prototype{'argtypes'}[$i],
                                     argname   => $$prototype{'___argnames'}[$i],
                                     argreg    => $$prototype{'regs'}[$i],
                                     argnum    => $i );
                }
                $self->emu_function_end (prototype => $prototype);
            }

            $self->emu_trap (prototype => $prototype);
          }
      }
    }
    
    sub function_start {
      my $self      = shift;
      my %params    = @_;
      my $prototype = $params{'prototype'};
      my $sfd       = $self->{SFD};

      print "$prototype->{return}";
      if ($prototype->{type} eq 'varargs') {
          print " VARARGS68K";
      }
      print "\n";
      print "$gateprefix$prototype->{funcname}(";
      if ($prototype->{type} eq 'function' &&
          $prototype->{subtype} =~ /^(library|device|boopsi)$/) {
          # Special function prototype

          if ($prototype->{bias} == 0) {
            # Do nothing
          }
          elsif ($prototype->{subtype} eq 'library' ||
               $prototype->{subtype} eq 'boopsi') {
            print "struct LibraryManagerInterface* _iface";
          }
          elsif( $prototype->{subtype} eq 'device') {
            print "struct DeviceManagerInterface* _iface";
          }
      }
      else {
          print "struct $sfd->{BaseName}IFace* _iface";
      }
    }

    sub function_arg {
      my $self      = shift;
      my %params    = @_;
      my $prototype = $params{'prototype'};
      my $argtype   = $params{'argtype'};
      my $argname   = $params{'argname'};
      my $argreg    = $params{'argreg'};
      my $argnum    = $params{'argnum'};
      my $sfd       = $self->{SFD};

      if ($prototype->{subtype} ne 'tagcall' ||
          $argnum ne $prototype->{numargs} - 2) {

          if ($argnum != 0 || $prototype->{bias} != 0) {
            print ",\n";
          }

          if ($prototype->{subtype} =~ /^(library|device|boopsi)$/ &&
            $prototype->{bias} == 0 &&
            $argnum == $prototype->{numargs} - 1 ) {
            print "     struct ExecIFace* _iface";
          }
          else {
            print "     $prototype->{___args}[$argnum]";
          }
      }
    }
    
    sub function_end {
      my $self      = shift;
      my %params    = @_;
      my $prototype = $params{'prototype'};
      my $sfd       = $self->{SFD};

      if ($self->{PROTO}) {
          print ");\n";
      }
      else {
          print ")\n";
          print "{\n";
          
          if ($prototype->{subtype} =~ /^(library|device|boopsi)$/ &&
            $prototype->{bias} == 0) {
            print "  $prototype->{___args}[$prototype->{numargs} - 1] = ".
                "($prototype->{argtypes}[$prototype->{numargs} - 1]) " .
                "_iface->Data.LibBase;\n";
          }
          
          if ($prototype->{type} ne 'varargs') {
            print "  return $libprefix$prototype->{funcname}(";

            if ($libarg eq 'first' && !$prototype->{nb}) {
                print "($sfd->{basetype}) _iface->Data.LibBase";
                print $prototype->{numargs} > 0 ? ", " : "";
            }

            print join (', ', @{$prototype->{___argnames}});

            if ($libarg eq 'last' && !$prototype->{nb}) {
                print $prototype->{numargs} > 0 ? ", " : "";
                print "($sfd->{basetype}) _iface->Data.LibBase";
            }
          }
          else {
            my $na;

            if ($prototype->{subtype} eq 'tagcall') {
                $na = $prototype->{numargs} - 3;
            }
            elsif ($prototype->{subtype} eq 'printfcall') {
                $na = $prototype->{numargs} - 2;
            }
            else {
                # methodcall: first vararg is removed
                $na = $prototype->{numargs} - 3;
            }
            
            print "  va_list _va;\n";
            print "  va_startlinear (_va, ";
            if ($na >= 0) {
                print "$prototype->{___argnames}[$na]);\n";
            }
            else {
                print "_iface);\n"
            }

            print "  return $libprefix$prototype->{real_funcname}(";

            if ($libarg eq 'first' && !$prototype->{nb}) {
                print "($sfd->{basetype}) _iface->Data.LibBase";
                print $prototype->{numargs} > 0 ? ", " : "";
            }

            for (my $i = 0; $i <= $na; ++$i) {
                print "@{$prototype->{___argnames}}[$i], ";
            }

            print "va_getlinearva (_va, " .
                "$prototype->{argtypes}[$prototype->{numargs}-1])";
            
            if ($libarg eq 'last' && !$prototype->{nb}) {
                print $prototype->{numargs} > 0 ? ", " : "";
                print "($sfd->{basetype}) _iface->Data.LibBase";
            }
          }
      
          print ");\n";
          print "}\n";
      }
    }


    sub emu_function_start {
      my $self      = shift;
      my %params    = @_;
      my $prototype = $params{'prototype'};
      my $sfd       = $self->{SFD};

      print "STATIC $prototype->{return} \n";
      print "$gateprefix$prototype->{funcname}PPC(ULONG *regarray)\n";
      print "{\n";
      print "  struct Library * _base = (struct Library *) regarray[REG68K_A6/4];\n";
      print "  struct ExtendedLibrary * ExtLib = (struct ExtendedLibrary *) ((ULONG) _base + _base->lib_PosSize);\n";
      
      if ($prototype->{subtype} =~ /^(library|device|boopsi)$/) {
          # Special function prototype

          if ($prototype->{bias} == 0) {
            # Do nothing
          }
          elsif ($prototype->{subtype} eq 'library' ||
               $prototype->{subtype} eq 'boopsi') {
            print "  struct LibraryManagerInterface* _iface = ";
            print "ExtLib->ILibrary;\n";
          }
          elsif( $prototype->{subtype} eq 'device') {
            print "  struct DeviceManagerInterface* _iface = ";
            print "ExtLib->IDevice;\n";
          }
      }
      else {
          print "  struct $sfd->{BaseName}IFace* _iface = ";
          print "(struct $sfd->{BaseName}IFace*) ExtLib->MainIFace;\n";
      }
    }

    sub emu_function_arg {
      my $self      = shift;
      my %params    = @_;
      my $prototype = $params{'prototype'};
      my $argtype   = $params{'argtype'};
      my $argname   = $params{'argname'};
      my $argreg    = $params{'argreg'};
      my $argnum    = $params{'argnum'};
      my $sfd       = $self->{SFD};

      print "  $prototype->{___args}[$argnum] = ($argtype) regarray[REG68K_" .
          (uc $argreg) . "/4];\n";
    }
    
    sub emu_function_end {
      my $self      = shift;
      my %params    = @_;
      my $prototype = $params{'prototype'};
      my $sfd       = $self->{SFD};

      print "\n";

      my $funcname = $prototype->{funcname};
      
      if ($prototype->{subtype} eq 'library' ||
          $prototype->{subtype} eq 'device' ||
          $prototype->{subtype} eq 'boopsi') {

          if ($prototype->{bias} == 6) {
            $funcname = "Open";
          }
          elsif ($prototype->{bias} == 12) {
            $funcname = "Close";
          }
          elsif ($prototype->{bias} == 18 ||
               $prototype->{bias} == 24) {
            print "  return 0;\n";
            print "}\n";
            print "\n";
            return;
          }

          if ($prototype->{subtype} eq 'device') {
            if ($prototype->{bias} == 30) {
                $funcname = "BeginIO";
            }
            elsif ($prototype->{bias} == 36) {
                $funcname = "AbortIO";
            }
          }
      }
      
      print "  return _iface->$funcname(";
      print join (', ', @{$prototype->{___argnames}});

      if ($prototype->{subtype} eq 'device' && ($prototype->{bias} == 36)) {
          print "), 0;  /* Return type changed to VOID in OS4?! */\n";
      }
      else {
          print ");\n";
      }
      print "}\n";
      print "\n";
    }
    
    sub emu_trap {
      my $self      = shift;
      my %params    = @_;
      my $prototype = $params{'prototype'};
      my $sfd       = $self->{SFD};

      if ($self->{PROTO}) {
          print "extern ";
      }

      print "CONST struct EmuTrap m68k$gateprefix$prototype->{funcname}";

      if (!$self->{PROTO}) {
          print " = { TRAPINST, TRAPTYPE, (ULONG (*)(ULONG *)) $gateprefix$prototype->{funcname}PPC }";
      }
      
      print ";\n";
      print "\n";
    }
}