# dynload # Test one of (dyn.load, dyn.load2, dyn.load.shared) with C object code # compiled with both default and debug options. if(switch(platform(), HP700=, HP800=T, F)) { cat("This test is known to fail on HP700/HP800. Function pointers", "cannot be set to addresses of functions in Sqpe, with dyn.load2.", "This is still true as of 3.2 release. Skipping dynload test...", sep="\n") end.do.test() } else T { # 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), "IRIX4D" = 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 dyn.load or dyn.load2 on this platform.\n") end.do.test() } cat("\nWARNING: dyn.load.functions dataset not found - will use", dynload.name, "for test...\n") } T } { # check dyn.load. sbug 8/1/91 bill dl.test1.c<- c( "#include ", "#include ", "static double dl_test_aux() ; /* in TEXT */", "typedef double (*pfd)() ;", "static pfd func_exp = exp ; /* in DATA, external relocation */", "static pfd func_log ; /* in BSS */", "static pfd func_aux = dl_test_aux ; /* in DATA, reloc'n rel to TEXT */", "static char mybuf[1020] ; /* in BSS */", "static char *dl_test_pattern = \"XY\" ; /* in DATA */", "static char *six = &mybuf[2] ; /* in DATA, relocation rel to BSS */", "", "void", "dl_test1(x, err, msg)", "double *x ;", "long *err ;", "char **msg ;", "{", " *err = 0 ;", " if (func_exp(*x) != exp(*x)) {", " *err |= 1L<<0 ;", " fprintf(stderr, \"Problem : func_exp(%g)=%g, exp(%g)=%g\\n\",", " *x, func_exp(*x), *x, exp(*x)) ;", " }", " /*", " * func_log= and log() cause relocation in TEXT rel to external,", " * but the first is not a function call and the second is. Often", " * this results in ordinary vs. pc relative relocation types.", " */", " func_log = log ;", " if (func_log(*x) != log(*x)) {", " *err |= 1L<<1 ;", " fprintf(stderr, \"Problem : func_log(%g)=%g, log(%g)=%g\\n\",", " *x, func_log(*x), *x, log(*x)) ;", " }", " if (func_aux(*x) != log(*x)) {", " *err |= 1L<<2 ;", " fprintf(stderr, \"Problem : func_aux(%g)=%g, log(%g)=%g\\n\",", " *x, func_aux(*x), *x, log(*x)) ;", " }", " mybuf[0] = dl_test_pattern[1] ;", " (void)sprintf(&mybuf[1], \" 6 reps : %g, %g, %g, %g, %g, %g, err=\",", " *x, *x, *x, *x, *x, *x) ;", " if (*six != \'6\') {", " *err |= 1L<<3 ;", " fprintf(stderr, \"Problem : mybuf=%s\\n\", mybuf) ;", " }", " (void)sprintf(mybuf+strlen(mybuf), \"%ld\", *err) ;", " fflush(stderr) ;", " fprintf(stdout, \"%s\\n\", mybuf) ; fflush(stdout) ;", " *x = 2.0 * *x ;", " *msg = mybuf ;", "}", "", "static double", "dl_test_aux(x)", "double x ;", "{", " return log(x) ;", "}", "" ) # use a subdirectory of /tmp instead of /tmp itself, in case we Splus MAKE # the .o someday instead of directly invoking cc: test.dir <- tempfile("dl_dir") test.src.file <- "dl_test1.c" test.obj.file <- if(dynload.name == "dyn.load.shared") "dl_test1.so" else "dl_test1.o" test.src.path <- paste(test.dir, test.src.file, sep="/") dl.cleanup <- function(dir) unix(paste("rm -rf", dir), output.to.S=F) compile.options <- switch(dynload.name, "dyn.load" = c("default", "debug"), "dyn.load2" = c("default", "debug"), "dyn.load.shared" = "default" ) for(option in compile.options) { # Run the test once for each set of compile options: dl.cleanup(test.dir) unix(paste("mkdir", test.dir)) cat(dl.test1.c, sep="\n", file=test.src.path) # Compile the source code to be loaded: if(dynload.name == "dyn.load.shared") { # Compile with the SHLIB script (dyn.load.shared): if(unix(paste("cd", test.dir, ";", "SHLIB", test.obj.file, test.src.file, "> ./compile.out 2>&1"), output=F) != 0) { cat(paste("Cannot compile", test.src.path)) cat("\nCompile errors:\n") unix(paste("cat ", test.dir, "/compile.out", sep="")) } } else { # Compile with the COMPILE script (dyn.load and dyn.load2): compile.cmd <- if(option == "debug") "COMPILE CFLAGS=-g" else "COMPILE" ## Create a makefile and specify debug option: #unix(paste("cd", test.dir, "; echo 'CFLAGS=-g' > ./Makefile;", # "echo 'FFLAGS=-g' >> ./Makefile")) if(unix(paste("cd", test.dir, ";", compile.cmd, test.src.file, "> ./compile.out 2>&1"), output=F) != 0) { cat(paste("Cannot compile", test.src.path)) cat("\nCompile errors:\n") unix(paste("cat ", test.dir, "/compile.out", sep="")) } } # Load the compiled code: if(dynload.name == "dyn.load.shared") { # dyn.load.shared returns NULL. Just make sure symbol is loaded: DYNLOAD(paste(test.dir, test.obj.file, sep="/")) if(symbol.C("dl_test1") != "dl_test1") stop("dyn.load.shared or symbol.C broken") } else { # dyn.load and dyn.load2 return a list of symbols that were loaded: if(!any(DYNLOAD(paste(test.dir, test.obj.file, sep="/")) == symbol.C("dl_test1"))) stop("dyn.load[2] or symbol.C broken") } # Test the loaded code: test.out <- tempfile() #cat("Expect to see \"Y 6 reps : 1, 1, 1, 1, 1, 1, err=0\" vvv\n") sink(file=test.out) result <- all.equal(.C("dl_test1", as.double(1), as.integer(666), "foo"), list(as.double(2), as.integer(0), "Y 6 reps : 1, 1, 1, 1, 1, 1, err=0")) sink() if(result) { unlink(test.out) } else { cat("\nFAIL: Bad results from executing dyn.loaded code.") cat("\nThese compile flags were used for the test.", "Are they the right ones?:\n") cat(cflags) cat("Here is the test output:\n") unix(paste("cat", test.out)) } } # Cleanup: dl.cleanup(test.dir) for(obj in c("DYNLOAD", "cflags.dflt", "cflags")) if(exists(obj)) remove(obj) 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 }