getMultipleLength = function(x,y) {
if (x==y) {
return(x)
} else if (x<y) {
small=x
big=y
} else {
small=y
big=x
}
if (small==0) {
return(0)
}
if ((big %% y) != 0) {
error("small is not a multiple of big")
}
return(big)
}
inferTypeStubs=list(
list(
opcodes=c("SUB.OP", "MUL.OP", "ADD.OP"),
func=function(expression) {
currentNeededType<<-lowerType(higherType(left_operand,right_operand),currentNeededType)
left_operand<<-tpSetNeededType(left_operand, higherType(tpGetNeededType(left_operand),currentNeededType))
right_operand<<-tpSetNeededType(right_operand, higherType(tpGetNeededType(right_operand),currentNeededType))
return(currentNeededType)
}
),
list(
opcodes=c("EQ.OP", "GE.OP", "GT.OP", "LE.OP", "LT.OP"),
func=function(expression) {
newType=higherType(left_operand,right_operand)
if (tpGetName(newType) == tpAny) {
newType=getType(name=tpAny,
subName=tpLogical,
vectorLength=tpGetVectorLength(newType))
} else if (tpGetName(newType) == tpNumeric) {
newType=getType(name=tpLogical,vectorLength=tpGetVectorLength(newType))
} else {
stop("unreachable")
}
if (! is.null(currentNeededType)) {
if (tpGetName(currentNeededType) == tpAny) {
neededType=currentNeededType
} else {
neededType=lowerType(left_operand,right_operand)
}
left_operand=tpSetNeededType(left_operand, higherType(tpGetNeededType(left_operand),neededType))
right_operand=tpSetNeededType(right_operand, higherType(tpGetNeededType(right_operand),neededType))
} else {
neededType=NULL
}
return(newType)
}
),
list(
opcodes=c("AND2ND.OP"),
func=function(expression) {
newType=getType(name=tpLogical, vectorLength=1)
return(newType)
}
),
list(
opcodes=c("LDCONST.OP", "PUSHCONSTARG.OP"),
func=function(value) {
if (typeof(value)=="double") {
if (is.null(currentNeededType) || tpGetName(currentNeededType)==tpNumeric) {
newType=getType(name=tpNumeric, vectorLength=length(var))
} else {
newType=getType(name=tpAny, subName=tpNumeric, vectorLength=length(var))
}
} else {
newType=getType(name=tpAny)
}
return(newType)
}
),
list(
opcodes=c("LDNULL.OP"),
func=function(expression) {
newType=getType(name=tpNull, vectorLength=1)
return(newType)
}
),
list(
opcodes=c("GETVAR.OP"),
func=function(varName) {
newType=vars[[varName]]
if (is.null(newType)) {
stop(paste("Variable ",varName, "not defined before"))
}
return(newType)
}
),
list(
opcodes=c("SETVAR.OP"),
func=function(varName) {
#browser()
var=vars[[varName]]
if (is.null(var)) {
vars[[varName]]<<-val
newType=val
} else if (! typesMatch(var,val)) {
newType=higherType(var,val)
vars[[varName]]<<-newType
} else {
newType=val
}
return(newType)
}
),
list(
opcodes=c("BRIFNOT.OP", "GOTO.OP", "POP.OP"),
func=function(...) {
return(getType(name=tpVoid))
}
),
list(
opcodes=c("RETURN.OP"),
func=function() {
if (! is.null(currentNeededType)) {
val<<-tpSetNeededType(val,higherType(currentNeededType,tpGetNeededType(val)))
newType=currentNeededType
newType=tpSetNeededType(newType, currentNeededType)
} else {
newType=val
}
return(newType)
}
),
list(
opcodes=c("GETFUN.OP", "GETBUILTIN.OP", "GETINTLBUILTIN.OP"),
func=function(funName) {
newType=getType(name=tpFunctionName)
newType=tpSetFunName(newType,funName)
switch(opName,
"GETFUN.OP" = {
#browser()
funBody=body(get(funName, envir=globalenv()))
if (is.null(funBody)) {
newType=tpSetFunClass(newType,"primitive")
} else {
newType=tpSetFunClass(newType,"function")
}
},
"GETBUILTIN.OP" = { newType=tpSetFunClass(newType,"builtin")},
"GETINTLBUILTIN.OP" = { newType=tpSetFunClass(newType,"internal")},
{stop("who am i?")}
)
return(newType)
}
),
list(
opcodes=c("MAKEPROM.OP"),
func=function(code) {
#browser()
if (is.null(typeArray[opNumber][[1]])) {
tmpType=list(promiseList=list())
promTypeList=tmpType$promiseList
} else {
tmpType=typeArray[[opNumber]]
promTypeList=tpGetPromiseList(tmpType)
}
promIns=code[[2]][-1]
promConst=code[[3]]
tm=getInferTypeManager(promTypeList, vars)
visitStackMachine2(promIns,promConst,tm)
#browser()
promTypeList=tm$environ$typeArray
newType = promTypeList[length(promIns)][[1]]
newType = tpSetPromiseList(newType,promTypeList)
return(newType)
}
),
list(
opcodes=c("PUSHFALSEARG.OP"),
func=function() {
newType=getType(name=tpLogical, vectorLength=1)
return(newType)
}
),
list(
opcodes=c("CALL.OP", "CALLBUILTIN.OP"),
func=function(expression, argCount) {
#browser()
if (tpGetFunClass(fun) == "function") {
argListPos=list()
argListPosCount=0
argListNamed=list()
argListNamedPos=list()
if (argCount>0) {
for (i in (1:argCount)) {
#browser()
arg=get(paste(sep="_","callArg",i))
if (length(tpGetArgName(arg)) == 0) {
argListPos[[argListPosCount+1]]=arg
argListPosCount=argListPosCount+1;
} else {
argListNamed[[tpGetArgName(arg)]]=arg
argListNamedPos[[i]]=tpGetArgName(arg)
}
}
}
ctxt=initCompileContext(get(tpGetFunName(fun), envir=globalenv()),tpGetFunName(fun))
ctxt=inferFunctionType(ctxt,funcSignature=list(pos=argListPos,named=argListNamed))
newType=ctxt$returnType
newType = tpSetFuncType(newType,fun)
newType = tpSetFuncContext(newType, ctxt)
newType = tpSetArgListNamedPos(newType, argListNamedPos)
} else {
#browser()
newType = getType(tpAny)
newType = tpSetFuncType(newType,getType(tpAny))
}
return(newType)
}
),
list(
opcodes=c("CALLSPECIAL.OP"),
func=function(expression) {
newType=getType(name=tpAny)
return(newType)
}
),
list(
opcodes=c("DODOTS.OP"),
func=function() {
return(getType(name=tpDots))
}
),
list(
opcodes=c("AND1ST.OP", "PUSHARG.OP", "STARTSUBSET2.OP"),
func=function(...) {
return(val)
}
),
list(
opcodes=c("SETTAG.OP"),
func=function(argName) {
newType=tpSetArgName(val,argName)
return(newType)
}
),
list(
opcodes=c("DFLTSUBSET2.OP"),
func=function() {
newType=tpSetVectorLength(variable,1)
return(newType)
}
)
)
inferTypeHandler=function(..., opNumber, opName, argTypes) {
args=list(...)
env=new.env()
args2=list()
for (arg in names(argTypes)) {
if (argTypes[[arg]] == "stack") {
#replacing stack arguemnts with the entry in the stack array
env[[arg]]=typeArray[[args[[arg]]]]
} else {
args2[[arg]]=args[[arg]]
}
}
if (is.null(typeArray[opNumber][[1]])) {
env$currentNeededType=NULL
} else {
env$currentNeededType=tpGetNeededType(typeArray[[opNumber]])
}
#env$vars=vars
#env$typeArray=parent.env(parent.env(environment()))$typeArray
#browser()
func=func
parent.env(env)=environment()
environment(func)=env
if (is.null(func)) {
stop(paste("no handler for op=", opName, " avaiable!"))
}
res=do.call(func,args2, envir=env)
opArgTypes=list()
for (arg in names(argTypes)) {
if (argTypes[[arg]] == "stack") {
#propragatin needed type
typeArray[[args[[arg]]]]<<-env[[arg]]
#collecting args
opArgTypes[[arg]]=env[[arg]]
}
}
#if (! typesMatch(res, getType(name=tpVoid))) {
res=tpSetNeededType(res,env$currentNeededType)
res=tpSetArgs(res,opArgTypes)
#browser()
if (is.null(typeArray[opNumber][[1]])) {
changed<<-TRUE
} else {
changed<<-(changed || (! (typesMatch(typeArray[[opNumber]],res))))
}
typeArray[opNumber]<<-res
#}
#typeArray<<-env$typeArray
#vars<<-env$vars
return(opNumber)
}
getInferTypeManager = function(typeArray, vars) {
res=list()
env=new.env()
#browser()
parent.env(env)=parent.env(environment(inferTypeHandler))
env$typeArray=typeArray
env$vars=vars
env$changed=FALSE
for (opGroup in inferTypeStubs) {
for (op in opGroup$opcodes) {
res[[op]]=inferTypeHandler
environment(res[[op]])=new.env()
parent.env(environment(res[[op]]))=env
environment(res[[op]])$func=opGroup$func
}
}
#browser()
res$environ=env
return(res)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.