# dyn.load test for Fortran code.
{
   # Pick a dynload function for the test, trying first to use the
   # "dyn.load.functions" dataset, which should exist in all Splus releases
   # after June, 1995 (includes some Splus 3.3 releases, but not all), or
   # failing this, by guessing which dynload is primary to this platform:
   if(exists("dyn.load.functions")) {
      if(any(dyn.load.functions == "dyn.load")) {
         # Run this test with dyn.load():
         DYNLOAD <- dyn.load
         dynload.name <- "dyn.load"
      } else if(any(dyn.load.functions == "dyn.load2")) {
         # Run this test with dyn.load2():
         DYNLOAD <- dyn.load2
         dynload.name <- "dyn.load2"
      } else if(any(dyn.load.functions == "dyn.load.shared")) {
         # Run this test with dyn.load.shared():
         DYNLOAD <- dyn.load.shared
         dynload.name <- "dyn.load.shared"
      } else {
         cat("\nNo dyn.load, dyn.load2 or dyn.load.shared functions found.",
            "Skipping test...\n")
         end.do.test()
      }
   } else {
      # Issue a warning message, guess which dynload to use, and run the
      # test anyway:
      which.dynload <- switch(platform(),
         "OSF1_DECALPHA" = list(dyn.load=F, dyn.load2=F, dyn.load.shared=T),
         "IRIS4D" = list(dyn.load=F, dyn.load2=F, dyn.load.shared=T),
         "SUNOS5_SPARC" = list(dyn.load=T, dyn.load2=F, dyn.load.shared=T),
         "WIN386" = list(dyn.load=F, dyn.load2=F),
         "DOS386" = list(dyn.load=F, dyn.load2=F),
         "HP800" =,
         "HP700" = list(dyn.load=F, dyn.load2=T),
                 list(dyn.load=T, dyn.load2=T)
      )
      if(which.dynload$dyn.load) {
         DYNLOAD <- dyn.load
         dynload.name <- "dyn.load"
      } else if(which.dynload$dyn.load2) {
         DYNLOAD <- dyn.load2
         dynload.name <- "dyn.load2"
      } else if(which.dynload$dyn.load.shared) {
         DYNLOAD <- dyn.load.shared
         dynload.name <- "dyn.load.shared"
      } else {
         cat("Skipping test: No dynload functions found. Should there be any",
            "for this platform?\n")
         end.do.test()
      }
      cat("\nWARNING: dyn.load.functions dataset not found - will use",
         dynload.name, "for test...\n")
   }
   T
}

{
   test.dir <- tempfile("dynloadb")
   unix(paste("mkdir", test.dir))
   source.file <- "test.f"
   object.file <- paste(test.dir, 
      if(dynload.name == "dyn.load.shared") "test.so" else "test.o", sep="/")
   out.file <- "test.out"
   cat(
      "      subroutine dltest(x, y, z, bderr)",
      "      real*4 x, z",
      "      integer y",
      "      logical bderr",
      "      common /bgrp/ am(200)",
      "      common /dlcom1/ one(10)",
      "      common /dlcom2/ two(50)",
      "C     d2 (S_utils.r) should give (exp(x)-1)/x",
      "      x = d2(x)",
      "C     am(10) is par('col')",
      "      y = am(10)",
      "      z = two(10)+two(11)",
      "      bderr = z .eq. 673",
      "      return",
      "      end",
      "      block data bddlcom2",
      "      common /dlcom2/ two(50)",
      "      data two/10*666., 40*7./",
      "      end",
      file=paste(test.dir, source.file, sep="/"), sep="\n"
   )
   temp.file <- tempfile()
   printer(file=temp.file)
   par(col=17)

   # Compile the source code to be loaded:
   comp.cmd <- if(dynload.name == "dyn.load.shared") "SHLIB" else "COMPILE"
   if(unix(paste("cd", test.dir, ";", comp.cmd, source.file,
      ">", out.file, "2>&1"), output=F) != 0) {
      cat(paste("Cannot compile", source.file))
      cat("\nCompile errors:\n")
      unix(paste("cat ", test.dir, "/", out.file, sep=""))
   }

   # Load the fortran code:
   if(dynload.name == "dyn.load.shared") {
      DYNLOAD(object.file, symbols=symbol.For("dltest"))
   } else invisible(any(DYNLOAD(object.file) == symbol.For("dltest"))) 

   # See if the symbol is loaded after dynloading:
   after <- is.loaded(symbol.For("dltest"))
   if(after) {
      # Test the loaded object:
      ftn.return <- list()
      ftn.return <- .Fortran("dltest", as.single(0.1), as.integer(666), 
         as.single(1), F)
      expected <- list(as.single((exp(0.1)-1)/0.1), as.integer(par("col")),
         as.single(673), T)
      result <- all.equal(ftn.return, expected, tolerance=2e-6)
      if(! is.logical(result) || result == F) {
         cat("\nTest of loaded code failed - Expected:\n")
         options(digits=15)
         print(expected); print(lapply(expected, storage.mode))
         cat("Got:\n")
         print(ftn.return); print(lapply(ftn.return, storage.mode))
      }
   } else {
      cat("\nSymbol not found - dynload must have failed?\n")
      result <- F
   }

   dev.off()
   # Remove tempfiles after test:
   on.exit(unix(paste("rm -rf", test.dir))) 
   T
}
{
   # Print test result as a separate expression so the entire test expression
   # doesn't get printed when the test fails (just specific messages):
   result
}