old.opt <- options(warn=1, echo=F)

stampfil <- date()	# stamp when this file was sourced; see bin/LOOP

"do.test.ssi"<-
function(file, track = getenv("DO_TEST_TRACK") != "")
{
# track=T: print every expression and how much memory and time it took.
#
# Returns T for successful test.
#
        assign("test.ok", T, frame=0)
	assign("DO.TEST.FRAME.N", value = sys.nframe(), frame = 0)
	# used by end.do.test()
	if(!exists("PROC.TIME", mode = "function")) PROC.TIME <- switch(
			platform(),
			DOS386 = proc.time,
			function()
			proc.time()[3])
	E <- parse(file = file, n = -1)
	if(track) {
		pt0 <- PROC.TIME()
		ms0 <- memory.size()
		cat(
			"Cumulative time & memory stats' baseline set to zero here (after parsing file).\n"
			)
		for(I in seq(along = E)) {
			cat("expr:\n")
			print(E[[I]])
			pt1 <- PROC.TIME()
			ms1 <- memory.size()
			val <- eval(E[[I]], F)
			pt2 <- PROC.TIME()
			ms2 <- memory.size()
			print(structure(.Data = c(pt2 - pt1, pt2 - pt0,
				ms2 - ms1, ms2 - ms0), .Names = c(
				"time (incr)", "time (cumul)", "mem (incr)",
				"mem (cumul)")))
			ok <- !(mode(val) != "logical" || length(val) !=
				1 || is.na(val) || !val)
			if(!ok)
				print(val)	# e.g. ret value of all.equal
			cat("< test", if(!ok) "failed" else "passed", 
				">\n----------\n")
                        assign("test.ok", ok, frame=0)
		}
	}
	else {
		for(I in seq(along = E)) {
			val <- eval(E[[I]], F)
			if(mode(val) != "logical" || length(val) != 1 ||
				is.na(val) || !val) {
				print(E[[I]])
				print(val)
                                assign("test.ok", F, frame=0)
			}
		}
	}
	invisible(get("test.ok", frame=0))
}
"end.do.test"<-
function()
{
# evaluate a 'break' in the frame of do.test.ssi. This stops testing.
	eval(expression(break)[[1]], local = get("DO.TEST.FRAME.N", frame = 0))
	
}
# Now do.test from AT&T does eval(,local=F) too. do.test.ssi() changed
# accordingly.
# "do.test.global"<-
# function(file)
# {
# 	assign("DO.TEST.FRAME.N", value = sys.nframe(), frame = 0)
# 	# used by end.do.test()
# 	e <- parse(file = file, n = -1)
# 	for(i in seq(along = e)) {
# 		val <- eval(e[[i]], local = F)
# 		if(mode(val) != "logical" || length(val) != 1 || is.na(val) ||
# 			!val) {
# 			print(e[[i]])
# 			print(val)
# 		}
# 	}
# 	invisible(NULL)
# }
"assert"<-
function(x, message = NULL)
{
	e <- substitute(x)	# 	cat("e is", e, "\n")
	if(!(value <- as.logical(eval(e, local = sys.parent())))) {
		if(is.null(message)) {
			all.calls <- sys.calls()	
	# deparse() for human-like output:
			message <- paste("assertion failed, expression", 
				deparse(e), ", in function", as.character(
				all.calls[[length(all.calls) - 1]][[1]]))
		}
		cat(message, "\n")
	}
	invisible(value)
}
"eval.and.recover"<-
function(expr1, expr2 = cat("\n\nTest ran to completion.\n"), restarted = F)
{
# Evaluate an error-producing expression, and keep going.  Example
# "f"<-
# function()
# {
# 	aaa <- "A"
# 	cat("Expect an error and 'Dumped'\n")
# 	eval.and.recover(sin(aaa))
# 	cat("After the errror.\n")
# }
	if(!restarted) {
		restart(T)
		restarted <- T
		expr1
	}
	else expr2
}
"causes.error"<-
function(e1, e2 = NULL, bad.call = deparse(substitute(e1)), message = "")
{
# Return e2, whose default value is TRUE or FALSE
# depending on whether the evaluation of expression e1 produced an
# error with message 'message'. Since eval.and.recover is used, and
# it calls restart(T), evaluation proceeds after the error. This
# function could probably be combined into eval.and.recover if it
# weren't for a bug that causes a system termination when restart(T)
# is called from the same function that plays with options(error).
#
# Argument bad.call is a string which should be used in place of the deparsed
# e1 in writing a note to ignore the error message. Useful if e1 is e.g.
# eval(expression(E), local=F), for then by default the note will read "Error in
# eval(expression(E), local=F): ..." but the error message will read 
# "Error in E: ...".
#
# Example:
# > causes.error(1+"a", message="Non-numeric second operand")
# IGNORE "Error in 1 + "a": Non-numeric second operand" vvv
# Error in 1 + "a": Non-numeric second operand
# IGNORE "Error in 1 + "a": Non-numeric second operand" ^^^
# Correct error was generated.
# [1] T
# 
	if(exists(".last.error.msg", frame = 0)) remove(".last.error.msg",
			frame = 0)
	old.err.opt <- options(error = expression(assign(".last.error.msg",
		.C("get_last_message",
		"")[[1]], frame = 0)))
	ignore <- paste(sep = "", "IGNORE \"Error in ", bad.call, ": ", message,
		"\"")
	cat("\n") ; cat(paste(ignore, "vvv\n"))
	eval.and.recover(e1, expression())
	cat(paste(ignore, "^^^\n"))
	options(old.err.opt)
	on.exit(if(exists(".last.error.msg", frame = 0)) remove(
			".last.error.msg", frame = 0))
	if(is.null(e2)) {
		e2 <- exists(".last.error.msg", frame = 0) && .last.error.msg ==
			message
		cat(if (e2) "Correct" else "WRONG", "error was generated.\n")
# 		cat("Test", if(e2) "passed\n" else "failed\n")
	}
	cat("\n")
	e2
}
"base.convert"<-
function(x, inbase = 16, outbase = 2)
{
# Takes a vector of character strings with digits in base 'inbase', returns
# a similar vector with representations in base 'outbase'. Because we use
# unix(input=), it happens to work even if x is numeric but consists of only
# digits from 0-9 (of course).
#
# first change things like ff, 0xff, 0XFF, to FF, else dc barfs:
	data <- paste(unix("tr \\[a-z\\] \\[A-Z\\] | sed 's/^0X//'", input = x),
		"p")
	unix(paste("(echo", outbase, "o", inbase, "i; cat) | dc"), input = data
		)
}
tty.msg <-
switch(platform(),
	DOS386 = function(...) cat(..., file="con"),
	         function(...) cat(..., file="/dev/tty")
	)

is.readable <-
switch(platform(),
	DOS386 = function(x) 0 == access(x, 4),
		 function(x) 0 == unix(paste("test -r", x), output=F))

is.executable <-
switch(platform(),
	DOS386 = function(x) 0 == access(x, 7),
	DECSTATION = function(x) is.readable(x) && 0 == unix(paste(sep='',
	"test A`find ", x," -perm -100 -print` = A", x), output=F),
	APOLLO = function(x) 0 == unix(paste('SYSTYPE=sys5.3 sh -c "',paste("test -x", x), '"'), output=F),
		 function(x) 0 == unix(paste("test -x", x), output=F))

files.same <-
switch(platform(),
	DOS386 = function(file1, file2)
	{
		f1 <- scan(file1, what = "")
		f2 <- scan(file2, what = "")
		all(f1 == f2)
	}
	,
	function(file1, file2)
	0 == unix(paste("cmp -s", file1, file2), out = F))

# Use dummy.device.on() and dummy.device.off() for situations when a device 
# must be open for a test to run, but the graphics itself is not of interest.
# Lots of these in the loop tests under ~stest/loop.tests.

dummy.device.on <-
switch(platform(),
	DOS386 = function(file=tempfile()) {
			if (exists(".dummy.device.file", where=1))
				stop("can have only one dummy device at a time")
			printer(file=file)
			assign(".dummy.device.file", file, where=1)
			invisible(file)
		},
	function() invisible(printer(file="/dev/null"))
)
dummy.device.off <-
switch(platform(),
	DOS386 = function(file=get(".dummy.device.file", where=1)) {
			dev.off()	# printer()
			unlink(file)
			remove(".dummy.device.file", where=1)
		},
	function() invisible(dev.off())
)

"Order"<-
function(x)
{
# return the order of x in base 10; define 0 to have order 0.
	ifelse(x == 0, 0, floor(log10(abs(x))))
}
"vectors.equal"<-
function(current, target, tol = 1e-6)
{
# 
# Take two numeric objects (this rules out lists and complex numbers) and
# compare them. If they are equal, return TRUE; if not, return FALSE and
# print out the elements which differ, the differences, and the orders of
# magnitude of all these. The idea is to look at the 'order' columns to
# decide quickly if the discrepancies are serious, instead of looking at the
# numbers.
# 
	if(mode(current) != "numeric" || mode(target) != "numeric") stop(
			"arguments must be mode numeric")
	diff <- current - target
	too.big <- abs(diff) >= tol
	if(any(too.big)) {
		cat("\n\n")
		print(structure(.Data = c(current[too.big], target[too.big],
			diff[too.big], Order(current[too.big]), Order(target[
			too.big]), Order(diff[too.big])), .Dim = c(sum(too.big),
			6), .Dimnames = list(paste(sep = "", "(", (1:length(
			current))[too.big], ")"), c("current", "target", 
			"curr - tgt", "O(c)", "O(t)", "O(c - t)")), tol = tol),
			digits =  - log10(tol))
		F
	}
	else T
}
"check.loaded"<-
function(where = 1, interface = ".C")
{
	switch(interface,
		.C = {
			symbol.LANG <- symbol.C
		}
		,
		.Fortran = {
			symbol.LANG <- symbol.For
		}
		,
		stop("interface must be .C or .Fortran"))
	cat("Searching", search()[where], "for", interface, "...\n")
	calls <- find.calls.db(interface, where, replace = F, save.calls = T)
	if(length(calls) == 0)
		warning(paste("No calls to", interface, "found."))
	else cat("Doing is.loaded ...\n")
	fun.names <- names(calls)
	for(f in seq(calls)) {
		for(call. in calls[[f]]) {
			fun.name <- fun.names[f]
			if(mode(sym <- call.[[2]]) != "character")
				warning(paste(
				  "can't determine symbol name in", 
				  interface, "in function", fun.name, 
				  "on", search()[where],
				  ". Expression is:\n", paste(deparse(
				  sym), collapse = "\n"), "\n"))
			else if(!is.loaded(sym2 <- symbol.LANG(sym))
				)
				warning(paste("symbol", sym2, 
				  "is not loaded.", interface, 
				  "in function", fun.name, 
				  "on", search()[where], "\n"))
		}
	}
	invisible()
}
"find.calls.db"<-
function(name, where = 1, replace = F, save.calls = F)
{
# Search all functions on 'where' for calls to the function named in char
# string 'name'. If save.calls=F, return a char vector of names of
# functions which call it. If save.calls=T, return the call/assignment
# expressions in a list. Each element of the list corresponds to one
# calling function; i.e. length(find.calls.db(save.calls=T)) ==
# length(find.calls.db(save.calls=F)), and names(find.calls.db(save.calls=T))
# == find.calls.db(save.calls=F).
#
# 'replace' says whether to look for calls in the context of replacement
# expressions or not.
#
# See the helpfile for find.calls for more details.
#
# This function is designed to keep memory usage down, not to be particularly
# elegant.
#
	old.keep <- options(keep = NULL)	# don't cache functions
	on.exit(options(old.keep))
	obj.names <- objects(where)
	calls.it <- vector("logical", length(obj.names))
	j <- 0
	if(save.calls) {
		calls <- vector("list", length(obj.names))
		k <- 0
		for(i in obj.names) {
			j <- j + 1
			obj <- get(i, where = where, immediate = T)	
	# immediate=T => don't keep it around on expression frame
			if(mode(obj) == "function") {
				these.calls <- find.calls(obj, name, 
				  replace = replace)
				calls.it[j] <- length(these.calls) != 
				  0
				if(length(these.calls)) {
				  k <- k + 1
				  calls[[k]] <- these.calls
				}
			}
		}
		calls <- calls[0:k]
		names(calls) <- obj.names[calls.it]
		calls
	}
	else {
# ! save.calls
		for(i in obj.names) {
			j <- j + 1
			obj <- get(i, where = where, immediate = T)
			if(mode(obj) == "function")
				calls.it[j] <- 0 != find.calls(obj, 
				  name, expr = F, replace = replace)
		}
		obj.names[calls.it]
	}
}

# Generic dynamic loading of a module file.
dload.name <- dyn.load.functions[1]
dload <- get(dload.name, mode = "function")


# Used in loop.tests/stat.att
attach.targets <- function () attach(getenv("TARGET_DATA_DIR"))

options(old.opt)
rm(.Last.value )