Lisp by R

gistfile1.r

opt <- options(warn=-1)

## ------------------------------------------------------------
## Test
## ------------------------------------------------------------

## > rm(list=ls()); source("Eval.R")
## > repl()
## rlisp > (<- make.counter (function (c) (function () (<<- c (+ c 1)))))
## <Closure Function Sexp> 
## rlisp > (<- c1 (make.counter 3))
## <Closure Function Sexp> 
## rlisp > (c1)
## <Number Sexp: 4.000000> 
## rlisp > (c1)
## <Number Sexp: 5.000000> 
## rlisp > (c1)
## <Number Sexp: 6.000000> 
## rlisp > (<- c2 (make.counter 100))
## <Closure Function Sexp> 
## rlisp > (c2)
## <Number Sexp: 101.000000> 
## rlisp > (c2)
## <Number Sexp: 102.000000> 
## rlisp > (c2)
## <Number Sexp: 103.000000> 
## rlisp > (c1)
## <Number Sexp: 7.000000> 
## rlisp > 


## ------------------------------------------------------------
## S Expressions and Env
## ------------------------------------------------------------

Num <- function(num.value) {
  obj <- list(num.value=num.value)
  class(obj) <- c("Num", "Sexp")
  obj
}

## Str <- function(str.value) {
##   obj <- list(str.value=str.value)
##   class(obj) <- c("Str", "Sexp")
##   obj
## }

Symbol <- function(symbol.value) {
  obj <- list(symbol.value=symbol.value)
  class(obj) <- c("Symbol", "Sexp")
  obj
}

Closure <- function(formals, body, env) {
  obj <- list(formals=formals, body=body, env=env)
  class(obj) <- c("Closure", "Sexp")
  obj
}

Primitive <- function(primitive.fun) {
  obj <- list(primitive.fun=primitive.fun)
  class(obj) <- c("Primitive", "Sexp")
  obj
}

Env <- function(frame, parent) {
  obj <- dict()
  obj$frame <- frame
  obj$parent <- parent
  class(obj) <- "Env"
  obj
}


## ------------------------------------------------------------
## S Expressions Print Fucntions
## ------------------------------------------------------------

toString.Num <- function(sexp) sprintf("<Number Sexp: %f>", sexp$num.value)

## toString.Str <- function(sexp) sprintf("<String Sexp: '%s'>", sexp$str.value)

toString.Symbol <- function(sexp) sprintf("<Symbol Sexp: %s>", sexp$symbol.value)

toString.Closure <- function(sexp) "<Closure Function Sexp>"

toString.Primitive <- function(sexp) "<Primitive Function Sexp>"

toString.list <- function(list) {
  paste("[", do.call("paste", c(lapply(list, toString), sep=", ")), "]", sep="")
}

print.Sexp <- function(sexp) print(toString(sexp))


## ------------------------------------------------------------
## my.parse
## ------------------------------------------------------------

read <- function(program.text) {
  read.from(tokenize(program.text))$value
}

my.parse <- read

tokenize <- function(program.text) {
  strsplit(gsub("\\)", " )", gsub("\\(", "( ",  program.text)), "\\s+")[[1]]
}

read.from <- function(tokens) {
  if (length(tokens) == 0) stop("unexpected EOF")
  token <- tokens[[1]]
  tokens <- tokens[-1]
  if (token == "(") {
    l <- list()
    while (tokens[[1]] != ")") {
      read.result <- read.from(tokens)
      value <- read.result$value
      tokens <- read.result$tokens
      if (mode(value) == "list") value <- list(value)
      l <- append(l, value)
    }
    tokens <- tokens[-1]
    list(value=l, tokens=tokens)
    
  } else if (token == ")") {
    stop("unexpected ')'")
  } else {
    list(value=sexp(token), tokens=tokens)
  }
}

sexp <- function(token) {
  if (!is.na(as.double(token)))
    Num(as.double(token))
  else
    Symbol(token)
}


## ------------------------------------------------------------
## my.eval
## ------------------------------------------------------------

my.eval <- function(exp, ...) UseMethod("my.eval", exp)

my.eval.Num <- function(exp, env) exp

## my.eval.Str <- function(exp, env) exp

my.eval.Symbol <- function(exp, env) lookup.env(env, exp$symbol.value)

my.eval.Closure <- function(exp, env) exp

my.eval.Primitive <- function(exp, env) exp

my.eval.list <- function(exp, env) {

  op <- exp[[1]]
  args.exp <- exp[-1]
  
  if (inherits(op, "Symbol") && op$symbol.value == "<-") {
    var.exp <- args.exp[[1]]
    val.exp <- args.exp[[2]]
    if (!inherits(var.exp, "Symbol")) stop(var.exp, " is not a symbol.")
    define(env, var.exp$symbol.value, my.eval(val.exp, env))

  } else if (inherits(op, "Symbol") && op$symbol.value == "<<-") {
    var.exp <- args.exp[[1]]
    val.exp <- args.exp[[2]]
    if (!inherits(var.exp, "Symbol")) stop(var.exp, " is not a symbol.")
    deep.define(env, var.exp$symbol.value, my.eval(val.exp, env))
  } else if (inherits(op, "Symbol") && op$symbol.value == "function") {
    formals <- args.exp[[1]]
    body    <- args.exp[[2]]
    Closure(formals, body, env)

  } else if (inherits(op, "Symbol") && op$symbol.value == "if") {
    cond         <- args.exp[[1]]
    true.clause  <- args.exp[[2]]
    false.clause <- args.exp[[3]]
    if (my.eval(cond, env)$num.value == 0) {
      my.eval(false.clause, env)
    } else {
      my.eval(true.clause, env)
    }
  } else {
    call.fun(my.eval(op, env), each.my.eval(args.exp, env))
  }
}

each.my.eval <- function (exp.list, env) {
  lapply(exp.list, function(exp) my.eval(exp, env))
}


## ------------------------------------------------------------
## Utilities
## ------------------------------------------------------------

dict <- new.env

my.cat <- function(...) do.call("cat", lapply(list(...), toString))

lookup.env <- function(env, var) {
  if (is.null(env)) stop(var, " not found.")

  if (var %in% names(env$frame)) {
    env$frame[[var]]
  } else {
    lookup.env(env$parent, var)
  }
}

define <- function(env, var, val) {
  env$frame[[var]] <- val
  val
}

deep.define <- function(env, var, val) {
  if (is.null(env$parent)) {
    env$frame[[var]] <- val
    val
  } else if (var %in% names(env$parent$frame)) {
    env$parent$frame[[var]] <- val
    val
  } else {
    deep.define(env$parent, var, val)
  }
}

call.fun <- function(fun, args) {
  if (inherits(fun, "Closure")) {
    formals <- fun$formals
    body    <- fun$body
    env     <- fun$env
    my.eval(body, extend.env(env, formals, args))
  } else {
    fun$primitive.fun(args)
  }
}

extend.env <- function(env, formals, args) {
  frame <- list()
  if (length(formals) == 0) {
    Env(frame=frame, parent=env)
  } else {
    for (i in 1:length(formals)) {
      name <- formals[[i]]$symbol.value
      value <- args[[i]]
      frame[[name]] <- value
    }
    Env(frame=frame, parent=env)
  }
}

repl <- function(env=default.env, prompt="rlisp > ") {
  while(TRUE) {
    cat(prompt)
    val <- my.eval(my.parse(readline()), env)
    my.cat(val, "\n")
  }
}


## ------------------------------------------------------------
## Primitive Fucntions
## ------------------------------------------------------------

add <- Primitive(function(args) {
  x <- args[[1]]; y <- args[[2]]
  Num(x$num.value + y$num.value)
})

sub <- Primitive(function(args) {
  x <- args[[1]]; y <- args[[2]]
  Num(x$num.value - y$num.value)
})

mult <- Primitive(function(args) {
  x <- args[[1]]; y <- args[[2]]
  Num(x$num.value * y$num.value)
})

div <- Primitive(function(args) {
  x <- args[[1]]; y <- args[[2]]
  Num(x$num.value / y$num.value)
})

## join.str <- Primitive(function(args) {
##   x <- args[[1]]; y <- args[[2]]
##   Str(paste(x$str.value, y$str.value, sep=""))
## })

eq <- Primitive(function(args) {
  x <- args[[1]]; y <- args[[2]]
  if (x$num.value == y$num.value) Num(1) else Num(0)
})

gt <- Primitive(function(args) {
  x <- args[[1]]; y <- args[[2]]
  if (x$num.value > y$num.value) Num(1) else Num(0)
})

lt <- Primitive(function(args) {
  x <- args[[1]]; y <- args[[2]]
  if (x$num.value < y$num.value) Num(1) else Num(0)
})


## ------------------------------------------------------------
## default.env
## ------------------------------------------------------------

default.env <- Env(list("TRUE"=Num(1),
                        "FALSE"=Num(0),
                        "+"=add,
                        "-"=sub,
                        "*"=mult,
                        "/"=div,
##                         "++"=join.str,
                        "="=eq,
                        ">"=gt,
                        "<"=lt), NULL)

## options(opt)