"%&&%"<-
function(e1, e2)
{
	if(Logical.value(e1)) {
		if(Logical.value(e2))
			TRUE
		else FALSE
	}
	else FALSE
}
"%||%"<-
function(e1, e2)
{
	if(!Logical.value(e1)) {
		if(Logical.value(e2))
			TRUE
		else FALSE
	}
	else TRUE
}
"Do.internal"<-
function(expr, call, entry, code)
eval(expr, Frames[[Nframe]])
"Eval"<-
function(expr, frame)
{
	if(!missing(frame)) {
		old.frame <- Nframe
		Nframe <<- frame
	}
	if(is.language(expr))
		switch(mode(expr),
			"<-" = ,
			"<<-" = {Assign.Eval(expr)}
			,
			name = {Name.Eval(expr)}
			,
			call = {Call.Eval(expr)}
			,
			frame = {
				New.frame(expr[[2]], expr[[3]])
				value <- Eval(expr[[0]])
				if(Return.flag[[Nframe]])
					value <- Return[[Nframe]]
				Pop.frame()
				value
			}
			,
			internal = {
				call <- as.call(expr[[1]])
				args <- list()
				code <- if(length(expr) < 4)
					0
				else expr[[4]]
				if(length(expr) < 3 || Eval(expr[[3]]))
					for(i in call[-1]) args <- c(args,
							Eval(i))
				Do.internal(expr, call, args, code)
			}
			,
			"repeat" = {
				Break.flag[Nframe] <<- FALSE
				Next.flag[Nframe] <<- FALSE
				Value <- NULL
				repeat {
					Body <- Eval(expr[[1]])
					if(Break.flag[Nframe] || Return.flag[[
						Nframe]])
						break
					if(Next.flag[Nframe])
						Next.flag[[Nframe]] <<- FALSE
						
					else Value <- Body
				}
				Break.flag[Nframe] <<- FALSE
				if(Return.flag[Nframe])
					Return[[Nframe]]
				else Value
			}
			,
			"while" = {
				Break.flag[Nframe] <<- FALSE
				Next.flag[Nframe] <<- FALSE
				Value <- NULL
				repeat {
					if(!Eval(expr[[1]]))
						break
					Body <- Eval(expr[[2]])
					if(Break.flag[Nframe] || Return.flag[[
						Nframe]])
						break
					if(Next.flag[Nframe])
						Next.flag[[Nframe]] <<- FALSE
						
					else Value <- Body
				}
				Break.flag[Nframe] <<- FALSE
				if(Return.flag[Nframe])
					Return[[Nframe]]
				else Value
			}
			,
			"for" = {
				Break.flag[Nframe] <<- FALSE
				Next.flag[Nframe] <<- FALSE
				Value <- NULL
				what <- as.character(expr[[1]])
				counter <- Eval(expr[[2]])
				old.what <- Frames[[Nframe]][[what]]
				for(i in seq(along = counter)) {
					Assign(what, counter[[i]], Nframe)
					Body <- Eval(expr[[3]])
					if(Break.flag[Nframe] || Return.flag[[
						Nframe]])
						break
					if(Next.flag[Nframe])
						Next.flag[[Nframe]] <<- FALSE
						
					else Value <- Body
				}
				if(!is.null(old.what))
					Assign(what, old.what, Nframe)
				Break.flag[Nframe] <<- FALSE
				if(Return.flag[Nframe])
					Return[[Nframe]]
				else Value
			}
			,
			"{" = {
				value <- NULL
				for(subexpr in expr) {
					element <- Eval(subexpr)
					if(Return.flag[Nframe] || Break.flag[
						Nframe] || Next.flag[Nframe])
						break
					value <- element
				}
				value
			}
			,
			"return" = {
				Return[[Nframe]] <<- Eval(expr[[1]])
				Return.flag[Nframe] <<- T
				Return[[Nframe]]
			}
			,
			"break" = {
				Break.flag[Nframe] <<- T
				NULL
			}
			,
			"next" = {
				Next.flag[Nframe] <<- T
				NULL
			}
			,
			"if" = {
				if(Logical.value(expr[[1]]))
					Eval(expr[[2]])
				else if(length(expr) > 2)
					Eval(expr[[3]])
				else NULL
			}
			,
			stop(paste("Eval doesn't know how to evaluate", mode(
				expr))))
	else expr
}

Name.Eval <- function(expr) {

	Frame <- Frames[[Nframe]]
	name <- as.character(expr)
	n <- match(name, names(Frame), FALSE)
	if(n) {
		Temp <- Frame[[n]]
		if(is.language(Temp) && n > length(
			Frame) - Nargs[Nframe]) {
# argument
			if(attr(Frame, "missing")[
				n]) {
# default
				Insert(name, 
					Bad.default,
					Nframe)
				value <- Eval(Temp[[
					2]])
				Assign(name, value,
					Nframe)
			}
			else {
# actual argument
prev <- Nframe; Nframe <<- Parent[Nframe]
				value <- Eval(Temp[[
					1]])
				Insert(name, value,
					Nframe)
Nframe <<- prev
			}
		}
		Temp
	}
	else Get(name)	#non-local
}

Assign.Eval <- function(expr){
	perm <- mode(expr) == "<<-"
	Temp <- Replace.expr(expr)
	value <- Eval(expr[[2]], Nframe)
	switch(mode(Temp),
		"<-" = ,
		"<<-" = {
			name <- as.character(expr[[
				1]])
			Temp <- value
			frame <- if(perm || Nframe ==
				1)
				-1
			else Nframe
		}
		,
		call = {
			name <- as.character(Temp[[
				1]])
			Temp[[length(Temp)]] <- value
			Temp <- Eval(Temp, Nframe)
			frame <- if(perm)
				-1
			else Frame.of(name)
		}
		,
		Eval(Temp))	# complicated case
	if(No.flags())
		assign(name, Temp, frame = frame)
	else if(Return.flag[[Nframe]])
		value <- Return[[Nframe]]
	value
}

Call.Eval <- function(expr) {
	if(mode(expr[[1]] == "name"))
		Definition <- Get(expr[[1]], mode = 
			"function")
	else {
		Definition <- Eval(expr[[1]])
		if(mode(Definition)!="function")
			stop(paste(Definition, 
				"is not a function"))
	}
	New.frame(amatch(Definition, expr),
		expr)
	value <- Eval(Definition[[length(Definition)]])
	if(Return.flag[[Nframe]])
		value <- Return[[Nframe]]
	Pop.frame()
	value
}
"Eval.init"<-
function()
{
	Nframe <<- 1
	Frames <<- list(list())
	Calls <<- list(list())
	Return <<- list(NULL)
	Nargs <<- 0
	Parent <<- 1
	Return.flag <<- Break.flag <<- Next.flag <<- F
	if(!exists("Trace.eval"))
		Trace.eval <<- NULL
}
"Get"<-
function(.NAME, .MODE = "any")
{
	.N <- match(as.character(.NAME), names(Frames[[Nframe]]), F)
	if(.N) {
		.X <- Frames[[Nframe]][[.N]]
		if(.MODE == "any" || mode(.X) == .MODE)
			return(.X)
		warning(paste("looking for object of mode", .MODE, 
			"; ignored one of mode", mode(.X)))
	}
	get(.NAME, mode = .MODE)
}
"Insert"<-
function(name, value, Nframe)
{
	frame <- Frames[[Nframe]]
	new <- c(value, frame)
	names(new) <- c(name, names(frame))
	attr(new, "missing") <- attr(frame, "missing")
	Frames[[Nframe]] <- new
}
"Logical.value"<-
function(expr)
{
	if(is.language(expr))
		expr <- Eval(expr)
	expr <- as.logical(expr)
	if(length(expr) < 1)
		stop("No data to treat as logical")
	if(is.na(epxr[1]))
		stop("Missing value where logical needed")
	if(length(expr) > 1)
		warning(paste("Condition has", length(which), 
			"elements: only the first used"))
	expr[1]
}
Lparse <- function() {
	repeat { tok_get.token(); if(!is.null(tok))break}
	if(mode(tok)!= "(") stop(paste("Got",mode(tok),"instead of initial ("))
	lparse()
}

lparse <- function(level=0) {
	parse <- NULL; n <- 1
	repeat {
		token <- get.token()
		switch(mode(token),
		"(" =  token <- lparse(level+1),
		")" = return(parse))
# initial token determines mode
		if(is.null(parse)) switch(mode(token),
			"name" =,
			"character" = {parse <- call(token);n <- 2},
			"call" = { parse <- token; n <- 2},
			parse <- token)
		else {parse[[n]] <- token; n <- n +1}
	}
}
"Missing"<-
function(what)
{
	argname <- substitute(what)
	if(mode(argname)!="name")
		stop("The argument to missing() should be a name")
	call <- sys.calls()[[sys.parent(1)]]
	fundef <- eval(call[[1]])
	formals <- names(fundef)[ - length(fundef)]
	n <- match(argname, formals)
	if(is.na(n))
		stop(paste(argname, "should have been an argument name"))
	attr(amatch(fundef, call), "missing")[n]
}
"New.frame"<-
function(frame, call)
{
	parent <- Nframe
	Nframe <<- length(Frames) + 1
	Frames[[Nframe]] <<- as.frame(frame)
	Calls[[Nframe]] <<- as.call(call)
	Nargs[[Nframe]] <<- length(frame)
	Parent[[Nframe]] <<- parent
	Return.flag[[Nframe]] <<- FALSE
}
"Program"<-
expression({
	Last.expr <<- parse(prompt = "P> ")
	.Auto.print <- switch(mode(.Last.expr[[1]]),
		"<-" = ,
		"<<-" = F,
		T)
	Eval.init()
	.Last.value <<- Eval(Last.expr[[1]], sys.Nframe())
	if(.Auto.print)
		print(.Last.value)
}
)
"Replace.assign"<-
function(expr)
.Internal(Replace.assign(expr), "S_dummy" = , T, 6)
"Replace.expr"<-
function(expr)
{
	lhs <- expr[[1]]
	if(mode(lhs) == "name")
		return(expr)
	if(mode(lhs)!="call")
		stop(paste("Left side of assignment can't be of mode", mode(
			lhs)))
	object <- lhs[[2]]
	if(mode(object) == "name") {
# make the replacement call
		fun.name <- lhs[[1]]
		lhs[[1]] <- paste(fun.name, "<-", sep = "")
		lhs[[length(lhs) + 1]] <- expr[[2]]
		lhs
	}
	else expd.assign(expr, Nframe)
}
"Switch"<-
function(EXPRESSION, ...)
{
	branches <- expression(..., NULL)
	which <- EXPRESSION
	if(length(which) > 1)
		warning(paste("switch value has", length(which), 
			"elements: only the first used"))
	if(mode(which) == "character")
		n <- match(which, names(branches), length(branches))
	else {
		n <- trunc(which)
		if(n < 1 || n > length(branches))
			n <- length(branches)
	}
	eval(branches[[n]])
}
"a.to.vec.index"<-
function(all.i, dim)
{
	delta <- exp(cumsum(log(dim)))
	if(length(all.i)!=length(dim))
		stop("non-matching arguments")
	indices <- all.i[[1]]
	for(i in 2:length(dim)) {
		ii <- (all.i[[i]] - 1) * delta[i - 1]
		indices <- outer(indices, ii, "+")
	}
	as.vector(indices)
}
all.symbols <- function(names) {
	symbols <- fsymbols <- ssymbols <- character(0)
	for(i in names) {
		obj <- get(i)
		if(mode(obj)=="function"){
		   obj <- obj[[length(obj)]]
		   symbols <- c(symbols,C.symb(obj))
		   fsymbols <- c(fsymbols, F.symb(obj))
		   ssymbols <- c(ssymbols,S.symb(obj))
		}
	}
	list(C = unique(symbols), F = unique(fsymbols), S=unique(ssymbols))
}

C.symb <- function(obj) {
	symb <- character(0)
	if(!(is.recursive(obj) && is.language(obj)))return(symb)
	switch(mode(obj),
	"internal"  = symb <- name.or.char(obj,2),
	"call" = if(as.character(obj[[1]])==".C")
			symb <- name.or.char(obj,2)
	)
	for( i in obj) symb <- c(symb, C.symb(i))
	symb
}

F.symb <- function(obj) {
	symb <- character(0)
	if(!(is.recursive(obj) && is.language(obj)))return(symb)
	if(mode(obj)=="call" && as.character(obj[[1]])==".Fortran")
		symb <- name.or.char(obj,2)
	for( i in obj) symb <- c(symb, F.symb(i))
	symb

}		

S.symb<- function(obj) {
	symb <- character(0)
	if(!(is.recursive(obj) && is.language(obj)))return(symb)
	switch(mode(obj),
	"S.call" = symb <- name.or.char(obj,2),
	"call" = {
		what <- as.character(obj[[1]])
		if(what=="marks.xy" || what=="plot.xy")
			symb <- obj[[length(obj)]]
	})
	for( i in obj) symb <- c(symb, S.symb(i))
	symb

}		

name.or.char <- function(obj,i) {
	nn_names(obj)[i]
	if(is.null(nn) ||nn=="" )as.character(obj[[i]])
	else nn
}

"array.indices"<-
function(a, ..., replace = F)
{
	a <- as.array(a)
	d <- dim(a)
	k <- length(d)
	if(nargs() - 1!=k)
		stop("Need", k, "subscripts for array")
	dn <- dimnames(a)
	z <- list(...)
	for(i in 1:k) {
		dummy <- 1:d[i]
		if(length(dn[[i]]) > 0)
			names(dummy) <- dn[[i]]
		z[[i]] <- vec.index(dummy, z[[i]], replace)
	}
	z
}
"expd.assign"<-
function(expr, frame = sys.parent(1))
.Internal(expd.assign(expr, frame), "S_dummy" = , T, -6)
"expd.assikgn"<-
"first.match"<-
function(x, table)
{
	awk.table <- paste("x[", seq(along = x), "] = \"", x, "\"", sep = "")
	cmd <- c("awk 'BEGIN {", paste("n=", length(x)), awk.table, 
		"}\n/./ {for(i=1;i<=n;i++)print  index($0,x[i])}'")
	ind <- unix(paste(cmd, collapse = "\n"), input = table) == 1
 
	xx <- matrix(ind, length(x), length(table))
	dimnames(xx) <- list(x, table)
	xx
}
"get.token"<-
function()
.Internal(get.token(), "get_token" = )
"mat.index"<-
function(mat, dim)
{
	delta <- exp(cumsum(log(dim)))
	indices <- mat[, 1]
	if(length(dim) > 1)
		for(j in 2:length(dim)) indices <- indices + (mat[, j] - 1) *
				delta[j - 1]
	drop(indices)
}
"pmatch"<-
function(call.names, fun.names)
{
	nargs <- length(fun.names)
	by.position <- nchar(call.names) == 0
	dot.pos <- match("...", fun.names, 0)
	if(dot.pos)
		before <- 1:nargs < dot.pos
	else before <- rep(TRUE, nargs)	# step 1
	matched <- match(call.names, fun.names, 0)	# step 2
	partial <- !(matched | by.position)
	if(any(partial)) {
		rows <- 1:length(call.names)
		cols <- (1:nargs)[before]
		xx <- first.match(call.names, fun.names[before])
		ok <- rows[partial & apply(xx, 1, sum) == 1]
		for(i in ok) matched[i] <- cols[xx[i,  ]]
		matched[duplicated(matched)] <- 0
	}
# step 3
	ok <- 1:nargs
	ok <- ok[before & !match(ok, matched, 0)]
	by.position <- (1:length(call.names))[by.position]
	length(by.position) <- length(ok) <- min(length(by.position), length(
		ok))
	if(length(by.position))
		matched[by.position] <- ok
	if(dot.pos)
		matched[!matched] <- dot.pos
	matched
}
"Pop.frame"<-
function()
{
	n <- Parent[[Nframe]]
	length(Frames) <<- length(Calls) <<- length(Nargs) <<- length(Parent) <<-
		n
	Nframe <<- n
	browser()
}
"vec.index"<-
function(x, i, replace = F)
{
	all.i <- seq(along = x)
	if(missing(i))
		all.i
	else switch(mode(i),
			character = {
				n <- if(replace)
					match(i, as.character(names(x)))
				else pmatch(i, as.character(names(x)))
				nomatch <- is.na(n)
				n[nomatch] <- length(x) + seq(length = sum(
					nomatch))
				n
			}
			,
			logical = {
				if(length(i) < length(x))
					i <- rep(i, length = length(x))
				all.i[i]
			}
			,
			numeric = {
				if(any(i < 0)) {
					if(any(is.na(i) | i > 0))
						stop(
							"only 0's may be mixed with negative subscripts"
							)
					all.i[i]
				}
				else i
			}
			)
}
