[GR-29739] Fixes for module testing.

PullRequest: fastr/2578

Author: msimacek

com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/altrepApiTests.R

@@ -1,4 +1,4 @@
-# Copyright (c) 2020, Oracle and/or its affiliates. All rights reserved.
+# Copyright (c) 2021, Oracle and/or its affiliates. All rights reserved.
 # DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
 #
 # This code is free software; you can redistribute it and/or modify it
@@ -21,47 +21,58 @@
 
 # Contains tests for some ALTREP API functions for standard vectors.
 
+# Note that for api.*_IS_SORTED we do not care about the return value because there may be
+# different internal representation of data in FastR and GNU-R for the same vector, and both can
+# correctly claim that the data is sorted or that they do not know.
+# The same applies for api.*_NO_NA functions.
+
+stopifnot( require(testrffi))
+
 # Integer API
 integer_api_tests <- function(int_vec) {
-    for (i in 1:length(int_vec)) {
-        api.INTEGER_ELT(int_vec, i)
+    for (i in 0:(length(int_vec) - 1)) {
+        print(api.INTEGER_ELT(int_vec, i))
     }
-    api.INTEGER_IS_SORTED(int_vec)
-    api.INTEGER_NO_NA(int_vec)
+    invisible(api.INTEGER_IS_SORTED(int_vec))
+    invisible(api.INTEGER_NO_NA(int_vec))
 }
 integer_api_tests(1:10)
 integer_api_tests(as.integer(c(14, 51, 157, 42, 20, 15, 15)))
 
 # Real API
 real_api_tests <- function(real_vec) {
-    for (i in 1:length(real_vec)) {
-        api.REAL_ELT(real_vec, i)
+    for (i in 0:(length(real_vec) - 1)) {
+        print(api.REAL_ELT(real_vec, i))
     }
-    api.REAL_IS_SORTED(real_vec)
-    api.REAL_NO_NA(real_vec)
+    invisible(api.REAL_IS_SORTED(real_vec))
+    invisible(api.REAL_NO_NA(real_vec))
 }
-real_api_tests(as.double(1:100))
+real_api_tests(as.double(1:8))
 real_api_tests(as.double(c(0, 0, 0, 0, 1)))
 
 # Logical API
 logical_api_tests <- function(lgl_vec) {
-    for (i in 1:length(lgl_vec)) {
-        api.LOGICAL_ELT(lgl_vec, i)
+    for (i in 0:(length(lgl_vec) - 1)) {
+        print(api.LOGICAL_ELT(lgl_vec, i))
     }
-    api.LOGICAL_IS_SORTED(lgl_vec)
-    api.LOGICAL_NO_NA(lgl_vec)
+    invisible(api.LOGICAL_IS_SORTED(lgl_vec))
+    invisible(api.LOGICAL_NO_NA(lgl_vec))
 }
 logical_api_tests(c(TRUE, TRUE, FALSE, TRUE))
 logical_api_tests(c(TRUE, FALSE))
 logical_api_tests(TRUE)
 
 # String API
 string_api_tests <- function(str_vec) {
-    for (i in 1:length(str_vec)) {
-        api.STRING_ELT(str_vec, i)
+    for (i in 0:(length(str_vec) - 1)) {
+        # api.STRING_ELT returns CHARSXP, which is not correctly handled by GNU-R's print, thus
+        # we wrap it in ScalarString and then print it instead.
+        string_elt <- api.STRING_ELT(str_vec, i)
+        string <- api.Rf_ScalarString(string_elt)
+        print(string)
     }
-    api.STRING_IS_SORTED(str_vec)
-    api.STRING_NO_NA(str_vec)
+    invisible(api.STRING_IS_SORTED(str_vec))
+    invisible(api.STRING_NO_NA(str_vec))
 }
 string_api_tests(c("hello", "world"))
 string_api_tests(c(""))
@@ -70,6 +81,6 @@ string_api_tests(c("a", "b", "c"))
 
 # Raw API
 raw_vec <- as.raw(c(12, 117, 45, 0, 1))
-for (i in 1:length(raw_vec)) {
-    api.RAW_ELT(raw_vec, i)
+for (i in 0:(length(raw_vec) - 1)) {
+    print(api.RAW_ELT(raw_vec, i))
 }

com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/rapiTests.R

@@ -75,12 +75,6 @@ assertEquals(NULL, api.SET_ATTRIB(x, as.pairlist(list(names=c('a','b')))))
 assertEquals(c('a','b'), names(x))
 # note: printing x on GNU-R causes segfault
 
-# ---------------------------------------------------------------------------------------
-# Rf_mkCharLenCE, note: last arg is encoding and 0 ~ native encoding
-
-assertEquals("hello world", api.Rf_mkCharLenCE("hello world", 11, 0))
-ignore("FastR bug", assertEquals("hello", api.Rf_mkCharLenCE("hello this will be cut away", 5, 0)))
-
 
 # ----------------------------------------------------------------------------------------
 # Rf_eval

com.oracle.truffle.r.test.packages/pkgtest/__init__.py

@@ -1,5 +1,5 @@
 #
-# Copyright (c) 2016, 2020, Oracle and/or its affiliates. All rights reserved.
+# Copyright (c) 2016, 2021, Oracle and/or its affiliates. All rights reserved.
 # DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
 #
 # This code is free software; you can redistribute it and/or modify it
@@ -188,7 +188,7 @@ def _run_install_packages_script(rscript_path, args, kwargs):
 
 def _fastr_installpkgs(args, **kwargs):
     """
-    Runs 'install.packages.R' script with GnuR.
+    Runs 'install.packages.R' script with fastr.
     """
     if "FASTR_WORKING_DIR" in os.environ:
         env["TMPDIR"] = os.environ["FASTR_WORKING_DIR"]
@@ -362,10 +362,10 @@ def __init__(self):
         self.install_data = None
         self.pkg = None
         self.mode = None
-        self.start_install_pattern = re.compile(r"^BEGIN processing: (?P<package>[a-zA-Z0-9\.\-]+) .*")
-        self.test_pattern = re.compile(r"^(?P<status>BEGIN|END) testing: (?P<package>[a-zA-Z0-9\.\-]+) .*")
-        self.time_pattern = re.compile(r"^TEST_TIME: (?P<package>[a-zA-Z0-9\.\-]+) (?P<time>[0-9\.\-]+) .*")
-        self.status_pattern = re.compile(r"^(?P<package>[a-zA-Z0-9\.\-]+): (?P<status>OK|FAILED).*")
+        self.start_install_pattern = re.compile(r"^BEGIN processing:\s*(?P<package>[a-zA-Z0-9.-]+)")
+        self.test_pattern = re.compile(r"^(?P<status>BEGIN|END) testing:\s*(?P<package>[a-zA-Z0-9.-]+)")
+        self.time_pattern = re.compile(r"^TEST_TIME:\s*(?P<package>[a-zA-Z0-9.-]+) (?P<time>[0-9.-]+)")
+        self.status_pattern = re.compile(r"^(?P<package>[a-zA-Z0-9.-]+):\s*(?P<status>OK|FAILED)")
         self.install_data = dict()
         self.install_status = dict()
         self.test_info = dict()

com.oracle.truffle.r.test.packages/pkgtest/fuzzy_compare.py

@@ -1,5 +1,5 @@
 #
-# Copyright (c) 2019, 2020, Oracle and/or its affiliates. All rights reserved.
+# Copyright (c) 2019, 2021, Oracle and/or its affiliates. All rights reserved.
 # DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
 #
 # This code is free software; you can redistribute it and/or modify it
@@ -195,9 +195,9 @@ def _get_next_line(prompt, content, content_len, line_idx):
     while i < content_len:
         line = content[i]
         if prompt is not None:
-            line = line.replace(prompt, "", 1);
-        line = line.strip();
-        if line is not "":
+            line = line.replace(prompt, "", 1)
+        line = line.strip()
+        if line != "":
             return line, i
         i = i + 1
     return None, i
@@ -264,10 +264,10 @@ def _is_ignored_function(fun_name, gnur_content, gnur_stmt, fastr_content, fastr
 
 def _is_statement_begin(captured_prompt, line):
     if captured_prompt is None:
-        return False;
-    if not line is None:
+        return False
+    if line is not None:
         line_wo_prompt = line.replace(captured_prompt, "").strip()
-        return line.startswith(captured_prompt) and line_wo_prompt is not "" and not line_wo_prompt.startswith("#")
+        return line.startswith(captured_prompt) and line_wo_prompt != "" and not line_wo_prompt.startswith("#")
     return False
 
 

com.oracle.truffle.r.test.packages/r/install.cache.R

@@ -174,7 +174,6 @@ pkg.cache.get <- function(pkg.cache.env, pkg, lib) {
     }
 
     pkg.name <- as.character(pkg["Package"])
-    pkg.version <- as.character(pkg["Version"])
 
     log.message("using package cache directory ", version.dir, level=1)
     cache.entry.name <- pkg.cache.entry.filename(pkg)
@@ -251,7 +250,6 @@ pkg.cache.insert <- function(pkg.cache.env, pkg, lib) {
     }
 
     tryCatch({
-        pkg.version <- as.character(pkg["Version"])
         fromPath <- file.path(lib, pkgname)
         cache.entry.name <- pkg.cache.entry.filename(pkg)
         toPath <- pkg.cache.file.path(pkg.cache.env, version.dir, cache.entry.name)
@@ -263,6 +261,9 @@ pkg.cache.insert <- function(pkg.cache.env, pkg, lib) {
         # cleanup older package versions
         pkg.cache.cleanup.pkg.versions(pkg.cache.env, version.dir, pkgname)
 
+        if (file.exists(toPath)) {
+            file.remove(toPath)
+        }
         if(zip(toPath, pkgname, flags="-r9Xq") != 0L) {
             pkg.cache.unlock(pkg.cache.env, version.dir)
             log.message("could not compress package dir ", fromPath , " and store it to ", toPath, level=1)

com.oracle.truffle.r.test.packages/r/install.packages.R

@@ -628,7 +628,7 @@ install.pkgs <- function(pkgnames, dependents.install=F, log=T) {
 	result <- TRUE
 	for (pkgname in pkgnames) {
 		if (log) {
-			log.message.always("BEGIN processing:", pkgname, "\n")
+			log.message.always("BEGIN processing: ", pkgname, "\n")
 			log.timestamp()
 		}
 		dependent.install.ok <- T
@@ -643,12 +643,12 @@ install.pkgs <- function(pkgnames, dependents.install=F, log=T) {
 				# 3. a mixture of TRUE and NA: ok, but some more to install (the NAs)
 				if (any(!dep.status, na.rm=T)) {
 					# case 2
-					log.message.always("not installing dependents of:", pkgname, ", one or more previously failed", "\n")
+					log.message.always("not installing dependents of: ", pkgname, ", one or more previously failed", "\n")
 					dependent.install.ok <- F
 				} else {
 					if (anyNA(dep.status)) {
 						# case 3
-						log.message.always("installing dependents of:", pkgname, "\n")
+						log.message.always("installing dependents of: ", pkgname, "\n")
 						dependent.install.ok <- install.pkgs(dependents, dependents.install=T)
 					} else {
 						# case 1
@@ -661,7 +661,7 @@ install.pkgs <- function(pkgnames, dependents.install=F, log=T) {
 			cat("would install:", pkgname, "\n")
 		} else {
 			if (!dependent.install.ok) {
-				log.message.always("not installing:", pkgname, "dependent install failure","\n")
+				log.message.always("not installing: ", pkgname, "dependent install failure","\n")
 			} else {
 				should.install <- T
 				if (pkgname %in% names(install.status)) {
@@ -678,7 +678,7 @@ install.pkgs <- function(pkgnames, dependents.install=F, log=T) {
 					}
 				}
 				if (should.install) {
-					log.message.always("installing:", pkgname, "(", install.count, "of", install.total, ")", "\n")
+					log.message.always("installing: ", pkgname, "(", install.count, "of", install.total, ")", "\n")
 					log.timestamp()
 					this.result <- install.pkg(pkgname)
 					result <- result && this.result
@@ -688,12 +688,12 @@ install.pkgs <- function(pkgnames, dependents.install=F, log=T) {
 					}
 				} else {
 					msg <- if (install.status[pkgname]) "already installed" else "failed earlier"
-					log.message.always("not installing:", pkgname, "(", install.count, "of", install.total, ")", msg)
+					log.message.always("not installing: ", pkgname, "(", install.count, "of", install.total, ")", msg)
 				}
 			}
 		}
 		if (log) {
-			log.message.always("END processing:", pkgname, "\n")
+			log.message.always("END processing: ", pkgname, "\n")
 		}
 
 		install.count = install.count + 1
@@ -711,15 +711,15 @@ install.suggests <- function(pkgnames) {
 				ignore <- c(ignore, suggests[grepl(ignore.pattern[[i]], suggests)])
 			}
 			suggests <- if (class(ignore.pattern) == 'negation') ignore else setdiff(suggests, ignore)
-			log.message("NOTE: ignoring suggested:", paste(ignore, collapse=','))
+			log.message("NOTE: ignoring suggested: ", paste(ignore, collapse=','))
 		}
 		if (length(suggests) > 0) {
 			if (is.fastr() && !ignore.blacklist) {
 				# no point in trying to install blacklisted packages (which are likely)
 				blacklist <- get.blacklist()
 				nsuggests <- suggests[!suggests %in% blacklist]
 				if (length(nsuggests) != length(suggests)) {
-					log.message("not installing Suggests of:", pkgname, ", one or more is blacklisted: ", paste0(suggests[suggests %in% blacklist], collapse=","))
+					log.message("not installing Suggests of: ", pkgname, ", one or more is blacklisted: ", paste0(suggests[suggests %in% blacklist], collapse=","))
 					return()
 				}
 			}
@@ -730,11 +730,11 @@ install.suggests <- function(pkgnames) {
 			# 3. a mixture of TRUE and NA: ok, but some more to install (the NAs)
 			if (any(!dep.status, na.rm=T)) {
 				# case 2
-				log.message("not installing Suggests of:", pkgname, ", one or more previously failed")
+				log.message("not installing Suggests of: ", pkgname, ", one or more previously failed")
 			} else {
 				if (anyNA(dep.status)) {
 					# case 3
-					log.message("installing Suggests of:", pkgname,":",paste(suggests[is.na(dep.status)], sep=", "))
+					log.message("installing Suggests of: ", pkgname, ": ", paste(suggests[is.na(dep.status)], sep=", "))
 					dependent.install.ok <- install.pkgs(suggests[is.na(dep.status)], dependents.install=F, log=F)
 				} else {
 					# case 1
@@ -785,7 +785,7 @@ show.install.status <- function(test.pkgnames) {
 do.it <- function() {
 	log.message("Getting the list of packages to install", level = 2)
 	test.pkgnames <- get.pkgs()
-	log.message("List of packages to install:", paste0(test.pkgnames, collapse=","), level = 2)
+	log.message("List of packages to install: ", paste0(test.pkgnames, collapse=","), level = 2)
 
 	if (list.versions) {
 		for (pkgname in test.pkgnames) {
@@ -837,12 +837,12 @@ do.it <- function() {
 				if (dry.run) {
 					cat("would test:", pkgname, "\n")
 				} else {
-					log.message.always("BEGIN testing:", pkgname, "(", test.count, "of", test.total, ")")
+					log.message.always("BEGIN testing: ", pkgname, "(", test.count, "of", test.total, ")")
 					test.package(pkgname)
-					log.message.always("END testing:", pkgname)
+					log.message.always("END testing: ", pkgname)
 				}
 			} else {
-				log.message.always("install failed, not testing:", pkgname)
+				log.message.always("install failed, not testing: ", pkgname)
 			}
 			test.count = test.count + 1
 		}
@@ -936,7 +936,7 @@ test.package <- function(pkgname) {
         res <- 1L
     }
 	end.time <- proc.time()[[3]]
-	log.message("TEST_TIME:", pkgname, end.time - start.time)
+	log.message("TEST_TIME: ", pkgname, end.time - start.time)
     return (res)
 }
 
@@ -1147,7 +1147,7 @@ quiet <- F
 verbose <- F
 very.verbose <- F
 log.file <- file.path(getwd(), 'install.packages.R.log')
-cat("The output is also logged into:", log.file, "\n")
+cat("The output is also logged into: ", log.file, "\n")
 
 loggable <- function(level) {
 	result <- T