elf
/
LispInSmallPieces
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Compare commits

base: elf:master
Branches Tags
elf:master
elf:coffeescript
..
compare: elf:coffeescript
Branches Tags
elf:master
elf:coffeescript

No commits in common. "master" and "coffeescript" have entirely different histories.
master ... coffeescri

47 changed files with 519 additions and 3640 deletions
Show Stats Expand all files Collapse all files

9
.gitignore vendored
View File

@ -6,11 +6,4 @@ npm-debug.log
package.yml
node_modules/*
tmp/
bin/_mocha
bin/mocha
bin/coffee
bin/cake
bin/coffeelint
test-reports.xml
LisperatorLanguage
chapter?/test.coffee
test/

33
Makefile
View File

@ -1,33 +0,0 @@
.PHONY: test
# docs: $(patsubst %.md,%.html,$(wildcard *.md))
SOURCES= chapter1/*.coffee chapter3/*.coffee chapter-lambda-1/*.coffee test/*.coffee
%.js: src/%.coffee
node_modules/.bin/mocha coffee -c -o . $<
%.html: %.md header.html footer.html
cat header.html > $@
pandoc $< >> $@
cat footer.html >> $@
node_modules: package.json
mkdir -p node_modules
npm install
lint:
coffeelint $(SOURCES)
test: clean node_modules
@JUNIT_REPORT_PATH=test-reports.xml JUNIT_REPORT_STACK=1 ./node_modules/.bin/mocha \
--reporter mocha-jenkins-reporter --compilers coffee:coffee-script/register || true
ltest: node_modules
node_modules/.bin/mocha --compilers coffee:coffee-script/register
watch:
while inotifywait $(SOURCES) ; do make test; done
clean:
rm -f report.xml test-reports.xml

39
README.md
View File

@ -1,37 +1,2 @@
# A Collection of Interpreters from Lisp In Small Pieces, written in Coffeescript
## Purpose
I don't know Lisp, so I figured the correct place to start was to write
my own interpreter. After buying five different textbooks (*The
Structure and Interpretation of Computer Programs*, aka "The Wizard
Book", Friedman's *The Essentials of Programming Languages*, *Let over
Lambda*, *On Lisp*, and one more) I decided Christian Quinnec's *Lisp In
Small Pieces* gave the clearest step-by-step introduction.
Since I didn't know Lisp, my task was to translate what Quiennec wrote
in his book into a language I *did* know: Javascript. Well,
Coffeescript, which is basically Javascript with a lot of the
syntactical noise removed, which is why I liked it.
## Usage
I don't know if you're going to get much out of it, but the reader
(which I had to write by hand, seeing as I didn't *have* a native Lisp
reader on hand in my Javascripty environment), and each interpreter has
a fairly standard test case that demonstrates that each language does
what it says it does: you can do math, set variables, name and create
functions, and even do recursion.
## Notes
chapter-lambda-1 is not from Lisp In Small Pieces. It is a primitive
CPS interpreter built on top of the interpreter from LiSP Chapter 1,
using techniques derived from a fairly facile reading of
<a href="http://lisperator.net/pltut/">Lisperator's "Implement A
Programming Language in Javascript."</a> But it was fun.
## LICENSE AND COPYRIGHT NOTICE: NO WARRANTY GRANTED OR IMPLIED
See the LICENSE file.
Not much to see here. Just practicing a few things. If you're
expecting miracles, this isn't the place for it.

195
chapter-lambda-1/interpreter.coffee
View File

@ -1,195 +0,0 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
{Node} = require "../chapter1/reader_types"
class LispInterpreterError extends Error
name: 'LispInterpreterError'
constructor: (@message) ->
env_init = nil
env_global = env_init
definitial = (name, value = nil) ->
env_global = (cons (cons name, value), env_global)
name
defprimitive = (name, nativ, arity) ->
definitial name, ((args, callback) ->
vmargs = listToVector(args)
if (vmargs.length == arity)
callback nativ.apply null, vmargs
else
throw new LispInterpreterError "Incorrect arity")
defpredicate = (name, nativ, arity) ->
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
the_false_value = (cons "false", "boolean")
definitial "#t", true
definitial "#f", the_false_value
definitial "nil", nil
definitial "foo"
definitial "bar"
definitial "fib"
definitial "fact"
defprimitive "cons", cons, 2
defprimitive "car", car, 2
defprimitive "set-cdr!", setcdr, 2
defprimitive "+", ((a, b) -> a + b), 2
defprimitive "*", ((a, b) -> a * b), 2
defprimitive "-", ((a, b) -> a - b), 2
defprimitive "/", ((a, b) -> a / b), 2
defpredicate "lt", ((a, b) -> a < b), 2
defpredicate "eq?", ((a, b) -> a == b), 2
# MISTAKE: Variables are always of type Symbol. This is probably a
# mistake.
extend = (env, variables, values) ->
if (pairp variables)
if (pairp values)
(cons (cons (car variables), (car values)),
(extend env, (cdr variables), (cdr values)))
else
throw new LispInterpreterError "Too few values"
else if (nilp variables)
if (nilp values) then env else throw new LispInterpreterError "Too many values"
else
if (variables.type == 'symbol')
(cons (cons variables, values), env)
else
nil
make_function = (variables, body, env, callback) ->
callback (values, cb) -> eprogn body, (extend env, variables, values), cb
invoke = (fn, args, callback) ->
fn args, callback
# Takes a list of nodes and calls evaluate on each one, returning the
# last one as the value of the total expression. In this example, we
# are hard-coding what ought to be a macro, namely the threading
# macros, "->"
eprogn = (exps, env, callback) ->
if (pairp exps)
if pairp (cdr exps)
evaluate (car exps), env, (next) ->
eprogn (cdr exps), env, callback
else
evaluate (car exps), env, callback
else
callback nil
evlis = (exps, env, callback) ->
if (pairp exps)
evlis (cdr exps), env, (rest) ->
evaluate (car exps), env, (calc) ->
callback cons calc, rest
else
callback nil
lookup = (id, env) ->
if (pairp env)
if (caar env) == id
cdar env
else
lookup id, (cdr env)
else
nil
update = (id, env, value, callback) ->
if (pairp env)
if (caar env) == id
setcdr value, (car env)
callback value
else
update id, (cdr env), value, callback
else
callback nil
# This really ought to be the only place where the AST meets the
# interpreter core. I can't help but think that this design precludes
# pluggable interpreter core.
# TODO: Reengineer this with a call to normalize
astSymbolsToLispSymbols = (node) ->
return nil if nilp node
throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
handler = (cell) ->
return nil if nilp cell
cons (car cell).value, (handler cdr cell)
handler node.value
# Takes an AST node and evaluates it and its contents. A node may be
# ("list" (... contents ...)) or ("number" 42) or ("symbol" x), etc.
cadddr = metacadr('cadddr')
metadata_evaluation =
listp: (node) -> node.type == 'list'
symbolp: (node) -> node.type == 'symbol'
numberp: (node) -> node.type == 'number'
stringp: (node) -> node.type == 'string'
commentp: (node) -> node.type == 'comment'
nvalu: (node) -> node.value
mksymbols: (list) -> astSymbolsToLispSymbols(list)
straight_evaluation =
listp: (cell) -> cell.__type == 'list'
symbolp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] not in ["\"", ";"]
commentp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == ";"
numberp: (cell) -> typeof cell == 'number'
stringp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == "\""
boolp: (cell) -> typeof cell == 'boolean'
nullp: (cell) -> cell == null
vectorp: (cell) -> (not straight_evaluation.listp cell) and toString.call(cell) == '[object Array]'
recordp: (cell) -> (not cell._prototype?) and toSTring.call(cell) == '[object Object]'
objectp: (cell) -> (cell._prototype?) and toString.call(cell) == '[object Object]'
nilp: (cell) -> nilp(cell)
nvalu: (cell) -> cell
mksymbols: (cell) -> cell
makeEvaluator = (ix = straight_evaluation, ty="straight") ->
(exp, env, callback) ->
if ix.symbolp exp
return callback lookup (ix.nvalu exp), env
else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
return callback ix.nvalu exp
else if ix.listp exp
body = ix.nvalu exp
head = car body
if ix.symbolp head
return switch (ix.nvalu head)
when "quote" then callback cdr body
when "if"
evaluate (cadr body), env, (res) ->
w = unless res == the_false_value then caddr else cadddr
evaluate (w body), env, callback
when "begin" then eprogn (cdr body), env, callback
when "set!"
evaluate (caddr body), env, (newvalue) ->
update (ix.nvalu cadr body), env, newvalue, callback
when "lambda"
make_function (ix.mksymbols cadr body), (cddr body), env, callback
else
evaluate (car body), env, (fn) ->
evlis (cdr body), env, (args) ->
invoke fn, args, callback
else
evaluate (car body), env, (fn) ->
evlis (cdr body), env, (args) ->
invoke fn, args, callback
else
throw new LispInterpreterError ("Can't handle a #{type}")
nodeEval = makeEvaluator(metadata_evaluation, "node")
lispEval = makeEvaluator(straight_evaluation, "lisp")
evaluate = (exp, env, cb) ->
(if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env, cb)
module.exports = (c, cb) -> evaluate c, env_global, cb

10
chapter1/astAccessors.coffee
View File

@ -1,10 +0,0 @@
{car, cdr, listp} = require 'cons-lists/lists'
{Node, Symbol} = require "./reader_types"
module.exports = ops =
astObject: (form) -> form instanceof Node
aValue: (form) -> form.value
aSymbol: (form) -> form.value
isAList: (form) -> ops.astObject(form) and form.type == 'list'
isARecord: (form) -> ops.astObject(form) and form.type == 'record'
isAVector: (form) -> ops.astObject(form) and form.type == 'vector'

56
chapter1/astToList.coffee
View File

@ -1,56 +0,0 @@
{car, cdr, cons, listp, nilp, nil,
list, pairp, listToString} = require 'cons-lists/lists'
{astObject} = require './astAccessors'
{Symbol} = require './reader_types'
# RICH_AST -> LISP_AST
normalizeForm = (form) ->
listToRecord1 = (l) ->
o = Object.create(null)
while(l != nil)
o[normalizeForm(car l)] = normalizeForm(car cdr l)
l = cdr cdr l
null
o
listToVector1 = (l) ->
while(l != nil) then p = normalizeForm(car l); l = cdr l; p
id = (a) -> a
methods =
'list': normalizeForms
'vector': (atom) -> listToVector1(atom)
'record': (atom) -> listToRecord1(atom)
# Basic native types. Meh.
'symbol': (id) -> new Symbol(id.name)
'number': id
'string': id
'nil': (atom) -> nil
# Values inherited from the VM.
'true': (atom) -> true
'false': (atom) -> false
'null': (atom) -> null
'undefined': (atom) -> undefined
methods[form.type](form.value)
normalizeForms = (forms) ->
# Yes, this reifies the expectation than an empty list and 'nil' are
# the same.
return nil if nilp forms
# Handle dotted list.
if (astObject forms)
return normalizeForm(forms)
cons(normalizeForm(car forms), normalizeForms(cdr forms))
module.exports =
normalizeForm: normalizeForm
normalizeForms: normalizeForms

185
chapter1/interpreter.coffee
View File

@ -1,185 +0,0 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr,
cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
{Node} = require "./reader_types"
class LispInterpreterError extends Error
name: 'LispInterpreterError'
constructor: (@message, position = null) ->
env_init = nil
env_global = env_init
definitial = (name, value = nil) ->
env_global = (cons (cons name, value), env_global)
name
defprimitive = (name, nativ, arity) ->
definitial name, ((args) ->
vmargs = listToVector(args)
if (vmargs.length == arity)
nativ.apply null, vmargs
else
throw (new LispInterpreterError "Incorrect arity"))
defpredicate = (name, nativ, arity) ->
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
the_false_value = (cons "false", "boolean")
definitial "#t", true
definitial "#f", the_false_value
definitial "nil", nil
definitial "foo"
definitial "bar"
definitial "fib"
definitial "fact"
defprimitive "cons", cons, 2
defprimitive "car", car, 2
defprimitive "set-cdr!", setcdr, 2
defprimitive "+", ((a, b) -> a + b), 2
defprimitive "*", ((a, b) -> a * b), 2
defprimitive "-", ((a, b) -> a - b), 2
defprimitive "/", ((a, b) -> a / b), 2
defpredicate "lt", ((a, b) -> a < b), 2
defpredicate "eq?", ((a, b) -> a == b), 2
extend = (env, variables, values) ->
if (pairp variables)
if (pairp values)
(cons (cons (car variables), (car values)),
(extend env, (cdr variables), (cdr values)))
else
throw new LispInterpreterError "Too few values"
else if (nilp variables)
if (nilp values) then env else throw new LispInterpreterError "Too many values"
else
if (variables.type == 'symbol')
(cons (cons variables, values), env)
else
nil
make_function = (variables, body, env) ->
(values) -> eprogn body, (extend env, variables, values)
invoke = (fn, args) ->
(fn args)
# Takes a list of nodes and calls evaluate on each one, returning the
# last one as the value of the total expression. In this example, we
# are hard-coding what ought to be a macro, namely the threading
# macros, "->"
eprogn = (exps, env) ->
if (pairp exps)
if pairp (cdr exps)
evaluate (car exps), env
eprogn (cdr exps), env
else
evaluate (car exps), env
else
nil
evlis = (exps, env) ->
if (pairp exps)
(cons (evaluate (car exps), env), (evlis (cdr exps), env))
else
nil
lookup = (id, env) ->
if (pairp env)
if (caar env) == id
cdar env
else
lookup id, (cdr env)
else
nil
update = (id, env, value) ->
if (pairp env)
if (caar env) == id
setcdr value, (car env)
value
else
update id, (cdr env), value
else
nil
# TODO: Reengineer this with a call to normalize
tap = (i) -> console.log(i) ; i
astSymbolsToLispSymbols = (node) ->
return nil if nilp node
throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
handler = (cell) ->
return nil if nilp cell
cons (car cell).value, (handler cdr cell)
handler node.value
cadddr = metacadr('cadddr')
# This is really the only thing that changes behavior between "reader
# nodes" (nodes loaded with debugging metadata) and a standard cons
# object. TODO: astSymbolsToLispSymbols should be deprecated in
# favor of normalizeForm (s?) and Symbol extraction
metadata_evaluation =
listp: (node) -> node.type == 'list'
symbolp: (node) -> node.type == 'symbol'
numberp: (node) -> node.type == 'number'
stringp: (node) -> node.type == 'string'
commentp: (node) -> node.type == 'comment'
nvalu: (node) -> node.value
mksymbols: (list) -> astSymbolsToLispSymbols(list)
straight_evaluation =
listp: (cell) -> cell.__type == 'list'
symbolp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] not in ["\"", ";"]
commentp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == ";"
numberp: (cell) -> typeof cell == 'number'
stringp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == "\""
boolp: (cell) -> typeof cell == 'boolean'
nullp: (cell) -> cell == null
vectorp: (cell) -> (not straight_evaluation.listp cell) and toString.call(cell) == '[object Array]'
recordp: (cell) -> (not cell._prototype?) and toSTring.call(cell) == '[object Object]'
objectp: (cell) -> (cell._prototype?) and toString.call(cell) == '[object Object]'
nilp: (cell) -> nilp(cell)
nvalu: (cell) -> cell
mksymbols: (cell) -> cell
makeEvaluator = (ix = straight_evaluation, ty="straight") ->
(exp, env) ->
# Takes an AST node and evaluates it and its contents. A node may be
# ("list" (... contents ...)) or ("number" 42) or ("symbol" x), etc.
if ix.symbolp(exp)
return lookup (ix.nvalu exp), env
else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
return ix.nvalu exp
else if ix.listp(exp)
body = ix.nvalu exp
head = car body
if ix.symbolp(head)
switch (ix.nvalu head)
when "quote" then cdr body
when "if"
unless (evaluate (cadr body), env) == the_false_value
evaluate (caddr body), env
else
evaluate (cadddr body), env
when "begin" then eprogn (cdr body), env
when "set!" then update (ix.nvalu cadr body), env, (evaluate (caddr body), env)
when "lambda" then make_function (ix.mksymbols cadr body), (cddr body), env
else invoke (evaluate (car body), env), (evlis (cdr body), env)
else
invoke (evaluate (car body), env), (evlis (cdr body), env)
else
throw new LispInterpreterError "Can't handle a #{exp.type}"
nodeEval = makeEvaluator(metadata_evaluation, "node")
lispEval = makeEvaluator(straight_evaluation, "lisp")
evaluate = (exp, env) ->
(if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env)
module.exports = (c) -> evaluate c, env_global

11
chapter1/reader_types.coffee
View File

@ -1,11 +0,0 @@
exports.Node = class
constructor: (@type, @value, @line, @column) ->
exports.Symbol = class
constructor: (@name) ->
exports.Comment = class
constructor: (@text) ->

448
chapter3/interpreter.coffee
View File

@ -1,448 +0,0 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
cadr, caadr, cadar, caddr, nilp, nil, setcdr,
metacadr, setcar} = require "cons-lists/lists"
{normalizeForms, normalizeForm} = require "../chapter1/astToList"
{Node, Symbol} = require '../chapter1/reader_types'
class LispInterpreterError extends Error
name: 'LispInterpreterError'
constructor: (@message) ->
the_false_value = (cons "false", "boolean")
# Base class that represents a value. Base class representing a LiSP
# value, a primitive, or a function
eq = (id1, id2) ->
if id1 instanceof Symbol and id2 instanceof Symbol
return id1.name == id2.name
id1 == id2
class Value
# Represents the base class of a continuation. Calls to invoke resume
# the contained continuation, which is typecast to one of the specific
# continuation needs of conditional, sequence, etc...
class Continuation
constructor: (@kont) ->
invoke: (value, env, kont) ->
if nilp cdr value
@kont.resume (car value)
else
throw new LispInterpreterError "Continuations expect one argument"
unwind: (value, ktarget) ->
if (@kont == ktarget) then (@kont.resume value) else (@kont.unwind value, ktarget)
catchLookup: (tag, kk) ->
@kont.catchLookup tag, kk
# Abstract class representing the environment
class Environment
lookup: -> throw new LispInterpreterError "Nonspecific invocation"
update: -> throw new LispInterpreterError "Nonspecific invocation"
blockLookup: -> throw new LispInterpreterError "Not an Environment"
# Base of the environment stack. If you hit this, your variable was
# never found for lookup/update. Note that at this time in the
# class, you have not
class NullEnv extends Environment
lookup: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
update: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
blockLookup: (name) -> throw new LispInterpreterError "Unknown block label #{name}"
# This appears to be an easy and vaguely abstract handle to the
# environment. The book is not clear on the distinction between the
# FullEnv and the VariableEnv.
class FullEnv extends Environment
constructor: (@others, @name) ->
@_type = "FullEnv"
lookup: (name, kont) ->
@others.lookup name, kont
update: (name, kont, value) ->
@others.update name, kont, value
blockLookup: (name, kont, value) ->
@others.blockLookup(name, kont, value)
# This is the classic environment pair; either it's *this*
# environment, or it's a parent environment, until you hit the
# NullEnv. Once the name has been found, the continuation is called
# with the found value.
class VariableEnv extends FullEnv
constructor: (@others, @name, @value) ->
@_type = "VariableEnv"
lookup: (name, kont) ->
if name == @name
kont.resume @value
else
@others.lookup name, kont
update: (name, kont, value) ->
if name == @name
@value = value
kont.resume value
else
@others.update name, kont, value
# "Renders the quote term to the current continuation"; in a more
# familiar parlance, calls resume in the current context with the
# quoted term uninterpreted.
evaluateQuote = (v, env, kont) ->
kont.resume normalizeForms v
# Evaluates the conditional expression, creating a continuation with
# the current environment that, when resumed, evaluates either the
# true or false branch, again in the current enviornment.
evaluateIf = (exps, env, kont) ->
evaluate (car exps), env, new IfCont(kont, (cadr exps), (caddr exps), env)
class IfCont extends Continuation
constructor: (@kont, @ift, @iff, @env) ->
@_type = "IfCont"
resume: (value) ->
evaluate (if value == the_false_value then @iff else @ift), @env, @kont
# Sequences: evaluates the current expression with a continuation that
# represents "the next expression" in the sequence. Upon resumption,
# calls this function with that next expression.
evaluateBegin = (exps, env, kont) ->
if (pairp exps)
if pairp (cdr exps)
evaluate (car exps), env, (new BeginCont kont, exps, env)
else
evaluate (car exps), env, kont
else
kont.resume("Begin empty value")
class BeginCont extends Continuation
constructor: (@kont, @exps, @env) ->
@_type = "BeginCont"
resume: (v) -> evaluateBegin (cdr @exps), @env, @kont
# In this continuation, we simply pass the continuation and the name
# to the environment to look up. The environment knows to call the
# continuation with the value.
evaluateVariable = (name, env, kont) ->
env.lookup(name, kont)
# This is the same dance as lookup, only with the continuation being
# called after an update has been performed.
evaluateSet = (name, exp, env, kont) ->
evaluate exp, env, (new SetCont(kont, name, env))
class SetCont extends Continuation
constructor: (@kont, @name, @env) ->
@_type = "SetCont"
resume: (value) ->
@env.update @name, @kont, value
# Calls the current contunation, passing it a new function wrapper.
evaluateLambda = (names, exp, env, kont) ->
kont.resume new Function names, exp, env
# Upon invocation, evaluates the body with a new environment that
# consists of the original names, their current values as called, and
# the continuation an the moment of invocation, which will continue
# (resume) execution once the function is finished.
#
# By the way: this is pretty much the whole the point.
class Function extends Value
constructor: (@variables, @body, @env) ->
@_type = "Function"
invoke: (values, env, kont) ->
evaluateBegin @body, (extend @env, @variables, values), kont
# Helper function to build name/value pairs for the current execution
# context.
extend = (env, names, values) ->
if (pairp names) and (pairp values)
new VariableEnv (extend env, (cdr names), (cdr values)), (car names), (car values)
else if (nilp names)
if (nilp values) then env else throw new LispInterpreterError "Arity mismatch"
else
new VariableEnv env, names, values
# Now we start the invocation: this is applying the function. Let's
# take it stepwise.
# Create a function environment. Calls the evaluateArguments(), which
# in turns goes down the list of arguments and creates a new
# environment, and then the continuation is to actually appy the nev
# environment to the existing function.
evaluateApplication = (exp, exps, env, kont) ->
evaluate exp, env, (new EvFunCont kont, exps, env)
class EvFunCont extends Continuation
constructor: (@kont, @exp, @env) ->
@_type = "EvFunCont"
resume: (f) ->
evaluateArguments @exp, @env, (new ApplyCont(@kont, f, @env))
# Evaluate the first list, creating a new list of the arguments. Upon
# completion, resume the continuation with the gather phase
evaluateArguments = (exp, env, kont) ->
if (pairp exp)
evaluate (car exp), env, (new ArgumentCont kont, exp, env)
else
kont.resume(nil)
class ArgumentCont extends Continuation
constructor: (@kont, @exp, @env) ->
@_type = "ArgumentCont"
resume: (v) ->
evaluateArguments (cdr @exp), @env, (new GatherCont @kont, v)
# Gather the arguments as each ArgumentCont is resumed into a list to
# be passed to our next step.
class GatherCont extends Continuation
constructor: (@kont, @value) ->
@_type = "GatherCont"
resume: (value) ->
@kont.resume (cons @value, value)
# Upon resumption, invoke the function.
class ApplyCont extends Continuation
constructor: (@kont, @fn, @env) ->
@_type = "ApplyCont"
resume: (value) ->
@fn.invoke value, @env, @kont
# A special continuation that represents what we want the interpreter
# to do when it's done processing.
class BottomCont extends Continuation
constructor: (@kont, @func) ->
@_type = "BottomCont"
resume: (value) ->
@func(value)
unwind: (value, ktarget) ->
throw new LispInterpreterError "Obsolete continuation"
catchLookup: (tag, kk) ->
throw new LispInterpreterError "No associated catch"
evaluateBlock = (label, body, env, kont) ->
k = new BlockCont(kont, label)
evaluateBegin body, (new BlockEnv env, label, kont), k
class BlockCont extends Continuation
constructor: (@kont, @label) ->
@_type = "BlockCont"
resume: (value) ->
@kont.resume value
class BlockEnv extends FullEnv
constructor: (@others, @name, @kont) ->
blockLookup: (name, kont, value) ->
if (name == @name)
kont.unwind value, @kont
else
@others.blockLookup(name, kont, value)
evaluateReturnFrom = (label, form, env, kont) ->
evaluate form, env, (new ReturnFromCont kont, env, label)
class ReturnFromCont extends Continuation
constructor: (@kont, @env, @label) ->
resume: (v) ->
@env.blockLookup @label, @kont, v
evaluateCatch = (tag, body, env, kont) ->
evaluate tag, env, (new CatchCont kont, body, env)
class CatchCont extends Continuation
constructor: (@kont, @body, @env) ->
resume: (value) ->
evaluateBegin @body, @env, (new LabeledCont @kont, value)
class LabeledCont extends Continuation
constructor: (@kont, @tag) ->
resume: (value) ->
@kont.resume value
catchLookup: (tag, kk) ->
if eq tag, @tag
evaluate kk.form, kk.env, (new ThrowingCont kk, tag, this)
else
@kont.catchLookup tag, kk
class ThrowCont extends Continuation
constructor: (@kont, @form, @env) ->
resume: (value) ->
@catchLookup value, @
evaluateThrow = (tag, form, env, kont) ->
evaluate tag, env, (new ThrowCont kont, form, env)
class ThrowingCont extends Continuation
constructor: (@kont, @tag, @resumecont) ->
resume: (value) ->
@resumecont.resume value
evaluateUnwindProtect = (form, cleanup, env, kont) ->
evaluate form, env, (new UnwindProtectCont kont, cleanup, env)
class UnwindProtectCont extends Continuation
constructor: (@kont, @cleanup, @env) ->
resume: (value) ->
evaluateBegin @cleanup, @env, (new ProtectReturnCont @kont, value)
class Primitive extends Value
constructor: (@name, @nativ) ->
@_type = "Primitive"
invoke: (args, env, kont) ->
@nativ.apply null, [args, env, kont]
env_init = new NullEnv()
definitial = (name, value = nil) ->
env_init = new VariableEnv env_init, name, value
name
defprimitive = (name, nativ, arity) ->
definitial name, new Primitive name, (args, env, kont) ->
vmargs = listToVector(args)
if (vmargs.length == arity)
kont.resume (nativ.apply null, vmargs)
else
throw new LispInterpreterError "Incorrect arity"
defpredicate = (name, nativ, arity) ->
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
definitial "#t", true
definitial "#f", the_false_value
definitial "nil", nil
# FIXME: All of these things dereference to the same value!!!!
for i in [
"x", "y", "z", "a", "b", "c", "foo", "bar", "hux",
"fib", "fact", "visit", "primes", "length"]
definitial i
defprimitive "cons", cons, 2
defprimitive "car", car, 2
defprimitive "cdr", cdr, 2
defprimitive "set-cdr!", setcdr, 2
defprimitive "set-car!", setcar, 2
defprimitive "+", ((a, b) -> a + b), 2
defprimitive "*", ((a, b) -> a * b), 2
defprimitive "-", ((a, b) -> a - b), 2
defprimitive "/", ((a, b) -> a / b), 2
defpredicate "lt", ((a, b) -> a < b), 2
defpredicate "gt", ((a, b) -> a > b), 2
defpredicate "lte", ((a, b) -> a <= b), 2
defpredicate "gte", ((a, b) -> a >= b), 2
defpredicate "eq?", ((a, b) -> a == b), 2
defpredicate "pair?", ((a) -> pairp a), 1
defpredicate "nil?", ((a) -> nilp a), 1
defpredicate "symbol?", ((a) -> /\-?[0-9]+$/.test(a) == false), 1
definitial "call/cc", new Primitive "call/cc", (values, env, kont) ->
if nilp cdr values
(car values).invoke (cons kont), env, kont
else
throw new LispInterpreterError "Incorrect arity for call/cc"
definitial "apply", new Primitive "apply", (values, env, kont) ->
if pairp cdr values
f = car values
args = (() ->
(flat = (args) ->
if nilp (cdr args) then (car args) else (cons (car args), (flat cdr args)))(cdr values))()
f.invoke args, env, kont
definitial "funcall", new Primitive "funcall", (args, env, kont) ->
if not nilp cdr args
@kont.invoke (car args), (cdr args)
else
throw new LispInterpreterError "Invoke requires a function name and arguments"
definitial "list", new Primitive "list", (values, env, kont) ->
(values, env, kont) -> kont.resume(values)
# Only called in rich node mode...
astSymbolsToLispSymbols = (node) ->
return nil if nilp node
throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
handler = (cell) ->
return nil if nilp cell
cons (car cell).value, (handler cdr cell)
handler node.value
metadata_evaluation =
listp: (node) -> node.type == 'list'
symbolp: (node) -> node.type == 'symbol'
numberp: (node) -> node.type == 'number'
stringp: (node) -> node.type == 'string'
commentp: (node) -> node.type == 'comment'
nvalu: (node) -> node.value
mksymbols: (list) -> astSymbolsToLispSymbols(list)
straight_evaluation =
listp: (cell) -> cell.__type == 'list'
symbolp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] not in ["\"", ";"]
commentp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == ";"
numberp: (cell) -> typeof cell == 'number'
stringp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == "\""
boolp: (cell) -> typeof cell == 'boolean'
nullp: (cell) -> cell == null
vectorp: (cell) -> (not straight_evaluation.listp cell) and toString.call(cell) == '[object Array]'
recordp: (cell) -> (not cell._prototype?) and toSTring.call(cell) == '[object Object]'
objectp: (cell) -> (cell._prototype?) and toString.call(cell) == '[object Object]'
nilp: (cell) -> nilp(cell)
nvalu: (cell) -> cell
mksymbols: (cell) -> cell
makeEvaluator = (ix = straight_evaluation, ty="straight") ->
(exp, env, kont) ->
if ix.symbolp exp
return evaluateVariable (ix.nvalu exp), env, kont
else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
return kont.resume ix.nvalu exp
else if ix.listp exp
body = ix.nvalu exp
head = car body
if ix.symbolp head
switch (ix.nvalu head)
when "quote" then evaluateQuote (cadr body), env, kont
when "if" then evaluateIf (cdr body), env, kont
when "begin" then evaluateBegin (cdr body), env, kont
when "set!" then evaluateSet (ix.nvalu cadr body), (caddr body), env, kont
when "lambda" then evaluateLambda (ix.mksymbols cadr body), (cddr body), env, kont
when "block" then evaluateBlock (ix.nvalu cadr body), (cddr body), env, kont
when "return-from" then evaluateReturnFrom (ix.nvalu cadr body), (caddr body), env, kont
when "catch" then evaluateCatch (cadr body), (cddr body), env, kont
when "throw" then evaluateThrow (cadr body), (caddr body), env, kont
when "unwind-protect" then evaluateUnwindProtect (cadr body), (cddr body), env, kont
else evaluateApplication (car body), (cdr body), env, kont
else
evaluateApplication (car body), (cdr body), env, kont
else
throw new LispInterpreterError("Can't handle a '#{type}'")
nodeEval = makeEvaluator(metadata_evaluation, "node")
lispEval = makeEvaluator(straight_evaluation, "lisp")
evaluate = (exp, env, kont) ->
(if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env, kont)
interpreter = (ast, kont) ->
evaluate ast, env_init, new BottomCont null, kont
module.exports = interpreter

549
chapter3g/interpreter.coffee
View File

@ -1,549 +0,0 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
cadr, caadr, cadar, caddr, nilp, nil, setcdr,
metacadr, setcar} = require "cons-lists/lists"
{normalizeForms, normalizeForm} = require "../chapter1/astToList"
{Node, Symbol} = require '../chapter1/reader_types'
class LispInterpreterError extends Error
name: 'LispInterpreterError'
constructor: (@message) ->
the_false_value = (cons "false", "boolean")
# An equality function that compares two values. This is necessary
# because object comparison in Javascipt is by reference, not by value.
# I want them to be by value, and this accomplishes that in this one
# special case.
eq = (id1, id2) ->
if id1 instanceof Symbol and id2 instanceof Symbol
return id1.name == id2.name
id1 == id2
# Base class that represents a value. Base class representing a LiSP
# value, a primitive, or a function
class Value
# Represents the base class of a continuation.
class Continuation
# Takes an existing continuation, which represents what to do when
# this continuation is invoked.
constructor: (@kont) ->
# Near as I can tell, this exists strictly to support call/cc
invoke: (value, env, kont) ->
if nilp cdr value
@kont.resume (car value)
else
throw new LispInterpreterError "Continuations expect one argument"
# As we're unwinding the stack, when we receive a new ktarget we've
# "breached" where this protection was created and need to resume the
# continuation passed there.
unwind: (value, ktarget) ->
if (@ == ktarget) then (@kont.resume value) else (@kont.unwind value, ktarget)
# When a throw happens, we need to proceed down the stack looking
# for a CatchContinuation. This supports that for all continuations.
catchLookup: (tag, kk) ->
@kont.catchLookup tag, kk
# Resume is literally the "What to do next."
resume: (value) ->
throw new LispInterpreterError "Wrong continuation for #{@_type}"
# Abstract class representing the environment
class Environment
lookup: -> throw new LispInterpreterError "Nonspecific invocation"
update: -> throw new LispInterpreterError "Nonspecific invocation"
blockLookup: -> throw new LispInterpreterError "Not an Environment"
# Base of the environment stack. If you hit this, your variable was
# never found for lookup/update. Note that at this time in the
# class, you have not
class NullEnv extends Environment
lookup: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
update: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
blockLookup: (name) -> throw new LispInterpreterError "Unknown block label #{name}"
# This appears to be an easy and vaguely abstract handle to the
# environment. The book is not clear on the distinction between the
# FullEnv and the VariableEnv.
class FullEnv extends Environment
constructor: (@others, @name) ->
@_type = "FullEnv"
lookup: (name, kont) ->
@others.lookup name, kont
update: (name, kont, value) ->
@others.update name, kont, value
blockLookup: (name, kont, value) ->
@others.blockLookup(name, kont, value)
# This is the classic environment pair; either it's *this*
# environment, or it's a parent environment, until you hit the
# NullEnv. Once the name has been found, the continuation is called
# with the found value.
class VariableEnv extends FullEnv
constructor: (@others, @name, @value) ->
@_type = "VariableEnv"
lookup: (name, kont) ->
if name == @name
kont.resume @value
else
@others.lookup name, kont
update: (name, kont, value) ->
if name == @name
@value = value
kont.resume value
else
@others.update name, kont, value
# "Renders the quote term to the current continuation"; in a more
# familiar parlance, calls resume in the current context with the
# quoted term uninterpreted.
evaluateQuote = (v, env, kont) ->
kont.resume normalizeForms v
# Evaluates the conditional expression, creating a continuation with
# the current environment that, when resumed, evaluates either the
# true or false branch, again in the current enviornment.
evaluateIf = (exps, env, kont) ->
evaluate (car exps), env, new IfCont(kont, (cadr exps), (caddr exps), env)
class IfCont extends Continuation
constructor: (@kont, @ift, @iff, @env) ->
@_type = "IfCont"
resume: (value) ->
evaluate (if value == the_false_value then @iff else @ift), @env, @kont
# Sequences: evaluates the current expression with a continuation that
# represents "the next expression" in the sequence. Upon resumption,
# calls this function with that next expression. You can begin to
# note how the "what to do next" gets wrapped in deeper and deeper
# layers of context until the current needs are resolved and we
# finally reach that final expression.
evaluateBegin = (exps, env, kont) ->
if (pairp exps)
if pairp (cdr exps)
evaluate (car exps), env, (new BeginCont kont, exps, env)
else
evaluate (car exps), env, kont
else
kont.resume("Begin empty value")
class BeginCont extends Continuation
constructor: (@kont, @exps, @env) ->
@_type = "BeginCont"
resume: (v) -> evaluateBegin (cdr @exps), @env, @kont
# In this continuation, we simply pass the continuation and the name
# to the environment to look up. The environment knows to call the
# continuation with the value.
evaluateVariable = (name, env, kont) ->
env.lookup(name, kont)
# This is the same dance as lookup, only with the continuation being
# called after an update has been performed.
evaluateSet = (name, exp, env, kont) ->
evaluate exp, env, (new SetCont(kont, name, env))
class SetCont extends Continuation
constructor: (@kont, @name, @env) ->
@_type = "SetCont"
resume: (value) ->
@env.update @name, @kont, value
# Calls the current contunation, passing it a new function wrapper.
evaluateLambda = (names, exp, env, kont) ->
kont.resume new Function names, exp, env
# Upon invocation, evaluates the body with a new environment that
# consists of the original names, their current values as called, and
# the continuation an the moment of invocation, which will continue
# (resume) execution once the function is finished.
#
# By the way: this is pretty much the whole the point.
class Function extends Value
constructor: (@variables, @body, @env) ->
@_type = "Function"
invoke: (values, env, kont) ->
evaluateBegin @body, (extend @env, @variables, values), kont
# Helper function to build name/value pairs for the current execution
# context.
extend = (env, names, values) ->
if (pairp names) and (pairp values)
new VariableEnv (extend env, (cdr names), (cdr values)), (car names), (car values)
else if (nilp names)
if (nilp values) then env else throw new LispInterpreterError "Arity mismatch"
else
new VariableEnv env, names, values
# Now we start the invocation: this is applying the function. Let's
# take it stepwise.
# Evaluate the application of a function call. The first step is to
# evaluate the first element of the function call, assuming it is or
# will resolve to a function (something of type * -> *). The
# continuation we create is to evaluate-function-cont.
evaluateApplication = (exp, exps, env, kont) ->
evaluate exp, env, (new EvFunCont kont, exps, env)
# After the function reference is finally generated, the resume()
# function here takes that reference and creates an
# apply-continuation, then calls evaluateArguments. See that.
class EvFunCont extends Continuation
constructor: (@kont, @exp, @env) ->
@_type = "EvFunCont"
resume: (f) ->
evaluateArguments @exp, @env, (new ApplyCont(@kont, f, @env))
# Evaluate the argument list, creating a new list of the arguments.
# For each argument pair, in calls the gather-cont, which creates the
# actual pair and resumes by processing the next pair, building the
# new environment. When the list is exhausted, the EvFunCont's built
# ApplyCont() is called with the generated new environment and its
# associated thunk.
evaluateArguments = (exp, env, kont) ->
if (pairp exp)
evaluate (car exp), env, (new ArgumentCont kont, exp, env)
else
kont.resume(nil)
class ArgumentCont extends Continuation
constructor: (@kont, @exp, @env) ->
@_type = "ArgumentCont"
resume: (v) ->
evaluateArguments (cdr @exp), @env, (new GatherCont @kont, v)
# Gather the arguments as each ArgumentCont is resumed into a list to
# be passed to our next step.
class GatherCont extends Continuation
constructor: (@kont, @value) ->
@_type = "GatherCont"
resume: (value) ->
@kont.resume (cons @value, value)
# Called with the new environment, and the orginal continuation that
# says what to do with the value generated by this function, now that
# it's actually been invoke.
class ApplyCont extends Continuation
constructor: (@kont, @fn, @env) ->
@_type = "ApplyCont"
resume: (value) ->
@fn.invoke value, @env, @kont
# A special continuation that represents what we want the interpreter
# to do when it's done processing.
class BottomCont extends Continuation
constructor: (@kont, @func) ->
@_type = "BottomCont"
resume: (value) ->
@func(value)
unwind: (value, ktarget) ->
throw new LispInterpreterError "Obsolete continuation"
catchLookup: (tag, kk) ->
throw new LispInterpreterError "No associated catch"
# A block is an implicit begin. So we evaluate it's contents with a
# new block-environment, which will automatically unwind any contents
# found within by traversing up the environment stack looking for
# labels that match the one with which this block was created.
evaluateBlock = (label, body, env, kont) ->
k = new BlockCont(kont, label)
evaluateBegin body, (new BlockEnv env, label, k), k
class BlockCont extends Continuation
constructor: (@kont, @label) ->
@_type = "BlockCont"
resume: (value) ->
@kont.resume value
class BlockEnv extends FullEnv
constructor: (@others, @name, @kont) ->
blockLookup: (name, kont, value) ->
if (name == @name)
kont.unwind value, @kont
else
@others.blockLookup(name, kont, value)
evaluateReturnFrom = (label, form, env, kont) ->
evaluate form, env, (new ReturnFromCont kont, env, label)
# Note that when return-from-cont's body has been evaluated, we then
# unwind up the environment stack until we find the first block that
# has the same label and call the continuation saved there. Note that
# this is the *first* time that continuation and executable is stored
# on the environment, and isn't implicitly part of the continuation
# stack.
class ReturnFromCont extends Continuation
constructor: (@kont, @env, @label) ->
@_type = "ReturnFromCont"
resume: (v) ->
@env.blockLookup @label, @kont, v
evaluateCatch = (tag, body, env, kont) ->
evaluate tag, env, (new CatchCont kont, body, env)
# catch-continuation receives (from evaluate) the processed value of a
# tag, the current environment, and what should happen after the
# context containing the catch is complete (the passed in 'kont' to
# evaluateCatch). That processed value becomes the label of the new
# labeled-continuation.
class CatchCont extends Continuation
constructor: (@kont, @body, @env) ->
@_type = "CatchFromCont"
resume: (value) ->
evaluateBegin @body, @env, (new LabeledCont @kont, value)
# Resume here does just that; it just resumes with the continuation
# passed in above. But should catch be *triggered* by a throw (and
# the throw-continuation), we get the contents of throw as an object
# to be evaluated with its current environment, then continue with
# *this* as the continuation passed to throwing-continuation, which
# resumes the catchLookup until the stack is exhausted.
class LabeledCont extends Continuation
constructor: (@kont, @tag) ->
@_type = "LabeledFromCont"
resume: (value) ->
@kont.resume value
catchLookup: (tag, kk) ->
if eq tag, @tag
evaluate kk.form, kk.env, (new ThrowingCont kk, tag, this)
else
@kont.catchLookup tag, kk
class ThrowCont extends Continuation
constructor: (@kont, @form, @env) ->
@_type = "ThrowCont"
resume: (value) ->
@catchLookup value, @
evaluateThrow = (tag, form, env, kont) ->
evaluate tag, env, (new ThrowCont kont, form, env)
class UnwindCont extends Continuation
constructor: (@kont, @value, @target) ->
resume: (value) ->
@kont.unwind @value, @target
evaluateUnwindProtect = (form, cleanup, env, kont) ->
evaluate form, env, (new UnwindProtectCont kont, cleanup, env)
# If the continuation is "resumed," it works like normal; but if its
# "unwound," it works its way up the unwind stack looking for the
# target continuation to which to deliver the value.
class UnwindProtectCont extends Continuation
constructor: (@kont, @cleanup, @env) ->
@_type = "UnwindProtectCont"
resume: (value) ->
evaluateBegin @cleanup, @env, (new ProtectReturnCont @kont, value)
unwind: (value, target) ->
evaluateBegin @cleanup, @env, (new UnwindCont @kont, value, target)
# Works its way through the stack environment stack, looking for
# ("breaching") protected blocks to unwind, and processing them as
# necessary. One of those will by definition be the continuation
# passed to the catch continuation: the throwing-continuation was
# constructed with the catch continuation itself as the address of the
# resumecont.
class ThrowingCont extends Continuation
constructor: (@kont, @tag, @resumecont) ->
@_type = "ThrowingCont"
resume: (value) ->
@kont.unwind value, @resumecont
# Note that this behavior basically much like throwing-continuation,
# except that it's the resumption (the next continuation), rather than
# the rewind.
class ProtectReturnCont extends Continuation
constructor: (@kont, @value) ->
@_type = "ProtectReturnCont"
resume: (value) ->
@kont.resume @value
# The bottom of the function pile, where native code is invoked.
class Primitive extends Value
constructor: (@name, @nativ) ->
@_type = "Primitive"
invoke: (args, env, kont) ->
@nativ.apply null, [args, env, kont]
env_init = new NullEnv()
definitial = (name, value = nil) ->
env_init = new VariableEnv env_init, name, value
name
defprimitive = (name, nativ, arity) ->
definitial name, new Primitive name, (args, env, kont) ->
vmargs = listToVector(args)
if (vmargs.length == arity)
# Note that native.apply(ctx, vmargs) is expected to return a
# singleton, like all evaluate() passes.
kont.resume (nativ.apply null, vmargs)
else
throw new LispInterpreterError "Incorrect arity"
defpredicate = (name, nativ, arity) ->
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
definitial "#t", true
definitial "#f", the_false_value
definitial "nil", nil
# FIXME: All of these things dereference to the same value!!!!
for i in [
"x", "y", "z", "a", "b", "c", "foo", "bar", "hux",
"fib", "fact", "visit", "primes", "length"]
definitial i
defprimitive "cons", cons, 2
defprimitive "car", car, 2
defprimitive "cdr", cdr, 2
defprimitive "set-cdr!", setcdr, 2
defprimitive "set-car!", setcar, 2
defprimitive "+", ((a, b) -> a + b), 2
defprimitive "*", ((a, b) -> a * b), 2
defprimitive "-", ((a, b) -> a - b), 2
defprimitive "/", ((a, b) -> a / b), 2
defpredicate "lt", ((a, b) -> a < b), 2
defpredicate "gt", ((a, b) -> a > b), 2
defpredicate "lte", ((a, b) -> a <= b), 2
defpredicate "gte", ((a, b) -> a >= b), 2
defpredicate "eq?", ((a, b) -> a == b), 2
defpredicate "pair?", ((a) -> pairp a), 1
defpredicate "nil?", ((a) -> nilp a), 1
defpredicate "symbol?", ((a) -> /\-?[0-9]+$/.test(a) == false), 1
definitial "call/cc", new Primitive "call/cc", (values, env, kont) ->
if nilp cdr values
(car values).invoke (cons kont), env, kont
else
throw new LispInterpreterError "Incorrect arity for call/cc"
definitial "apply", new Primitive "apply", (values, env, kont) ->
if pairp cdr values
f = car values
args = (() ->
(flat = (args) ->
if nilp (cdr args) then (car args) else (cons (car args), (flat cdr args)))(cdr values))()
f.invoke args, env, kont
definitial "funcall", new Primitive "funcall", (args, env, kont) ->
if not nilp cdr args
kont.invoke (env.lookup (car args)), (cdr args)
else
throw new LispInterpreterError "Invoke requires a function name and arguments"
definitial "list", new Primitive "list", (values, env, kont) ->
(values, env, kont) -> kont.resume(values)
# Only called in rich node mode...
astSymbolsToLispSymbols = (node) ->
return nil if nilp node
throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
handler = (cell) ->
return nil if nilp cell
cons (car cell).value, (handler cdr cell)
handler node.value
metadata_evaluation =
listp: (node) -> node.type == 'list'
symbolp: (node) -> node.type == 'symbol'
numberp: (node) -> node.type == 'number'
stringp: (node) -> node.type == 'string'
commentp: (node) -> node.type == 'comment'
nvalu: (node) -> node.value
mksymbols: (list) -> astSymbolsToLispSymbols(list)
# The hairness of this makes me doubt the wisdom of using Javascript.
straight_evaluation =
listp: (cell) -> cell.__type == 'list'
symbolp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] not in ["\"", ";"]
commentp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == ";"
numberp: (cell) -> typeof cell == 'number'
stringp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == "\""
boolp: (cell) -> typeof cell == 'boolean'
nullp: (cell) -> cell == null
vectorp: (cell) -> (not straight_evaluation.listp cell) and toString.call(cell) == '[object Array]'
recordp: (cell) -> (not cell._prototype?) and toSTring.call(cell) == '[object Object]'
objectp: (cell) -> (cell._prototype?) and toString.call(cell) == '[object Object]'
nilp: (cell) -> nilp(cell)
nvalu: (cell) -> cell
mksymbols: (cell) -> cell
prox =
"quote": (body, env, kont, ix) -> evaluateQuote (cadr body), env, kont
"if": (body, env, kont, ix) -> evaluateIf (cdr body), env, kont
"begin": (body, env, kont, ix) -> evaluateBegin (cdr body), env, kont
"set!": (body, env, kont, ix) -> evaluateSet (ix.nvalu cadr body), (caddr body), env, kont
"lambda": (body, env, kont, ix) -> evaluateLambda (ix.mksymbols cadr body), (cddr body), env, kont
"block": (body, env, kont, ix) -> evaluateBlock (ix.nvalu cadr body), (cddr body), env, kont
"return": (body, env, kont, ix) -> evaluateReturnFrom (ix.nvalu cadr body), (caddr body), env, kont
"catch": (body, env, kont, ix) -> evaluateCatch (cadr body), (cddr body), env, kont
"throw": (body, env, kont, ix) -> evaluateThrow (cadr body), (caddr body), env, kont
"protect": (body, env, kont, ix) -> evaluateUnwindProtect (cadr body), (cddr body), env, kont
makeEvaluator = (ix = straight_evaluation, ty="straight") ->
(exp, env, kont) ->
if ix.symbolp exp
return evaluateVariable (ix.nvalu exp), env, kont
else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
return kont.resume ix.nvalu exp
else if ix.listp exp
body = ix.nvalu exp
head = car body
if ix.symbolp head
# Every call is boiled down to body/env/kont (with ix.nvalu tossed in for fun)
# It should be possible to move natives into an address space
if prox[(ix.nvalu head)]?
prox[(ix.nvalu head)](body, env, kont, ix)
else evaluateApplication (car body), (cdr body), env, kont
else
evaluateApplication (car body), (cdr body), env, kont
else
throw new LispInterpreterError("Can't handle a '#{type}'")
nodeEval = makeEvaluator(metadata_evaluation, "node")
lispEval = makeEvaluator(straight_evaluation, "lisp")
evaluate = (exp, env, kont) ->
(if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env, kont)
interpreter = (ast, kont) ->
evaluate ast, env_init, new BottomCont null, kont
module.exports = interpreter

12
chapter3g/test.coffee
View File

@ -1,12 +0,0 @@
olisp = require '../chapter3g/interpreter'
{read, readForms} = require '../chapter1/reader'
{inspect} = require 'util'
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
# console.log lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (throw 1 (throw 2 5)) )) )))"
console.log lisp read "((lambda (c) (catch 111 (* 2 (unwind-protect (* 3 (throw 111 5)) (set! c 1) ))) ) 0)"

479
chapter4/interpreter.coffee
View File

@ -1,479 +0,0 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
cadr, caadr, cadar, caddr, nilp, nil, setcdr,
metacadr, setcar} = require "cons-lists/lists"
{length} = require "cons-lists/reduce"
{normalizeForms, normalizeForm} = require "../chapter1/astToList"
{Node, Comment, Symbol} = require '../chapter1/reader_types'
{inspect} = require 'util'
itap = (a) -> return inspect a, true, null, false
class LispInterpreterError extends Error
name: 'LispInterpreterError'
constructor: (@message) ->
the_false_value = (cons "false", "boolean")
eq = (id1, id2) ->
if id1 instanceof Symbol and id2 instanceof Symbol
return id1.name == id2.name
id1 == id2
# Only called in rich node mode...
astSymbolsToLispSymbols = (node) ->
return nil if nilp node
throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
handler = (cell) ->
return nil if nilp cell
cons (car cell).value, (handler cdr cell)
handler node.value
cadddr = metacadr('cadddr')
intlistp = (node) -> node.type == 'list'
intpairp = (node) -> node.type == 'list' and ((node.value.length < 2) or node.value[1].node.type != 'list')
intsymbolp = (node) -> node.type == 'symbol' or node instanceof Symbol
intnumberp = (node) -> node.type == 'number'
intstringp = (node) -> node.type == 'string'
intcommentp = (node) -> node.type == 'comment'
intnvalu = (node) -> node.value
intatomp = (node) -> node.type in ['symbol', 'number', 'string']
intnullp = (node) -> node.type == 'symbol' and node.value.name == 'null'
intmksymbols = (list) -> astSymbolsToLispSymbols(list)
# The hairness of this makes me doubt the wisdom of using Javascript.
sBehavior = new Symbol 'behavior'
sBoolean = new Symbol 'boolean'
sBoolify = new Symbol 'boolify'
sFunction = new Symbol 'function'
sSymbol = new Symbol 'symbol'
sString = new Symbol 'string'
sValue = new Symbol 'chars'
sName = new Symbol 'name'
sNumber = new Symbol 'number'
sNull = new Symbol 'null'
sTag = new Symbol 'tag'
sType = new Symbol 'type'
sValue = new Symbol 'value'
sPair = new Symbol 'pair'
sCar = new Symbol 'car'
sCdr = new Symbol 'cdr'
sSetCar = new Symbol 'setcar'
sSetCdr = new Symbol 'setcdr'
prox =
"quote": (body, env, mem, kont) -> evaluateQuote (cadr body), env, mem, kont
"if": (body, env, mem, kont) -> evaluateIf (cadr body), (caddr body), (cadddr body), env, mem, kont
"begin": (body, env, mem, kont) -> evaluateBegin (cdr body), env, mem, kont
"set!": (body, env, mem, kont) -> evaluateSet (intnvalu cadr body), (caddr body), env, mem, kont
"lambda": (body, env, mem, kont) -> evaluateLambda (intmksymbols cadr body), (cddr body), env, mem, kont
"or": (body, env, mem, kont) -> evaluateOr (cadr body), (caddr body), env, mem, kont
# ___ _ _
# | __|_ ____ _| |_ _ __ _| |_ ___ _ _
# | _|\ V / _` | | || / _` | _/ _ \ '_|
# |___|\_/\__,_|_|\_,_\__,_|\__\___/_|
#
transcode = (value, mem, qont) ->
forms = [
[intnullp, -> qont theEmptyList, mem],
[((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> qont (createBoolean value), mem)]
[intsymbolp, (-> qont (createSymbol value), mem)]
[intnumberp, (-> qont (createNumber value), mem)]
[intstringp, (-> qont (createString value), mem)]
[intlistp, (-> transcode (car intnvalu value), mem, (addr, mem2) ->
(transcode (cdr intvalu value), mem2, (d, mem3) ->
(allocatePair addr, d, mem3, qont)))]
]
found = (form[1] for form in forms when form[0](value))
if found.length != 1
throw new LispInterpreterError "Bad transcode match for #{value}"
found[0]()
transcode2 = (value, mem, qont) ->
forms = [
[((v) -> v instanceof Symbol and v.name == 'null'), (-> qont theEmptyList, mem)],
[((v) -> v instanceof Symbol and v.name in ['#t', '#f']), (-> qont (createBoolean value), mem)]
[((v) -> v instanceof Symbol), (-> qont (createSymbol value), mem)]
[((v) -> typeof v == 'string'), (-> qont (createString value), mem)]
[((v) -> typeof v == 'number'), (-> qont (createNumber value), mem)]
[((v) -> v.__type == 'list'), (-> transcode (car value), mem, (addr, mem2) ->
(transcode (cdr value), mem2, (d, mem3) ->
(allocatePair addr, d, mem3, qont)))]
]
found = (form[1] for form in forms when form[0](value))
if found.length < 1
throw new LispInterpreterError "Bad transcode match for #{value}"
found[0]()
transcodeBack = (value, mem) ->
forms = [
[sBoolean, ((v) -> ((v sBoolify) true, false))]
[sSymbol, ((v) -> (v sName))]
[sString, ((v) -> (v sValue))]
[sNumber, ((v) -> (v sValue))]
[sPair, ((v) ->
cons (transcodeBack (mem (v sCar)), mem), (transcodeBack (mem (v sCdr)), mem))]
[sFunction, (v) -> v]
]
found = (form[1] for form in forms when (eq (value sType), form[0]))
if found.length != 1
throw new LispInterpreterError "Bad transcode-back match for #{value}"
found[0](value)
evaluate = (exp, env, mem, kont) ->
if intatomp exp
if intsymbolp exp
evaluateVariable (intnvalu exp), env, mem, kont
else
evaluateQuote exp, env, mem, kont
else
body = intnvalu exp
head = car body
pname = (intnvalu head)
if pname instanceof Symbol and prox[pname.name]?
prox[pname.name](body, env, mem, kont)
else
evaluateApplication head, (cdr body), env, mem, kont
env_init = (id) ->
throw new LispInterpreterError "No binding for " + id
# This is basically the core definition of 'mem': it returns a
# function enclosing the address (a monotomically increasing number as
# memory is allocated) and the value. Update is passed the current
# memory, the address, and the value; it returns a function that says
# "If the requested address is my address, return my value, otherwise
# I'll call the memory handed to me at creation time with the address,
# and it'll go down the line." Update basically adds to a 'stack'
# built entirely out of pointers to the base mem.
update = (mem, addr, value) ->
(addra) -> if (eq addra, addr) then value else (mem addra)
updates = (mem, addrs, values) ->
if (pairp addrs)
updates (update mem, (car addrs), (car values)), (cdr addrs), (cdr values)
else
mem
# Memory location zero contains the position of the stack.
expandStore = (highLocation, mem) ->
update mem, 0, highLocation
mem_init = expandStore 0, (a) ->
throw new LispInterpreterError "No such address #{a}"
newLocation = (mem) ->
(mem 0) + 1
evaluateVariable = (name, env, mem, kont) ->
kont (mem (env name)), mem
evaluateSet = (name, exp, env, mem, kont) ->
evaluate exp, env, mem, (value, mem2) ->
kont value, (update mem2, (env name), value)
evaluateApplication = (exp, exprs, env, mem, kont) ->
# In chapter 3, this was a series of jumping continuations chasing
# each other. Here, all of the continuations are kept in one place,
# and the argument list is built by tail-calls to evaluateArguments
# until the list is exhausted, at which point the continuation is
# called. The continuation is built in the second paragraph below.
evaluateArguments = (exprs, env, mem, kont) ->
if (pairp exprs)
evaluate (car exprs), env, mem, (value, mem2) ->
evaluateArguments (cdr exprs), env, mem2, (value2, mem3) ->
kont (cons value, value2), mem3
else
kont cons(), mem
evaluate exp, env, mem, (fun, mem2) ->
evaluateArguments exprs, env, mem2, (value2, mem3) ->
if eq (fun sType), sFunction
(fun sBehavior) value2, mem3, kont
else
throw new LispInterpreterError "Not a function #{(car value2)}"
# Creates a memory address for the function, then creates a new memory
# address for each argument, then evaluates the expressions in the
# lambda, returning the value of the last one.
evaluateLambda = (names, exprs, env, mem, kont) ->
allocate 1, mem, (addrs, mem2) ->
kont (createFunction (car addrs), (values, mem, kont) ->
if eq (length names), (length values)
allocate (length names), mem, (addrs, mem2) ->
evaluateBegin exprs, (updates env, names, addrs), (updates mem2, addrs, values), kont
else
throw new LispInterpreterError "Incorrect Arrity"), mem2
evaluateIf = (expc, expt, expf, env, mem, kont) ->
evaluate expc, env, mem, (env, mems) ->
evaluate ((env sBoolify) expt, expf), env, mems, kont
evaluateQuote = (c, env, mem, kont) ->
transcode2 (normalizeForm c), mem, kont
# By starting over "from here," we undo all side-effect assignments
# that were effected by expression 1
evaluateOr = (exp1, exp2, env, mem, kont) ->
evaluate exp1, env, mem, (value, mem2) ->
((value sBoolify) (-> kont value, mem2), (-> evaluate exp2, env, mem, kont))()
# I like how, in this version, we explicitly throw away the meaning of
# all but the last statement in evaluateBegin.
evaluateBegin = (exps, env, mem, kont) ->
if pairp (cdr exps)
evaluate (car exps), env, mem, (_, mems) ->
evaluateBegin (cdr exps), env, mems, kont
else
evaluate (car exps), env, mem, kont
theEmptyList = (msg) ->
switch msg
when sType then sNull
when sBoolify then (x, y) -> x
createBoolean = (value) ->
combinator = if value then ((x, y) -> x) else ((x, y) -> y)
(msg) ->
switch msg
when sType then sBoolean
when sBoolify then combinator
createSymbol = (value) ->
(msg) ->
switch msg
when sType then sSymbol
when sName then value
when sBoolify then (x, y) -> x
createNumber = (value) ->
(msg) ->
switch msg
when sType then sNumber
when sValue then value
when sBoolify then (x, y) -> x
createString = (value) ->
(msg) ->
switch msg
when sType then sString
when sValue then value
when sBoolify then (x, y) -> x
createFunction = (tag, behavior) ->
(msg) ->
switch msg
when sType then sFunction
when sBoolify then (x, y) -> x
when sTag then tag
when sBehavior then behavior
# I'm not sure I get the difference between allocate and update.
# Update appears to have the power to append to the memory list
# without updating highLocation. If I'm reading this correct, then
# what we're actually looking at is a simulation of a memory
# subsystem, with expandStore/newLocation/allocate taking on the duty
# of "managing" our stack, and update actually just doing the managing
# the stack, and letting the garbage collector do its thing when a
# pointer to memory function goes out of scope. In short: the
# allocate collection of functions is "going through the motions" of
# managing memory; had this been a real memory manager, you'd have
# a lot more work to do.
allocate = (num, mem, q) ->
if (num > 0)
do ->
addr = newLocation mem
allocate (num - 1), (expandStore addr, mem), (addrs, mem2) ->
q (cons addr, addrs), mem2
else
q cons(), mem
allocateList = (values, mem, q) ->
consify = (values, q) ->
if (pairp values)
consify (cdr values), (value, mem2) ->
allocatePair (car values), value, mem2, q
else
q theEmptyList, mem
consify values, q
allocatePair = (addr, d, mem, q) ->
allocate 2, mem, (addrs, mem2) ->
q (createPair (car addrs), (cadr addrs)), (update (update mem2, (car addrs), addr), (cadr addrs), d)
createPair = (a, d) ->
(msg) ->
switch msg
when sType then sPair
when sBoolify then (x, y) -> x
when sSetCar then (mem, val) -> update mem, a, val
when sSetCdr then (mem, val) -> update mem, d, val
when sCar then a
when sCdr then d
env_global = env_init
mem_global = mem_init
# The name is pushed onto the global environment, with a corresponding
# address. The address is pushed onto the current memory, with the
# corresponding boxed value.
defInitial = (name, value) ->
if typeof name == 'string'
name = new Symbol name
allocate 1, mem_global, (addrs, mem2) ->
env_global = update env_global, name, (car addrs)
mem_global = update mem2, (car addrs), value
defPrimitive = (name, arity, value) ->
defInitial name, allocate 1, mem_global, (addrs, mem2) ->
mem_global = expandStore (car addrs), mem2
createFunction (car addrs), (values, mem, kont) ->
if (eq arity, (length values))
value values, mem, kont
else
throw new LispInterpreterError "Wrong arity for #{name}"
# ___ _ _ _ _ _ _ _
# |_ _|_ _ (_) |_(_) (_)_____ _| |_(_)___ _ _
# | || ' \| | _| | | |_ / _` | _| / _ \ ' \
# |___|_||_|_|\__|_|_|_/__\__,_|\__|_\___/_||_|
#
defInitial "#t", createBoolean true
defInitial "#f", createBoolean false
defInitial "nil", null
defPrimitive "<=", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
kont (createBoolean (((car values) sValue) <= ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Comparison requires numbers"
defPrimitive "<", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
kont (createBoolean (((car values) sValue) < ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Comparison requires numbers"
defPrimitive ">=", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
kont (createBoolean (((car values) sValue) >= ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Comparison requires numbers"
defPrimitive ">", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
kont (createBoolean (((car values) sValue) > ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Comparison requires numbers"
defPrimitive "=", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sType), sNumber)
kont (createBoolean (((car values) sValue) == ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Comparison requires numbers"
defPrimitive "*", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
kont (createNumber (((car values) sValue) * ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Multiplication requires numbers"
defPrimitive "+", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sType), sNumber)
kont (createNumber (((car values) sValue) + ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Addition requires numbers"
defPrimitive "/", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
kont (createNumber (((car values) sValue) / ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Division requires numbers"
defPrimitive "*", 2, (values, mem, kont) ->
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
kont (createNumber (((car values) sValue) - ((cadr values) sValue))), mem
else
throw new LispInterpreterError "Subtraction requires numbers"
defPrimitive "cons", 2, (values, mem, kont) ->
allocatePair (car values), (cadr values), mem, kont
defPrimitive "car", 1, (values, mem, kont) ->
if (eq ((car values) sType) sPair)
kont (mem ((car values) sCar)), mem
else
throw new LispInterpreterError "Not a pair"
defPrimitive "cdr", 1, (values, mem, kont) ->
if (eq ((car values) sType) sPair)
kont (mem ((car values) sCdr)), mem
else
throw new LispInterpreterError "Not a pair"
defPrimitive "setcdr", 2, (values, mem, kont) ->
if (eq ((car values) sType) sPair)
pair = (car values)
kont pair, ((pair sSetCdr) mem, (cadr values))
else
throw new LispInterpreterError "Not a pair"
defPrimitive "setcar", 2, (values, mem, kont) ->
if (eq ((car values) sType) sPair)
pair = (car values)
kont pair, ((pair sSetCar) mem, (cadr values))
else
throw new LispInterpreterError "Not a pair"
defPrimitive "eq?", 2, (values, mem, kont) ->
kont createBoolean (
if (eq ((car values) sType), ((cadr values) sType))
switch ((car values) sType)
when sBoolean
((car values) sBoolify) (((cadr values) sBoolify) true, false), (((cadr values) sBoolify) false, true)
when sSymbol
eq ((car values) sName), ((cadr values) sName)
when sPair
(((car values) sCar) == ((cadr values) sCar) and
((car values) sCdr) == ((cadr values) sCdr))
when sFunction
((car values) sTag) == ((cadr values) sTag)
else false
else false)
defPrimitive "eqv?", 2, (values, mem, kont) ->
kont createBoolean (
if (eq ((car values) sType), ((cadr values) sType))
switch ((car values) sType)
when sBoolean
((car values) sBoolify) (((cadr values) sBoolify) true, false), (((cadr values) sBoolify) false, true)
when sSymbol
eq ((car values) sName), ((cadr values) sName)
when sNumber
((car values) sValue) == ((cadr values) sValue)
when sPair
(((car values) sCar) == ((cadr values) sCar) and
((car values) sCdr) == ((cadr values) sCdr))
when sFunction
((car values) sTag) == ((cadr values) sTag)
else false
else false)
module.exports = (ast, kont) ->
evaluate ast, env_global, mem_global, (value, mem) ->
kont (transcodeBack value, mem)

204
chapter4/reader.coffee
View File

@ -1,204 +0,0 @@
{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
{inspect} = require "util"
{Node, Comment, Symbol} = require "../chapter1/reader_types"
NEWLINES = ["\n", "\r", "\x0B", "\x0C"]
WHITESPACE = [" ", "\t"].concat(NEWLINES)
EOF = new (class Eof)()
EOO = new (class Eoo)()
class Source
constructor: (@inStream) ->
@index = 0
@max = @inStream.length - 1
@line = 0
@column = 0
peek: -> @inStream[@index]
position: -> [@line, @column]
next: ->
c = @peek()
return EOF if @done()
@index++
[@line, @column] = if @peek() in NEWLINES then [@line + 1, 0] else [@line, @column + 1]
c
done: -> @index > @max
# IO -> IO
skipWS = (inStream) ->
while inStream.peek() in WHITESPACE then inStream.next()
# msg -> (IO -> Node => Error)
handleError = (message) ->
(line, column) -> new Node('error', message, line, column)
# IO -> Node => Comment
readComment = (inStream) ->
[line, column] = inStream.position()
r = (while inStream.peek() != "\n" and not inStream.done()
inStream.next()).join("")
if not inStream.done()
inStream.next()
new Node 'comment', (new Comment r), line, column
# IO -> (Node => Literal => String) | Error
readString = (inStream) ->
[line, column] = inStream.position()
inStream.next()
string = until inStream.peek() == '"' or inStream.done()
if inStream.peek() == '\\'
inStream.next()
inStream.next()
if inStream.done()
return handleError("end of file seen before end of string.")(line, column)
inStream.next()
new Node 'string', (string.join ''), line, column
# (String) -> (Node => Literal => Number) | Nothing
readMaybeNumber = (symbol) ->
if symbol[0] == '+'
return readMaybeNumber symbol.substr(1)
if symbol[0] == '-'
ret = readMaybeNumber symbol.substr(1)
return if ret? then -1 * ret else undefined
if symbol.search(/^0x[0-9a-fA-F]+$/) > -1
return parseInt(symbol, 16)
if symbol.search(/^0[0-9a-fA-F]+$/) > -1
return parseInt(symbol, 8)
if symbol.search(/^[0-9]+$/) > -1
return parseInt(symbol, 10)
if symbol.search(/^nil$/) > -1
return nil
undefined
# (IO, macros) -> (IO, Node => Number | Symbol) | Error
readSymbol = (inStream, tableKeys) ->
[line, column] = inStream.position()
symbol = (until (inStream.done() or inStream.peek() in tableKeys or inStream.peek() in WHITESPACE)
inStream.next()).join ''
number = readMaybeNumber symbol
if number?
return new Node 'number', number, line, column
new Node 'symbol', (new Symbol symbol), line, column
# (Delim, TypeName) -> IO -> (IO, node) | Error
makeReadPair = (delim, type) ->
# IO -> (IO, Node) | Error
(inStream) ->
inStream.next()
skipWS inStream
[line, column] = inStream.position()
if inStream.peek() == delim
inStream.next()
return new Node type, nil, line, column
# IO -> (IO, Node) | Error
dotted = false
readEachPair = (inStream) ->
[line, column] = inStream.position()
obj = read inStream, true, null, true
if inStream.peek() == delim
if dotted then return obj
return cons obj, nil
if inStream.done() then return handleError("Unexpected end of input")(line, column)
if dotted then return handleError("More than one symbol after dot")
return obj if obj.type == 'error'
if obj.type == 'symbol' and obj.value == '.'
dotted = true
return readEachPair inStream
cons obj, readEachPair inStream
ret = new Node type, readEachPair(inStream), line, column
inStream.next()
ret
# Type -> (IO -> (IO, Node))
prefixReader = (type) ->
# IO -> (IO, Node)
(inStream) ->
[line, column] = inStream.position()
inStream.next()
[line1, column1] = inStream.position()
obj = read inStream, true, null, true
return obj if obj.type == 'error'
new Node "list", cons((new Node("symbol", (new Symbol type), line1, column1)), cons(obj)), line, column
# I really wanted to make anything more complex than a list (like an
# object or a vector) something handled by a read macro. Maybe in a
# future revision I can vertically de-integrate these.
readMacros =
'"': readString
'(': makeReadPair ')', 'list'
')': handleError "Closing paren encountered"
'[': makeReadPair ']', 'vector'
']': handleError "Closing bracket encountered"
'{': makeReadPair('}', 'record', (res) ->
res.length % 2 == 0 and true or mkerr "record key without value")
'}': handleError "Closing curly without corresponding opening."
"`": prefixReader 'back-quote'
"'": prefixReader 'quote'
",": prefixReader 'unquote'
";": readComment
# Given a stream, reads from the stream until a single complete lisp
# object has been found and returns the object
# IO -> Form
read = (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, inReadMacros = null, keepComments = false) ->
inStream = if inStream instanceof Source then inStream else new Source inStream
inReadMacros = if InReadMacros? then inReadMacros else readMacros
inReadMacroKeys = (i for i of inReadMacros)
c = inStream.peek()
# (IO, Char) -> (IO, Node) | Error
matcher = (inStream, c) ->
if inStream.done()
return if recursiveP then handleError('EOF while processing nested object')(inStream) else nil
if c in WHITESPACE
inStream.next()
return nil
if c == ';'
return readComment(inStream)
ret = if c in inReadMacroKeys then inReadMacros[c](inStream) else readSymbol(inStream, inReadMacroKeys)
skipWS inStream
ret
while true
form = matcher inStream, c
skip = (not nilp form) and (form.type == 'comment') and not keepComments
break if (not skip and not nilp form) or inStream.done()
c = inStream.peek()
null
form
# readForms assumes that the string provided contains zero or more
# forms. As such, it always returns a list of zero or more forms.
# IO -> (Form* | Error)
readForms = (inStream) ->
inStream = if inStream instanceof Source then inStream else new Source inStream
return nil if inStream.done()
# IO -> (FORM*, IO) | Error
[line, column] = inStream.position()
readEach = (inStream) ->
obj = read inStream, true, null, false
return nil if (nilp obj)
return obj if obj.type == 'error'
cons obj, readEach inStream
obj = readEach inStream
if obj.type == 'error' then obj else new Node "list", obj, line, column
exports.read = read
exports.readForms = readForms
exports.Node = Node
exports.Symbol = Symbol

374
chapter5/interpreter5a.coffee
View File

@ -1,374 +0,0 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
cadr, caadr, cadar, caddr, nilp, nil, setcdr,
metacadr, setcar} = require "cons-lists/lists"
{map} = require "cons-lists/reduce"
{length} = require "cons-lists/reduce"
{Node, Comment, Symbol} = require '../chapter5/reader_types'
{inspect} = require 'util'
itap = (a) -> console.log inspect a, true, null, false; a
ftap = (a) -> console.log Function.prototype.toString.call(a); a
class Value
vpos = 0
constructor: (@v) ->
vpos = vpos + 1
inValue = (f) ->
new Value(f)
class LispInterpreterError extends Error
name: 'LispInterpreterError'
constructor: (@message) ->
the_false_value = (cons "false", "boolean")
eq = (id1, id2) ->
if id1 instanceof Symbol and id2 instanceof Symbol
return id1.name == id2.name
id1 == id2
cadddr = metacadr('cadddr')
# Hack
gsym = (x) -> if (x instanceof Symbol) then x.name else x
consp = (e) ->
((pairp e) and (typeof (car e) == 'number') and
((car e) > 0) and (pairp cdr e) and (typeof (cadr e) == 'number') and
((cadr e) > 0) and (nilp cddr e))
convert = (exp, store) ->
conv = (e) ->
if consp e
cons (conv (store (car e)).v), (conv (store (cadr e)).v)
else
if symbolp e then e.name
else if stringp e then '"' + e | '"'
else e
conv exp.v
# 5.2.4
# f[y → z] = λx . if y = x then z else f(x) endif
#
# Accepts a parent function, and ID and a value. Returns a function
# that takes a request ID. If the request ID equals the ID above,
# return the value, else call the parent function with the request
# ID.
#
# Calls allocate
extend = (next, id, value) ->
(x) -> if (eq x, id) then value else (next x)
# f[y* → z*] = if #y>0 then f[y*†1 → z*†1][y*↓1 → z*↓1] else f endif
#
# Helper. Builds a stack of extend() functions, at tail of which it
# appends the parent function.
#
#
lextends = (fn, ids, values) ->
if (pairp ids)
extend (lextends fn, (cdr ids), (cdr values)), (car ids), (car values)
else
fn
translate = (exp, store, qont) ->
if (pairp exp)
translate (car exp), store, (val1, store1) ->
translate (cdr exp), store1, (val2, store2) ->
allocate store2, 2, (store, addrs) ->
qont (inValue addrs), (extend (extend store, (car addrs), val1), (cadr addrs), val2)
else
qont (inValue exp), store
# Allocate is a function that takes a store, a number of addresses to
# allocate within that store, and a continuation; at the end, it calls
# the continuation with the store object and the new addresses.
allocate = (->
loc = 0
(store, num, qont) ->
aloop = (n, a) ->
if (n > 0)
loc = loc - 1
aloop (n - 1), (cons loc, a)
else
qont store, a
aloop(num, cons()))()
listp = (cell) -> cell.__type == 'list'
atomp = (cell) -> not (cell.__type?) or (not cell.__type == 'list')
symbolp = (cell) -> cell instanceof Symbol
commentp = (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == ";"
numberp = (cell) -> typeof cell == 'number'
stringp = (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == "\""
boolp = (cell) -> typeof cell == 'boolean'
nullp = (cell) -> cell == null
vectorp = (cell) -> (not straight_evaluation.listp cell) and toString.call(cell) == '[object Array]'
recordp = (cell) -> (not cell._prototype?) and toSTring.call(cell) == '[object Object]'
objectp = (cell) -> (cell._prototype?) and toString.call(cell) == '[object Object]'
nilp = (cell) -> nilp(cell)
nvalu = (cell) -> cell
mksymbols = (cell) -> cell
sBehavior = new Symbol 'behavior'
sBoolean = new Symbol 'boolean'
sBoolify = new Symbol 'boolify'
sFunction = new Symbol 'function'
sSymbol = new Symbol 'symbol'
sString = new Symbol 'string'
sQuote = new Symbol 'quote'
sLambda = new Symbol 'lambda'
sIf = new Symbol 'if'
sValue = new Symbol 'value'
sChars = new Symbol 'chars'
sBegin = new Symbol 'begin'
sName = new Symbol 'name'
sNumber = new Symbol 'number'
sNull = new Symbol 'null'
sTag = new Symbol 'tag'
sSet = new Symbol 'set'
sType = new Symbol 'type'
sValue = new Symbol 'value'
sPair = new Symbol 'pair'
sCar = new Symbol 'car'
sCdr = new Symbol 'cdr'
sSetCar = new Symbol 'setcar'
sSetCdr = new Symbol 'setcdr'
ValueToFunction = (e) ->
c = e.v
if (typeof c == 'function') then c else throw new LispInterpreterError("Not a function: " + Object.toString(c))
ValueToPair = (e) ->
c = e.v
if pairp c then c else throw new LispInterpreterError("Not a pair: " + Object.toString(c))
ValueToNumber = (e) ->
c = parseInt(e.v, 10)
if (typeof c == 'number') then c else throw new LispInterpreterError("Not a number: " + Object.toString(c))
ValueToPrimitive = (e) ->
return e.v
store_init = (a) -> throw new LispInterpreterError "No such address: #{a}"
env_init = (a) -> throw new LispInterpreterError "No such variable: #{a}"
class Interpreter
constructor: ->
arity_check = (name, arity, fn) =>
(values, kont, store) =>
if not eq (length values), arity
throw new LispInterpreterError "Incorrect Arity for #{name}"
fn(values, kont, store)
@definitial "cons", inValue arity_check "cons", 2, (values, kont, store) =>
allocate store, 2, (store, addrs) =>
kont (inValue (cons (car addrs), (cadr addrs))), (lextends store, addrs, values)
@definitial "car", inValue arity_check "car", 1, (values, kont, store) =>
kont (store car @valueToPair (car values)), store
@definitial "cdr", inValue arity_check "car", 1, (values, kont, store) =>
kont (store cadr @valueToPair (car values)), store
@defprimitive "pair?", ((v) -> inValue (consp v.v)), 1
@defprimitive "eq?", ((v1, v2) -> inValue (eq v1.v, v2.v)), 2
@defprimitive "symbol?", ((v) -> inValue (symbolp v.v)), 1
@definitial "set-car!", inValue arity_check, "set-car!", 2, (values, kont, store) ->
kont (car values), (extend store, (car (ValueToPair (car values))), (cadr values))
@definitial "set-cdr!", inValue arity_check, "set-cdr!", 2, (values, kont, store) ->
kont (car values), (extend store, (cadr (ValueToPair (car values))), (cadr values))
@defarithmetic "+", ((x, y) -> x + y), 2
@defarithmetic "-", ((x, y) -> x - y), 2
@defarithmetic "*", ((x, y) -> x * y), 2
@defarithmetic "/", ((x, y) -> x / y), 2
@defarithmetic "<", ((x, y) -> x < y), 2
@defarithmetic ">", ((x, y) -> x > y), 2
@defarithmetic "=", ((x, y) -> x == y), 2
@defarithmetic "<=", ((x, y) -> x <= y), 2
@defarithmetic ">=", ((x, y) -> x >= y), 2
@defarithmetic "%", ((x, y) -> x % y), 2
@definitial "apply", arity_check "apply", 2, inValue (values, kont, store) ->
flat = (v) ->
if pairp v.v
cons (store (car (ValueToPair v))), (flat (store (cadr (ValueToPair v))))
else
cons()
collect = (values) ->
if nullp cdr values
flat car values
else
cons (car values), (collect cdr values)
(ValueToFunction (car values)) (collect (cdr values)), kont, store
@definitial '#t', (inValue true)
@definitial '#f', (inValue false)
@definitial 'nil', (inValue cons())
@definitial "x", inValue (new Object(null))
@definitial "y", inValue (new Object(null))
@definitial "z", inValue (new Object(null))
@definitial "a", inValue (new Object(null))
@definitial "b", inValue (new Object(null))
@definitial "c", inValue (new Object(null))
@definitial "foo", inValue (new Object(null))
@definitial "bar", inValue (new Object(null))
@definitial "hux", inValue (new Object(null))
@definitial "fib", inValue (new Object(null))
@definitial "fact", inValue (new Object(null))
@definitial "visit", inValue (new Object(null))
@definitial "length", inValue (new Object(null))
@definitial "filter", inValue (new Object(null))
@definitial "primes", inValue (new Object(null))
meaning: (e) ->
meaningTable =
"quote": ((e) => @meaningQuotation (cadr e))
'lambda': ((e) => @meaningAbstraction (cadr e), (cddr e))
'if': ((e) => @meaningAlternative (cadr e), (caddr e), (cadddr e))
'begin': ((e) => @meaningSequence (cdr e))
'set!': ((e) => @meaningAssignment (cadr e), (caddr e))
if (atomp e)
return if (symbolp e) then (@meaningReference gsym(e)) else (@meaningQuotation e)
n = gsym(car e)
if meaningTable[n]?
meaningTable[n](e)
else
@meaningApplication (car e), (cdr e)
meaningSequence: (exps) =>
(env, kont, store) =>
(@meaningsSequence exps) env, kont, store
meaningsMultipleSequence: (exp, exps) ->
(env, kont, store) =>
hkont = (values, store1) =>
(@meaningsSequence exps) env, kont, store1
(@meaning exp) env, hkont, store
meaningsSingleSequence: (exp) ->
(env, kont, store) =>
(@meaning exp) env, kont, store
meaningsSequence: (exps) ->
if not (pairp exps)
throw new LispInterpreterError("Illegal Syntax")
if pairp cdr exps
@meaningsMultipleSequence (car exps), (cdr exps)
else
@meaningsSingleSequence (car exps)
meaningQuotation: (val) ->
(env, kont, store) ->
(translate val, store, kont)
meaningReference: (name) ->
(env, kont, store) ->
kont (store (env name)), store
# Extensional alternative
meaningAlternative: (exp1, exp2, exp3) ->
boolify = (value) ->
if (eq? value (inValue false)) then ((x, y) -> y) else ((x, y) -> x)
ef = (val, val1, val2) ->
val val1, val2
(env, kont, store) =>
hkont = (val, store1) =>
ef (boolify val), ((@meaning exp2) env, kont, store1), ((@meaning exp3) env, kont, store1)
(@meaning exp1)(env, hkont, store)
# Assignment
meaningAssignment: (name, exp) ->
name = if name instanceof Symbol then name.name else name
console.log(name)
(env, kont, store) =>
hkont = (val, store1) ->
kont val, (extend store1, (env name), val)
(@meaning exp) env, hkont, store
# Abstraction (keeps a lambda)
meaningAbstraction: (names, exps) ->
(env, kont, store) =>
funcrep = (vals, kont1, store1) =>
if not (eq (length vals), (length names))
throw new LispInterpreterError("Incorrect Arity.")
argnamestostore = (store2, addrs) =>
(@meaningsSequence exps) (lextends env, names, addrs), kont1, (lextends store2, addrs, vals)
allocate store1, (length names), argnamestostore
kont (inValue funcrep), store
meaningVariable: (name) ->
(m) ->
(vals, env, kont, store) ->
allocate store, 1, (store, addrs) ->
addr = (car addrs)
m (cdr vals), (extend env, names, addr), kont, (extend store, addr, (car vals))
meaningApplication: (exp, exps) ->
(env, kont, store) =>
hkont = (func, store1) =>
kont2 = (values, store2) ->
(ValueToFunction func) values, kont, store2
(@meanings exps) env, kont2, store1
(@meaning exp) env, hkont, store
meanings: (exps) =>
meaningSomeArguments = (exp, exps) =>
(env, kont, store) =>
hkont = (value, store1) =>
hkont2 = (values, store2) ->
kont (cons value, values), store2
(@meanings exps) env, hkont2, store1
(@meaning exp) env, hkont, store
meaningNoArguments = ->
(env, kont, store) ->
kont (cons()), store
if pairp exps
meaningSomeArguments (car exps), (cdr exps)
else
meaningNoArguments()
definitial: (name, value) ->
allocate store_init, 1, (store, addrs) ->
env_init = extend env_init, name, (car addrs)
store_init = extend store, (car addrs), value
name
defprimitive: (name, value, arity) ->
callable = (values, kont, store) =>
if not eq arity, (length values)
throw new LispInterpreterError "Incorrect Arity for #{name}"
kont (value.apply(null, listToVector(values))), store
@definitial name, (inValue callable)
defarithmetic: (name, value, arity) ->
callable = (values, kont, store) ->
if not eq arity, (length values)
throw new LispInterpreterError "Incorrect Arity for #{name}"
kont (inValue (value.apply(null, listToVector(map values, ValueToNumber)))), store
@definitial name, (inValue callable)
module.exports = (ast, kont) ->
interpreter = new Interpreter()
store_current = store_init
(interpreter.meaning ast)(env_init,
((value, store_final) -> kont (convert value, store_final)), store_current)

170
chapter5/reader.coffee
View File

@ -1,170 +0,0 @@
{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
{inspect} = require "util"
{Comment, Symbol} = require "../chapter5/reader_types"
NEWLINES = ["\n", "\r", "\x0B", "\x0C"]
WHITESPACE = [" ", "\t"].concat(NEWLINES)
EOF = new (class Eof)()
EOO = new (class Eoo)()
class ReadError extends Error
name: 'LispInterpreterError'
constructor: (@message) ->
class Source
constructor: (@inStream) ->
@index = 0
@max = @inStream.length - 1
@line = 0
@column = 0
peek: -> @inStream[@index]
position: -> [@line, @column]
next: ->
c = @peek()
return EOF if @done()
@index++
[@line, @column] = if @peek() in NEWLINES then [@line + 1, 0] else [@line, @column + 1]
c
done: -> @index > @max
# IO -> IO
skipWS = (inStream) ->
while inStream.peek() in WHITESPACE then inStream.next()
readMaybeNumber = (symbol) ->
if symbol[0] == '+'
return readMaybeNumber symbol.substr(1)
if symbol[0] == '-'
ret = readMaybeNumber symbol.substr(1)
return if ret? then -1 * ret else undefined
if symbol.search(/^0x[0-9a-fA-F]+$/) > -1
return parseInt(symbol, 16)
if symbol.search(/^0[0-9a-fA-F]+$/) > -1
return parseInt(symbol, 8)
if symbol.search(/^[0-9]+$/) > -1
return parseInt(symbol, 10)
if symbol.search(/^nil$/) > -1
return nil
undefined
# (Delim, TypeName) -> IO -> (IO, Node) | Errorfor
makeReadPair = (delim, type) ->
# IO -> (IO, Node) | Error
(inStream) ->
inStream.next()
skipWS inStream
if inStream.peek() == delim
inStream.next() unless inStream.done()
return if type then cons((new Symbol type), nil) else nil
# IO -> (IO, Node) | Error
dotted = false
readEachPair = (inStream) =>
obj = @read inStream, true, null, true
if inStream.peek() == delim
if dotted then return obj
return cons obj, nil
return obj if obj instanceof ReadError
if inStream.done() then return new ReadError "Unexpected end of input"
if dotted then return new ReadError "More than one symbol after dot in list"
if @acc(obj) instanceof Symbol and @acc(obj).name == '.'
dotted = true
return readEachPair inStream
cons obj, readEachPair inStream
obj = readEachPair(inStream)
inStream.next()
if type then cons((new Symbol type), obj) else obj
# Type -> IO -> IO, Node
class Reader
prefixReader = (type) ->
# IO -> IO, Node
(inStream) ->
inStream.next()
obj = @read inStream, true, null, true
return obj if obj instanceof ReadError
list((new Symbol type), obj)
"acc": (obj) -> obj
"symbol": (inStream) ->
symbol = (until (inStream.done() or @[inStream.peek()]? or inStream.peek() in WHITESPACE)
inStream.next()).join ''
number = readMaybeNumber symbol
if number?
return number
new Symbol symbol
"read": (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, keepComments = false) ->
inStream = if inStream instanceof Source then inStream else new Source inStream
c = inStream.peek()
# (IO, Char) -> (IO, Node) | Error
matcher = (inStream, c) =>
if inStream.done()
return if recursiveP then (new ReadError 'EOF while processing nested object') else nil
if c in WHITESPACE
inStream.next()
return nil
if c == ';'
return readComment(inStream)
ret = if @[c]? then @[c](inStream) else @symbol(inStream)
skipWS inStream
ret
while true
form = matcher inStream, c
skip = (not nilp form) and (form instanceof Comment) and not keepComments
break if (not skip and not nilp form) or inStream.done()
c = inStream.peek()
null
form
'(': makeReadPair ')', null
'[': makeReadPair ']', 'vector'
'{': makeReadPair('}', 'record', (res) ->
res.length % 2 == 0 and true or mkerr "record key without value")
'"': (inStream) ->
inStream.next()
s = until inStream.peek() == '"' or inStream.done()
if inStream.peek() == '\\'
inStream.next()
inStream.next()
return (new ReadError "end of file seen before end of string") if inStream.done()
inStream.next()
s.join ''
')': (inStream) -> new ReadError "Closing paren encountered"
']': (inStream) -> new ReadError "Closing bracket encountered"
'}': (inStream) -> new ReadError "Closing curly without corresponding opening."
"`": prefixReader 'back-quote'
"'": prefixReader 'quote'
",": prefixReader 'unquote'
";": (inStream) ->
r = (while inStream.peek() != "\n" and not inStream.done()
inStream.next()).join("")
inStream.next() if not inStream.done()
new Comment r
exports.Source = Source
exports.ReadError = ReadError
exports.Reader = Reader
reader = new Reader()
exports.read = -> reader.read.apply(reader, arguments)

39
chapter5/reader_rawtoform.coffee
View File

@ -1,39 +0,0 @@
{car, cdr, cons, listp, nilp, nil,
list, pairp, listToString} = require 'cons-lists/lists'
{Symbol, Comment} = require './reader_types'
class Normalize
normalize: (form) ->
return nil if nilp form
if (pairp form)
if (car form) instanceof Symbol and (car form).name in ['vector', 'record']
@[(car form).name](cdr form)
else
@list form
else
form
list: (form) ->
handle = (form) =>
return nil if nilp form
if not pairp form
return @normalize form
cons (@normalize car form), (handle cdr form)
handle form
vector: (form) ->
until (nilp form) then p = @normalize(car form); form = cdr form; p
record: (form) ->
o = Object.create(null)
until (nilp form)
o[(@normalize car form)] = (@normalize car cdr form)
form = cdr cdr form
null
o
exports.Normalize = Normalize
normalize = new Normalize()
exports.normalize = -> normalize.normalize.apply(normalize, arguments)

14
chapter5/reader_tracktoform.coffee
View File

@ -1,14 +0,0 @@
{Node} = require './reader_types'
{Normalize} = require './reader_rawtoform'
liftToNode = (f) ->
(form) ->
return f.call this, (if (form instanceof Node) then form.v else form)
NodeNormalize = class
for own key, func of Normalize::
NodeNormalize::[key] = liftToNode(func)
exports.Normalize = NodeNormalize
normalize = new NodeNormalize()
exports.normalize = -> normalize.normalize.apply(normalize, arguments)

11
chapter5/reader_types.coffee
View File

@ -1,11 +0,0 @@
exports.Node = class
constructor: (@v, @line, @column) ->
exports.Symbol = class
constructor: (@name) ->
exports.Comment = class
constructor: (@text) ->

25
chapter5/tracking_reader.coffee
View File

@ -1,25 +0,0 @@
{Reader, ReadError, Source} = require './reader'
{Node} = require './reader_types'
liftToTrack = (f) ->
(ioStream) ->
ioStream = if ioStream instanceof Source then ioStream else new Source ioStream
[line, column] = ioStream.position()
obj = f.apply(this, arguments)
if obj instanceof ReadError
obj['line'] = line
obj['column'] = column
return obj
if obj instanceof Node then obj else new Node obj, line, column
TrackingReader = class
for own key, func of Reader::
TrackingReader::[key] = liftToTrack(func)
TrackingReader::acc = (obj) -> obj.v
exports.ReadError = ReadError
exports.Reader = TrackingReader
exports.reader = reader = new TrackingReader()
exports.read = -> reader.read.apply(reader, arguments)

129
coffeelint.json
View File

@ -1,129 +0,0 @@
{
"arrow_spacing": {
"level": "ignore"
},
"braces_spacing": {
"level": "ignore",
"spaces": 0,
"empty_object_spaces": 0
},
"camel_case_classes": {
"level": "error"
},
"coffeescript_error": {
"level": "error"
},
"colon_assignment_spacing": {
"level": "ignore",
"spacing": {
"left": 0,
"right": 0
}
},
"cyclomatic_complexity": {
"value": 10,
"level": "ignore"
},
"duplicate_key": {
"level": "error"
},
"empty_constructor_needs_parens": {
"level": "ignore"
},
"ensure_comprehensions": {
"level": "warn"
},
"eol_last": {
"level": "ignore"
},
"indentation": {
"value": 2,
"level": "error"
},
"line_endings": {
"level": "ignore",
"value": "unix"
},
"max_line_length": {
"value": 120,
"level": "error",
"limitComments": true
},
"missing_fat_arrows": {
"level": "ignore",
"is_strict": false
},
"newlines_after_classes": {
"value": 3,
"level": "ignore"
},
"no_backticks": {
"level": "error"
},
"no_debugger": {
"level": "warn",
"console": false
},
"no_empty_functions": {
"level": "ignore"
},
"no_empty_param_list": {
"level": "ignore"
},
"no_implicit_braces": {
"level": "ignore",
"strict": true
},
"no_implicit_parens": {
"strict": true,
"level": "ignore"
},
"no_interpolation_in_single_quotes": {
"level": "ignore"
},
"no_plusplus": {
"level": "ignore"
},
"no_stand_alone_at": {
"level": "ignore"
},
"no_tabs": {
"level": "error"
},
"no_this": {
"level": "ignore"
},
"no_throwing_strings": {
"level": "error"
},
"no_trailing_semicolons": {
"level": "error"
},
"no_trailing_whitespace": {
"level": "error",
"allowed_in_comments": false,
"allowed_in_empty_lines": true
},
"no_unnecessary_double_quotes": {
"level": "ignore"
},
"no_unnecessary_fat_arrows": {
"level": "warn"
},
"non_empty_constructor_needs_parens": {
"level": "ignore"
},
"prefer_english_operator": {
"level": "ignore",
"doubleNotLevel": "ignore"
},
"space_operators": {
"level": "ignore"
},
"spacing_after_comma": {
"level": "ignore"
},
"transform_messes_up_line_numbers": {
"level": "warn"
}
}

67
docs/20150607.md
View File

@ -1,67 +0,0 @@
I've been working my way through a Lisp textbook, *Lisp In Small
Pieces*, by Christian Quinnec. It was originally written in French and
is not that well known among English-speaking Lisperati, not in
comparison to the Wizard book or Paul Graham's *On Lisp*, but what
caught my attention was how it really was in *small* pieces. Each
chapter ended with an interpreter described, sometimes in code,
sometimes in text; if you were smart enough, you could actually piece
the whole thing together and see how it worked.
I decided to make things hard for myself. Since I'm *not* a Lisperati
(although I may well and truly be seduced by Hy), I decided to make
things hard for myself by writing the interpreter in Coffeescript. Most
Lisp books assume you have a Lisp handy, and Quinnec's examples are fine
and dandy on many variants of Scheme, but for a fun time I decided to
write it in something else. Raganwald claims Javascript "is a Lisp,"
and if that's so it ought to be good enough to write a Lisp in it.
I mean, it's obviously been done before. I tried once before but got
lost. *LiSP* does me the favor of keeping me on track.
You can see all my sourcecode at <a
href="https://github.com/elfsternberg/LispInSmallPieces">Github: Lisp In
Small Pieces</a>.
Chapter 1 contains the base interpreter. It also contains a
hand-written Lisp reader, and refers to another project I have on
GitHub, <a
href="https://github.com/elfsternberg/cons-lists">cons-lists</a>, which
is exactly what it sounds like, a singly-linked list implementation in
Javascript, using nested Javascript arrays as the base. The base
interpreter is very primitive-- you can't even create new variable names
in the global namespace! Although you can shadow them using lambdas, so
it's pretty much bog standard Lambda Calculus.
Chapter "Lambda 1" contains a continuation-passing variant of the
interpreter from Chapter 1. It's basically a facile reading of
Lisperator's λ-language intepreter, with my own parser front-end and
some CPS style. It passes all the tests, but it's a distraction.
Chapter 3 contains the same interpreter, only using the architecture
Quinnec describes in Chapter 3 of his book.
Chapter 2 describes a number of different methodologies for binding,
scoping, and namespaces. The material is interesting but I didn't
pursue writing the various interpreters. I "got" what Quinnec was
saying, and if I'm ever interested in writing something with scoping
rules outside of the lexical scopes with which I'm familiar, I might
revisit the material.
The next step will be to add functions to the Chapter 3 interpreter to
do the various continuation management games, like call/cc, throw/catch,
$and so forth. Because *those*, I feel I need to understand.
How far will I take this project? I’m not sure. Chapter 4 is
"Assignment and Side Effects," so I’ll do that. Chapter 5 is theory,
and 6 implementation, of a "fast interpreter" of the kind French
programming language guys apparently love to study. I’ll read them, but
I’m not sure what code I’ll generate out of that. Chapter 7,
"Compilation," is interesting in that he starts by defining a VM that on
top of which our bytecode will run, and implement both the VM and the
compiler in Scheme. I think I want to do that chapter, and then
re-write the compiler to create LLVM-compatible code instead, just to
learn LLVM. Chapter 8 implements EVAL, chapter 9 has Macros, and
chapter 10 has Object-Oriented Lisp. So I’ll probably do those as well.
And then... we’ll see. I surprised myself by doing Chapter 3 in less
than two weeks.

12
docs/new.md
View File

@ -1,12 +0,0 @@
This doesn't really look like the read/analyze/compile passes that one
expects of a modern Lisp.
Reading converts the source code into a list of immutable values in the
low-level AST of the system. Reading and analysis must be combined if
there are to be reader macros (which I want to support).
... and then a miracle occurs ...
Compilation is the process of turning the AST into javascript.

57
extras/jenkins_config.xml
View File

@ -1,57 +0,0 @@
<?xml version='1.0' encoding='UTF-8'?>
<project>
<actions/>
<description>Building in the chapters of Lisp In Small Pieces.</description>
<logRotator class="hudson.tasks.LogRotator">
<daysToKeep>-1</daysToKeep>
<numToKeep>10</numToKeep>
<artifactDaysToKeep>-1</artifactDaysToKeep>
<artifactNumToKeep>-1</artifactNumToKeep>
</logRotator>
<keepDependencies>false</keepDependencies>
<properties/>
<scm class="hudson.plugins.git.GitSCM" plugin="git@2.3.4">
<configVersion>2</configVersion>
<userRemoteConfigs>
<hudson.plugins.git.UserRemoteConfig>
<url>file:///home/elf/Projects/LispInSmallPieces</url>
</hudson.plugins.git.UserRemoteConfig>
</userRemoteConfigs>
<branches>
<hudson.plugins.git.BranchSpec>
<name>*/master</name>
</hudson.plugins.git.BranchSpec>
</branches>
<doGenerateSubmoduleConfigurations>false</doGenerateSubmoduleConfigurations>
<submoduleCfg class="list"/>
<extensions/>
</scm>
<canRoam>true</canRoam>
<disabled>false</disabled>
<blockBuildWhenDownstreamBuilding>false</blockBuildWhenDownstreamBuilding>
<blockBuildWhenUpstreamBuilding>false</blockBuildWhenUpstreamBuilding>
<triggers>
<org.jenkinsci.plugins.fstrigger.triggers.FolderContentTrigger plugin="fstrigger@0.39">
<spec></spec>
<path>file:///home/elf/Projects/LispInSmallPieces</path>
<excludeCheckLastModificationDate>false</excludeCheckLastModificationDate>
<excludeCheckContent>false</excludeCheckContent>
<excludeCheckFewerOrMoreFiles>false</excludeCheckFewerOrMoreFiles>
</org.jenkinsci.plugins.fstrigger.triggers.FolderContentTrigger>
</triggers>
<concurrentBuild>false</concurrentBuild>
<builders>
<hudson.tasks.Shell>
<command>make node_modules test</command>
</hudson.tasks.Shell>
</builders>
<publishers>
<hudson.tasks.junit.JUnitResultArchiver plugin="junit@1.2-beta-4">
<testResults>test-reports.xml</testResults>
<keepLongStdio>false</keepLongStdio>
<testDataPublishers/>
<healthScaleFactor>1.0</healthScaleFactor>
</hudson.tasks.junit.JUnitResultArchiver>
</publishers>
<buildWrappers/>
</project>

14
package.json
View File

@ -1,5 +1,5 @@
{
"name": "LispInSmallPieces",
"name": "CoffeeLisp",
"version": "0.0.1",
"description": "A Coffeescript rendition of Lisp In Small Pieces",
"main": "bin/lisp",
@ -8,21 +8,13 @@
"cons-lists": "git+https://github.com/elfsternberg/cons-lists.git"
},
"devDependencies": {
"coffeelint": "~1.10.0",
"chai": "^2.0.0",
"mocha": "^2.1.0",
"mocha-jenkins-reporter": "^0.1.7"
"mocha": "^2.1.0"
},
"scripts": {
"test": "make test",
"build": "make node_modules"
},
"repository": {
"type": "git",
"url": "ssh://elfsternberg@elfsternberg.com/home/elfsternberg/repos/LispInSmallPieces"
"test": "echo \"Error: no test specified\" && exit 1"
},
"keywords": [
"lisp",
"scheme",
"practice",
"interpreter",

192
racket/chap1.rkt Normal file
View File

@ -0,0 +1,192 @@
; Lisp In Small Pieces, chapter 1 Simple Lambda Calculus interpreter
; with global environment, simple lexical closures enforced by singly
; linked lists.
; This covers only severals exercise: I added 'exit as an exit value;
; I fixed the definition of '<', and then applied the exercise out of
; the book.
; Any of the exercises that needed call/cc I've avoided for the simple
; reason that I started this to learn lisp, I'm a raw beginner, and
; call/cc is definitely advance estorics.
; Needed for 'wrong-syntax', which is Racket's version of the "wrong"
; exception tosser.
(require racket/syntax)
; LISP requires a mutatable environment, so using mcons/mpair for
; that.
(require scheme/mpair)
; Weird; racket needs this as a patch. I would have expected it as
; present in the default list of functions!
(define (atom? x)
(and (not (null? x))
(not (pair? x))))
(define env_init '())
(define env_global env_init)
; So, this macro places *into the current scope* (i.e. no building of
; a new scope that gets reaped upon exit) the names of variables and
; potential initial values.
(define-syntax definitial
(syntax-rules ()
((definitial name)
(begin (set! env_global (mcons (mcons 'name 'void) env_global)) 'name))
((definitial name value)
(begin (set! env_global (mcons (mcons 'name value) env_global)) 'name))))
; Oh! This macro (same scope thing again) associates named things with
; values in the target environment (the host language), along with
; arity checking. (which it doesn't do for 'if', for example)
(define-syntax defprimitive
(syntax-rules ()
((defprimitive name value arity)
(definitial name
(lambda (values)
(if (= arity (length values))
(apply value values)
(wrong-syntax #'here "Incorrect arity ~s" (list 'name values))))))))
; Sometimes, you do have to define something before you use it. Lesson
; learned.
(define the-false-value (cons "false" "boolean"))
(definitial t #t)
(definitial f the-false-value)
(definitial nil '())
(definitial foo)
(definitial bar)
(definitial fib)
(definitial fact)
(define-syntax defpredicate
(syntax-rules ()
((_ name native arity)
(defprimitive name (lambda args (or (apply native args) the-false-value)) arity))))
(defprimitive cons cons 2)
(defprimitive car car 1)
(defprimitive set-cdr! set-mcdr! 2)
(defprimitive + + 2)
(defprimitive - - 2)
(defprimitive * * 2)
(defpredicate lt < 2)
(defpredicate eq? eq? 2)
; This function extends the environment so that *at this moment of
; extension* the conslist head points to the old environment, then
; when it's done it points to the new environment. What's interesting
; is that the conslist head points to the last object initialized, not
; the first.
(define (extend env variables values)
(cond ((pair? variables)
(if (pair? values)
(mcons (mcons (car variables) (car values))
(extend env (cdr variables) (cdr values)))
(wrong-syntax #'here "Too few values")))
((null? variables)
(if (null? values)
env
(wrong-syntax #'here "Too many values")))
((symbol? variables) (mcons (mcons variables values) env))))
; Already we're starting to get some scope here. Note that
; make-function provides the environment, not the invoke. This makes
; this a lexically scoped interpreter.
(define (make-function variables body env)
(lambda (values)
(eprogn body (extend env variables values))))
; if it's a function, invoke it. Wow. Much complex. Very interpret.
(define (invoke fn args)
(if (procedure? fn)
(fn args)
(wrong-syntax #'here "Not an function ~s" fn)))
; Iterate through the exps, return the value of the last one.
(define (eprogn exps env)
(if (pair? exps)
(if (pair? (cdr exps))
(begin (evaluate (car exps) env)
(eprogn (cdr exps) env))
(evaluate (car exps) env))
'()))
; Iterate through the exps, return a list of the values of the
; evaluated expressions
(define (evlis exps env)
(if (pair? exps)
(cons (evaluate (car exps) env)
(evlis (cdr exps) env))
'()))
; silly patch because of the mutatable lists
(define-syntax mcaar (syntax-rules () ((_ e) (mcar (mcar e)))))
(define-syntax mcdar (syntax-rules () ((_ e) (mcdr (mcar e)))))
; Iterate through the environment, find an ID, return its associated
; value.
(define (lookup id env)
(if (mpair? env)
(if (eq? (mcaar env) id)
(mcdar env)
(lookup id (mcdr env)))
(wrong-syntax #'here "No such binding ~s" id)))
; Iterate through the environment, find an ID, and change its value to
; the new value. Again, purely global environment. Really starting
; to grok how the environment "stack" empowers modern runtimes.
(define (update! id env value)
(if (mpair? env)
(if (eq? (mcaar env) id)
(begin (set-mcdr! (mcar env) value) value)
(update! id (mcdr env) value))
(wrong-syntax #'here "No such binding ~s" id)))
; Core evaluation rules.
(define (evaluate exp env)
(if (atom? exp)
(cond
((symbol? exp) (lookup exp env))
((or (number? exp) (string? exp) (char? exp) (boolean? exp) (vector? exp)) exp)
(else (wrong-syntax #'here "Cannot evaluate")))
(case (car exp)
((quote) (cadr exp))
; Note: No checks that the statement even vaguely resembles the rules.
((if) (if (not (eq? (evaluate (cadr exp) env) the-false-value))
(evaluate (caddr exp) env)
(evaluate (cadddr exp) env)))
((begin) (eprogn (cdr exp) env))
((set!) (update! (cadr exp) env (evaluate (caddr exp) env)))
((lambda) (make-function (cadr exp) (cddr exp) env))
(else (invoke (evaluate (car exp) env) (evlis (cdr exp) env))))))
; Run it. Note that the function toplevel is self-referential.
(define (chapter1-scheme)
(define (toplevel)
(let ((result (evaluate (read) env_global)))
(if (not (eq? result 'exit))
(begin (display result) (toplevel))
#f)))
(toplevel))
; (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1))))))

10
racket/chap3.rkt Normal file
View File

@ -0,0 +1,10 @@
(define (find-symbol id tree)
(call/cc
(lambda (exit)
(define (find tree)
(if (pair? tree)
(or (find (car tree)) (find (cdr tree)))
(if (eq? tree id) (exit #t) #f)))
(find tree))))

17
src/eval.coffee Normal file
View File

@ -0,0 +1,17 @@
lookup = require './lookup'
{car, cdr, cadr, caadr, cdadr} = require './lists'
lispeval = (element, scope) ->
switch (car element)
when 'number' then parseInt (cadr element), 10
when 'string' then (cadr element)
when 'symbol' then lookup scope, (cadr element)
when 'list'
proc = lispeval (caadr element), scope
args = cdadr element
proc args, scope
else throw new Error ("Unrecognized type in parse: #{(car element)}")
module.exports = lispeval

43
src/fn.coffee Normal file
View File

@ -0,0 +1,43 @@
lispeval = require './eval'
{cons, nil, nilp, car, cdr, listToVector} = require './lists'
module.exports =
create_vm_expression_evaluator: (defining_scope, params, body) ->
(cells, scope) ->
args = (amap = (cells, accum) ->
return accum if nilp cells
amap((cdr cells), accum.concat(lispeval (car cells), scope)))(cells, [])
body.apply null, args
create_lisp_expression_evaluator: (defining_scope, params, body) ->
(cells, scope) ->
# Takes the current scope, which has been passed in during the
# execution phase, and evaluate the contents of the parameters
# in the context in which this call is made (i.e. when the
# function is *called*, rather than defined.
new_scope = (cmap = (cells, params, nscope) ->
return nscope if (nilp cells) or (nilp params)
nscope[(car params)] = lispeval (car cells), scope
cmap((cdr cells), (cdr params), nscope))(cells, params, {})
# Execute and evaluate the body, creating an inner scope that
# consists of: (1) the bound variables (the parameters)
# evaluated in the context of the function call, because that's
# where they were encountered (2) the free variables evaluated
# in the context of the defining scope, because that's where
# *they* were encountered.
#
# While this inspiration comes from Coglan, the clearest
# explanation is from Lisperator's 'make_lambda' paragraph at
# http://lisperator.net/pltut/eval1/
inner_scope = cons(new_scope, defining_scope)
(nval = (body, memo) ->
return memo if nilp body
nval((cdr body), lispeval((car body), inner_scope)))(body)
create_special_form_evaluator: (defining_scope, params, body) ->
(cells, scope) -> body(cells, scope)

0
chapter1/lisp.coffee → src/lisp.coffee
View File

152
src/lisp_ch1.coffee Normal file
View File

@ -0,0 +1,152 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
readline = require "readline"
{inspect} = require "util"
print = require "./print"
env_init = nil
env_global = env_init
ntype = (node) -> car node
nvalu = (node) -> cadr node
definitial = (name, value = nil) ->
env_global = (cons (cons name, value), env_global)
name
defprimitive = (name, nativ, arity) ->
definitial name, ((args) ->
vmargs = listToVector(args)
if (vmargs.length == arity)
nativ.apply null, vmargs
else
throw "Incorrect arity")
the_false_value = (cons "false", "boolean")
definitial "#t", true
definitial "#f", the_false_value
definitial "nil", nil
definitial "foo"
definitial "bar"
definitial "fib"
definitial "fact"
defpredicate = (name, nativ, arity) ->
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
defprimitive "cons", cons, 2
defprimitive "car", car, 2
defprimitive "set-cdr!", setcdr, 2
defprimitive "+", ((a, b) -> a + b), 2
defprimitive "*", ((a, b) -> a * b), 2
defprimitive "-", ((a, b) -> a - b), 2
defprimitive "/", ((a, b) -> a / b), 2
defpredicate "lt", ((a, b) -> a < b), 2
defpredicate "eq?", ((a, b) -> a == b), 2
extend = (env, variables, values) ->
if (pairp variables)
if (pairp values)
(cons (cons (car variables), (car values)),
(extend env, (cdr variables), (cdr values)))
else
throw "Too few values"
else if (nilp variables)
if (nilp values) then env else throw "Too many values"
else
if (symbolp variables)
(cons (cons variables, values), env)
else
nil
make_function = (variables, body, env) ->
(values) -> eprogn body, (extend env, variables, values)
invoke = (fn, args) ->
(fn args)
# Takes a list of nodes and calls evaluate on each one, returning the
# last one as the value of the total expression. In this example, we
# are hard-coding what ought to be a macro, namely the threading
# macros, "->"
eprogn = (exps, env) ->
if (pairp exps)
if pairp (cdr exps)
evaluate (car exps), env
eprogn (cdr exps), env
else
evaluate (car exps), env
else
nil
evlis = (exps, env) ->
if (pairp exps)
(cons (evaluate (car exps), env), (evlis (cdr exps), env))
else
nil
lookup = (id, env) ->
if (pairp env)
if (caar env) == id
cdar env
else
lookup id, (cdr env)
else
nil
update = (id, env, value) ->
if (pairp env)
if (caar env) == id
setcdr value, (car env)
value
else
update id, (cdr env), value
else
nil
# This really ought to be the only place where the AST meets the
# interpreter core. I can't help but think that this design precludes
# pluggable interpreter core.
astSymbolsToLispSymbols = (node) ->
return nil if nilp node
throw "Not a list of variable names" if not (ntype(node) is 'list')
handler = (node) ->
return nil if nilp node
cons (nvalu car node), (handler cdr node)
handler(nvalu node)
# Takes an AST node and evaluates it and its contents. A node may be
# ("list" (... contents ...)) or ("number" 42) or ("symbol" x), etc.
cadddr = metacadr('cadddr')
evaluate = (e, env) ->
[type, exp] = [(ntype e), (nvalu e)]
if type == "symbol"
return lookup exp, env
else if type in ["number", "string", "boolean", "vector"]
return exp
else if type == "list"
head = car exp
if (ntype head) == 'symbol'
switch (nvalu head)
when "quote" then cdr exp
when "if"
unless (evaluate (cadr exp), env) == the_false_value
evaluate (caddr exp), env
else
evaluate (cadddr exp), env
when "begin" then eprogn (cdr exp), env
when "set!" then update (nvalu cadr exp), env, (evaluate (caddr exp), env)
when "lambda" then make_function (astSymbolsToLispSymbols cadr exp), (cddr exp), env
else invoke (evaluate (car exp), env), (evlis (cdr exp), env)
else
invoke (evaluate (car exp), env), (evlis (cdr exp), env)
else
throw new Error("Can't handle a #{type}")
module.exports = (c) -> evaluate c, env_global

0
chapter1/lookup.coffee → src/lookup.coffee
View File

21
src/print.coffee Normal file
View File

@ -0,0 +1,21 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
ntype = (node) -> car node
nvalu = (node) -> cadr node
evlis = (exps, d) ->
if (pairp exps) then evaluate((car exps), d) + " " + evlis((cdr exps), d) else ""
indent = (d) ->
([0..d].map () -> " ").join('')
evaluate = (e, d = 0) ->
[type, exp] = [(ntype e), (nvalu e)]
if type == "symbol" then exp
else if type in ["number", "boolean"] then exp
else if type == "string" then '"' + exp + '"'
else if type == "list" then "\n" + indent(d) + "(" + evlis(exp, d + 2) + ")"
else throw "Don't recognize a #{type}"
module.exports = (c) -> evaluate c, 0

71
chapter1/reader.coffee → src/reader.coffee
View File

@ -1,12 +1,10 @@
{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
{inspect} = require "util"
{Node, Comment} = require "./reader_types"
{car, cdr, cons, nil, nilp, pairp, vectorToList} = require 'cons-lists/lists'
NEWLINES = ["\n", "\r", "\x0B", "\x0C"]
WHITESPACE = [" ", "\t"].concat(NEWLINES)
EOF = new (class Eof)()
EOO = new (class Eoo)()
EOF = new (class)
EOO = new (class)
class Source
constructor: (@inStream) ->
@ -32,9 +30,13 @@ class Source
skipWS = (inStream) ->
while inStream.peek() in WHITESPACE then inStream.next()
# (type, value, line, column) -> (node {type, value, line, column)}
makeObj = (type, value, line, column) ->
cons(type, cons(value, cons(line, cons(column, nil))))
# msg -> (IO -> Node => Error)
handleError = (message) ->
(line, column) -> new Node('error', message, line, column)
(line, column) -> makeObj('error', message, line, column)
# IO -> Node => Comment
readComment = (inStream) ->
@ -43,7 +45,7 @@ readComment = (inStream) ->
inStream.next()).join("")
if not inStream.done()
inStream.next()
new Node 'comment', (new Comment r), line, column
makeObj 'comment', r, line, column
# IO -> (Node => Literal => String) | Error
readString = (inStream) ->
@ -56,7 +58,7 @@ readString = (inStream) ->
if inStream.done()
return handleError("end of file seen before end of string.")(line, column)
inStream.next()
new Node 'string', (string.join ''), line, column
makeObj 'string', (string.join ''), line, column
# (String) -> (Node => Literal => Number) | Nothing
readMaybeNumber = (symbol) ->
@ -82,8 +84,8 @@ readSymbol = (inStream, tableKeys) ->
inStream.next()).join ''
number = readMaybeNumber symbol
if number?
return new Node 'number', number, line, column
new Node 'symbol', symbol, line, column
return makeObj 'number', number, line, column
makeObj 'symbol', symbol, line, column
# (Delim, TypeName) -> IO -> (IO, node) | Error
@ -95,25 +97,18 @@ makeReadPair = (delim, type) ->
[line, column] = inStream.position()
if inStream.peek() == delim
inStream.next()
return new Node type, nil, line, column
return makeObj(type, nil, line, column)
# IO -> (IO, Node) | Error
dotted = false
readEachPair = (inStream) ->
[line, column] = inStream.position()
obj = read inStream, true, null, true
if inStream.peek() == delim
if dotted then return obj
return cons obj, nil
if inStream.peek() == delim then return cons obj, nil
if inStream.done() then return handleError("Unexpected end of input")(line, column)
if dotted then return handleError("More than one symbol after dot")
return obj if obj.type == 'error'
if obj.type == 'symbol' and obj.value == '.'
dotted = true
return readEachPair inStream
cons obj, readEachPair inStream
return obj if (car obj) == 'error'
cons obj, readEachPair(inStream)
ret = new Node type, readEachPair(inStream), line, column
ret = makeObj type, readEachPair(inStream), line, column
inStream.next()
ret
@ -125,8 +120,8 @@ prefixReader = (type) ->
inStream.next()
[line1, column1] = inStream.position()
obj = read inStream, true, null, true
return obj if obj.type == 'error'
new Node "list", cons((new Node("symbol", type, line1, column1)), cons(obj)), line, column
return obj if (car obj) == 'error'
makeObj "list", cons((makeObj("symbol", type, line1, column1)), cons(obj)), line, column
# I really wanted to make anything more complex than a list (like an
# object or a vector) something handled by a read macro. Maybe in a
@ -139,7 +134,7 @@ readMacros =
'[': makeReadPair ']', 'vector'
']': handleError "Closing bracket encountered"
'{': makeReadPair('}', 'record', (res) ->
res.length % 2 == 0 and true or mkerr "record key without value")
res.length % 2 == 0 and true or mkerr "record key without value")
'}': handleError "Closing curly without corresponding opening."
"`": prefixReader 'back-quote'
"'": prefixReader 'quote'
@ -173,7 +168,7 @@ read = (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, inReadM
while true
form = matcher inStream, c
skip = (not nilp form) and (form.type == 'comment') and not keepComments
skip = (not nilp form) and (car form == 'comment') and not keepComments
break if (not skip and not nilp form) or inStream.done()
c = inStream.peek()
null
@ -184,21 +179,19 @@ read = (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, inReadM
# IO -> (Form* | Error)
readForms = (inStream) ->
inStream = if inStream instanceof Source then inStream else new Source inStream
return nil if inStream.done()
inStream = if inStream instanceof Source then inStream else new Source inStream
return nil if inStream.done()
# IO -> (FORM*, IO) | Error
[line, column] = inStream.position()
readEach = (inStream) ->
obj = read inStream, true, null, false
return nil if (nilp obj)
return obj if obj.type == 'error'
cons obj, readEach inStream
# IO -> (FORM*, IO) | Error
[line, column] = inStream.position()
readEach = (inStream) ->
obj = read inStream, true, null, false
return nil if (nilp obj)
return obj if (car obj) == 'error'
cons obj, readEach inStream
obj = readEach inStream
if obj.type == 'error' then obj else new Node "list", obj, line, column
obj = readEach inStream
if (car obj) == 'error' then obj else makeObj "list", obj, line, column
exports.read = read
exports.readForms = readForms
exports.Node = Node
exports.Symbol = Symbol

0
chapter1/reduce.coffee → src/reduce.coffee
View File

31
src/scope.coffee Normal file
View File

@ -0,0 +1,31 @@
lispeval = require './eval'
{cons, car, cdr, nilp, nil, cadar, cadr, caddr} = require './lists'
{create_lisp_expression_evaluator, create_vm_expression_evaluator, create_special_form_evaluator} = require './fn'
scope = cons
'+': create_vm_expression_evaluator scope, [], (a, b) -> a + b
'-': create_vm_expression_evaluator scope, [], (a, b) -> a - b
'*': create_vm_expression_evaluator scope, [], (a, b) -> a * b
'/': create_vm_expression_evaluator scope, [], (a, b) -> a / b
'==': create_vm_expression_evaluator scope, [], (a, b) -> a == b
'#t': true
'#f': false
'define': create_special_form_evaluator scope, [], (nodes, scope) ->
current = (car scope)
current[(cadar nodes)] = lispeval((cadr nodes), scope)
'lambda': create_special_form_evaluator scope, [], (nodes, scope) ->
param_nodes = cadar nodes
reducer = (l) ->
if (nilp l) then nil else cons (cadar l), reducer(cdr l)
param_names = reducer(param_nodes)
create_lisp_expression_evaluator scope, param_names, (cdr nodes)
'if': create_special_form_evaluator scope, [], (nodes, scope) ->
if lispeval (car nodes), scope
lispeval (cadr nodes), scope
else
lispeval (caddr nodes), scope
module.exports = scope

13
src/test_chap1.coffee Normal file
View File

@ -0,0 +1,13 @@
lisp = require './lisp_ch1'
{read, readForms} = require './reader'
{inspect} = require 'util'
ast = read("(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))")
# ast = read("(begin (if (lt 4 2) (+ 4 1) (+ 2 1)))")
# ast = read("(begin (set! fact 4) fact)")
# ast = read("(begin ((lambda (t) (if (lt t 2) (+ 4 1) (+ 2 1))) 1))")
# ast = read("(begin (set! fact (lambda (x) (+ x x))) (fact 5))")
# ast = read("(begin (set! fact (lambda (x) (- x 4))) (fact 5))")
console.log "Result:", (lisp ast)

25
test/reader5_samples.coffee
View File

@ -1,25 +0,0 @@
{cons, nil} = require "cons-lists/lists"
exports.samples = [
['nil', nil]
['0', 0]
['1', 1]
['500', 500]
['0xdeadbeef', 3735928559]
['"Foo"', 'Foo']
['(1)', cons(1)]
['(1 2)', cons(1, (cons 2))]
['(1 2 )', cons(1, (cons 2))]
['( 1 2 )', cons(1, (cons 2))]
['(1 (2 3) 4)', cons(1, cons(cons(2, cons(3)), cons(4)))]
['( 1 2 )', cons(1, (cons 2))]
['("a" "b")', cons("a", (cons "b"))]
['("a" . "b")', cons("a", "b")]
['[]', []]
['{}', {}]
['{"a" [1 2 3] "b" {"c" "d"} "c" ("a" "b" . "c")}', {"a": [1,2,3], "b":{"c": "d"}, "c": cons("a", cons("b", "c"))}]
['[1 2 3]', [1, 2, 3]]
['[1 2 [3 4] 5]', [1, 2, [3, 4], 5]]
# ['(1 2 3', 'error']
['{"foo" "bar"}', {foo: "bar"}]
]

54
test/test_chapter-lambda-1.coffee
View File

@ -1,54 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons} = require "cons-lists/lists"
olisp = require '../chapter-lambda-1/interpreter'
{read, readForms} = require '../chapter1/reader'
the_false_value = (cons "false", "boolean")
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
describe "Core interpreter #3", ->
it "Should handle true statements", ->
expect(lisp read "(begin (if (lt 0 1) #t #f))").to.equal(true)
it "Should handle false statements", ->
expect(lisp read "(begin (if (lt 1 0) #t #f))").to.deep.equal(the_false_value)
it "Should handle return strings", ->
expect(lisp read '(begin (if (lt 0 1) "y" "n"))').to.equal("y")
it "Should handle return strings when false", ->
expect(lisp read '(begin (if (lt 1 0) "y" "n"))').to.equal("n")
it "Should handle equivalent objects that are not intrinsically truthy", ->
expect(lisp read '(begin (if (eq? "y" "y") "y" "n"))').to.equal("y")
it "Should handle inequivalent objects that are not intrinsically truthy", ->
expect(lisp read '(begin (if (eq? "y" "x") "y" "n"))').to.equal("n")
it "Should handle basic arithmetic", ->
expect(lisp read '(begin (+ 5 5))').to.equal(10)
expect(lisp read '(begin (* 5 5))').to.equal(25)
expect(lisp read '(begin (/ 5 5))').to.equal(1)
expect(lisp read '(begin (- 9 5))').to.equal(4)
it "Should handle some algebra", ->
expect(lisp read '(begin (* (+ 5 5) (* 2 3)))').to.equal(60)
it "Should handle a basic setting", ->
expect(lisp read '(begin (set! fact 4) fact)').to.equal(4)
it "Should handle a zero arity thunk", ->
expect(lisp read '(begin (set! fact (lambda () (+ 5 5))) (fact))').to.equal(10)
it "Should handle a two arity thunk", ->
expect(lisp read '(begin (set! fact (lambda (a b) (+ a b))) (fact 4 6))').to.equal(10)
it "Should handle a recursive function", ->
expect(lisp read '(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))').to.equal(120)
it "Should handle an IIFE", ->
expect(lisp read '(begin ((lambda () (+ 5 5))))').to.equal(10)

48
test/test_chapter1.coffee
View File

@ -1,48 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons} = require "cons-lists/lists"
lisp = require '../chapter1/interpreter'
{read, readForms} = require '../chapter1/reader'
the_false_value = (cons "false", "boolean")
describe "Core interpreter #1", ->
it "Should handle true statements", ->
expect(lisp read "(begin (if (lt 0 1) #t #f))").to.equal(true)
it "Should handle false statements", ->
expect(lisp read "(begin (if (lt 1 0) #t #f))").to.deep.equal(the_false_value)
it "Should handle return strings", ->
expect(lisp read '(begin (if (lt 0 1) "y" "n"))').to.equal("y")
it "Should handle return strings when false", ->
expect(lisp read '(begin (if (lt 1 0) "y" "n"))').to.equal("n")
it "Should handle equivalent objects that are not intrinsically truthy", ->
expect(lisp read '(begin (if (eq? "y" "y") "y" "n"))').to.equal("y")
it "Should handle inequivalent objects that are not intrinsically truthy", ->
expect(lisp read '(begin (if (eq? "y" "x") "y" "n"))').to.equal("n")
it "Should handle basic arithmetic", ->
expect(lisp read '(begin (+ 5 5))').to.equal(10)
expect(lisp read '(begin (* 5 5))').to.equal(25)
expect(lisp read '(begin (/ 5 5))').to.equal(1)
expect(lisp read '(begin (- 9 5))').to.equal(4)
it "Should handle some algebra", ->
expect(lisp read '(begin (* (+ 5 5) (* 2 3)))').to.equal(60)
it "Should handle a basic setting", ->
expect(lisp read '(begin (set! fact 4) fact)').to.equal(4)
it "Should handle a zero arity thunk", ->
expect(lisp read '(begin (set! fact (lambda () (+ 5 5))) (fact))').to.equal(10)
it "Should handle a two arity thunk", ->
expect(lisp read '(begin (set! fact (lambda (a b) (+ a b))) (fact 4 6))').to.equal(10)
it "Should handle a recursive function", ->
expect(lisp read '(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))').to.equal(120)
it "Should handle an IIFE", ->
expect(lisp read '(begin ((lambda () (+ 5 5))))').to.equal(10)

96
test/test_chapter3-cont.coffee
View File

@ -1,96 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons} = require "cons-lists/lists"
olisp = require '../chapter3/interpreter'
{read, readForms} = require '../chapter1/reader'
the_false_value = (cons "false", "boolean")
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
describe "Core interpreter #3: Blocks", ->
it "Should handle simple blocks", ->
expect(lisp read "(block foo 33)").to.equal(33)
it "Should handle the last blocks", ->
expect(lisp read "(block foo 1 2 3)").to.equal(3)
it "Should handle expressive blocks", ->
expect(lisp read "(block foo (+ 5 5))").to.equal(10)
it "Should handle basic returns blocks", ->
expect(lisp read "(block foo (+ 1 (return-from foo 2)))").to.equal(2)
it "Should handle complex returns blocks", ->
code = "(block foo ((lambda (exit)(* 2 (block foo (* 3 (exit 5)) )) ) (lambda (x) (return-from foo x)) ) )"
expect(lisp read code).to.equal(5)
it "Expects an uninitialized return-from to fail", ->
expect(-> lisp read "(return-from foo 3)").to.throw("Unknown block label foo")
it "Expects to see an obsolete block when called late", ->
expect(-> lisp read "((block foo (lambda (x) (return-from foo x))) 3 )")
.to.throw("Obsolete continuation")
it "Expects to see an obsolete block when called late", ->
blocka = "((block a (* 2 (block b (return-from a (lambda (x) (return-from b x))))) )3 )"
expect(-> lisp read blocka).to.throw("Obsolete continuation")
it "Expects to see an obsolete block when called late", ->
blockb = "((block a (* 2 (block b (return-from a (lambda (x) (return-from a x))))) ) 3 )"
expect(-> lisp read blockb).to.throw("Obsolete continuation")
describe "Core interpreter #3: Try/Catch", ->
it "doesn't change a simple value", ->
expect(lisp read "(catch 'bar 1)").to.equal(1)
it "doesn't interfere with standard behavior", ->
expect(lisp read "(catch 'bar 1 2 3)").to.equal(3)
it "bails at the top level when no catch", ->
expect(-> lisp read "(throw 'bar 33)").to.throw("No associated catch")
it "catches the throws value", ->
expect(lisp read "(catch 'bar (throw 'bar 11))").to.equal(11)
it "catches before the evaluation happens", ->
expect(lisp read "(catch 'bar (* 2 (throw 'bar 5)))").to.equal(5)
it "unrolls through multiple layers of the stack", ->
expect(lisp read "((lambda (f) (catch 'bar (* 2 (f 5))) ) (lambda (x) (throw 'bar x)))").to.equal(5)
it "continues at the right location", ->
expect(lisp read "((lambda (f) (catch 'bar (* 2 (catch 'bar (* 3 (f 5))))) ) (lambda (x) (throw 'bar x)))").to.equal(10)
it "throw/catch happens with literalally catches", ->
expect(lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (throw 1 (throw 2 5)) )) )))").to.equal(105)
it "bails at top level when there aren't enough catches", ->
expect(-> lisp read "(catch 2 (* 7 (throw 1 (throw 2 3))))").to.throw("No associated catch")
#describe "Core interpreter #3: Unwind-Protect", ->
# it "protects the value correctly", ->
# expect(lisp read "(unwind-protect 1 2").to.equal(1)
# it "", ->
# expect(lisp read "((lambda (c) (unwind-protect 1 (set! c 2)) c ) 0 ").to.equal(2)
# it "", ->
# expect(lisp read "((lambda (c) (catch 111 (* 2 (unwind-protect (* 3 (throw 111 5)) (set! c 1) ))) ) 0 ").to.equal(5)
# it "", ->
# expect(lisp read "((lambda (c) (catch 111 (* 2 (unwind-protect (* 3 (throw 111 5)) (set! c 1) ))) c ) 0 ").to.equal(1)
# it "", ->
# expect(lisp read "((lambda (c) (block A (* 2 (unwind-protect (* 3 (return-from A 5)) (set! c 1) ))) ) 0 ").to.equal(5)
# it "", ->
# expect(lisp read "((lambda (c) (block A (* 2 (unwind-protect (* 3 (return-from A 5)) (set! c 1) ))) c ) 0 ").to.equal(1)
#
#
# describe "Core interpreter #3: Try/Catch with Throw as a function", ->
# contain = (fcall) ->
# return "(begin ((lambda () (begin (set! funcall (lambda (g . args) (apply g args))) #{fcall}))))"
#
# it "", ->
# expect(-> lisp read "(funcall throw 'bar 33").to.throw("bar")
# it "", ->
# expect(lisp read "(catch 'bar (funcall throw 'bar 11))").to.equal(11)
# it "", ->
# expect(lisp read "(catch 'bar (* 2 (funcall throw 'bar 5)))").to.equal(5)
# it "", ->in
# expect(lisp read "((lambda (f) (catch 'bar (* 2 (f 5))) ) (lambda (x) (funcall throw 'bar x))) ").to.equal(5)
# it "", ->
# expect(lisp read "((lambda (f) (catch 'bar (* 2 (catch 'bar (* 3 (f 5))))) ) (lambda (x) (funcall throw 'bar x)))) ").to.equal(10)
# it "", ->
# expect(lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (funcall throw 1 (funcall throw 2 5)) )) ))) ").to.equal(105)
# it "", ->
# expect(lisp read "(catch 2 (* 7 (funcall throw 1 (funcall throw 2 3))))").to.equal(3)
#
#
#
#

55
test/test_chapter3.coffee
View File

@ -1,55 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons} = require "cons-lists/lists"
olisp = require '../chapter3/interpreter'
{read, readForms} = require '../chapter1/reader'
the_false_value = (cons "false", "boolean")
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
describe "Core interpreter #3", ->
it "Should handle true statements", ->
expect(lisp read "(begin (if (lt 0 1) #t #f))").to.equal(true)
it "Should handle false statements", ->
expect(lisp read "(begin (if (lt 1 0) #t #f))").to.deep.equal(the_false_value)
it "Should handle return strings", ->
expect(lisp read '(begin (if (lt 0 1) "y" "n"))').to.equal("y")
it "Should handle return strings when false", ->
expect(lisp read '(begin (if (lt 1 0) "y" "n"))').to.equal("n")
it "Should handle equivalent objects that are not intrinsically truthy", ->
expect(lisp read '(begin (if (eq? "y" "y") "y" "n"))').to.equal("y")
it "Should handle inequivalent objects that are not intrinsically truthy", ->
expect(lisp read '(begin (if (eq? "y" "x") "y" "n"))').to.equal("n")
it "Should handle basic arithmetic", ->
expect(lisp read '(begin (+ 5 5))').to.equal(10)
expect(lisp read '(begin (* 5 5))').to.equal(25)
expect(lisp read '(begin (/ 5 5))').to.equal(1)
expect(lisp read '(begin (- 9 5))').to.equal(4)
it "Should handle some algebra", ->
expect(lisp read '(begin (* (+ 5 5) (* 2 3)))').to.equal(60)
it "Should handle a basic setting", ->
expect(lisp read '(begin (set! fact 4) fact)').to.equal(4)
it "Should handle a zero arity thunk", ->
expect(lisp read '(begin (set! fact (lambda () (+ 5 5))) (fact))').to.equal(10)
it "Should handle a two arity thunk", ->
expect(lisp read '(begin (set! fact (lambda (a b) (+ a b))) (fact 4 6))').to.equal(10)
it "Should handle a recursive function", ->
expect(lisp read '(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))').to.equal(120)
it "Should handle an IIFE", ->
expect(lisp read '(begin ((lambda () (+ 5 5))))').to.equal(10)

50
test/test_chapter3g.coffee
View File

@ -1,50 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons} = require "cons-lists/lists"
olisp = require '../chapter3g/interpreter'
{read, readForms} = require '../chapter1/reader'
the_false_value = (cons "false", "boolean")
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
describe "Core interpreter #3: Protect", ->
it "unwinds but returns the value of the form", ->
expect(lisp read "(protect 1 2").to.equal(1)
it "unwinds within an iffe to correctly evaluate the side-effect", ->
expect(lisp read "((lambda (c) (protect 1 (set! c 2)) c ) 0 ").to.equal(2)
it "Unwinds inside an unevaluated definition", ->
expect(lisp read "((lambda (c) (catch 111 (* 2 (protect (* 3 (throw 111 5)) (set! c 1) ))) ) 0)").to.equal(5)
it "Unwinds inside the evaluated definition, triggering the side effect", ->
expect(lisp read "((lambda (c) (catch 111 (* 2 (protect (* 3 (throw 111 5)) (set! c 1) ))) c ) 0)").to.equal(1)
it "Same story, using block/return", ->
expect(lisp read "((lambda (c) (block A (* 2 (protect (* 3 (return A 5)) (set! c 1) ))) ) 0)").to.equal(5)
it "Same story, using block/return with a triggered side-effect", ->
expect(lisp read "((lambda (c) (block A (* 2 (protect (* 3 (return A 5)) (set! c 1) ))) c ) 0)").to.equal(1)
#describe "Core interpreter #3: Try/Catch with Throw as a function", ->
# contain = (fcall) ->
# return "(begin ((lambda () (begin (set! funcall (lambda (g . args) (apply g args))) #{fcall}))))"
#
# it "", ->
# expect(-> lisp read "(funcall throw 'bar 33").to.throw("bar")
# it "", ->
# expect(lisp read "(catch 'bar (funcall throw 'bar 11))").to.equal(11)
# it "", ->
# expect(lisp read "(catch 'bar (* 2 (funcall throw 'bar 5)))").to.equal(5)
# it "", ->
# expect(lisp read "((lambda (f) (catch 'bar (* 2 (f 5))) ) (lambda (x) (funcall throw 'bar x))) ").to.equal(5)
# it "", ->
# expect(lisp read "((lambda (f) (catch 'bar (* 2 (catch 'bar (* 3 (f 5))))) ) (lambda (x) (funcall throw 'bar x)))) ").to.equal(10)
# it "", ->
# expect(lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (funcall throw 1 (funcall throw 2 5)) )) ))) ").to.equal(105)
# it "", ->
# expect(lisp read "(catch 2 (* 7 (funcall throw 1 (funcall throw 2 3))))").to.equal(3)

43
test/test_chapter4.coffee
View File

@ -1,43 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons} = require "cons-lists/lists"
olisp = require '../chapter4/interpreter'
{read, readForms} = require '../chapter4/reader'
the_false_value = (cons "false", "boolean")
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
describe "Core interpreter #4: Pure Lambda Memory", ->
it "Understands symbol equality", ->
expect(lisp read "(eq? 'a 'b)").to.equal(false)
expect(lisp read "(eq? 'a 'a)").to.equal(true)
it "Understands separate allocation inequality", ->
expect(lisp read "(eq? (cons 1 2) (cons 1 2))").to.equal(false)
it "Understands address equality", ->
expect(lisp read "((lambda (a) (eq? a a)) (cons 1 2))").to.equal(true)
expect(lisp read "((lambda (a) (eq? a a)) (lambda (x) x))").to.equal(true)
it "Understands function inequality", ->
expect(lisp read "(eq? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)
it "Understands equivalence", ->
expect(lisp read "(eqv? '1 '2)").to.equal(false)
expect(lisp read "(eqv? 1 1)").to.equal(true)
expect(lisp read "(eqv? 'a 'b)").to.equal(false)
expect(lisp read "(eqv? 'a 'a)").to.equal(true)
expect(lisp read "(eqv? (cons 1 2) (cons 1 2))").to.equal(false)
expect(lisp read "((lambda (a) (eqv? a a)) (cons 1 2))").to.equal(true)
expect(lisp read "((lambda (a) (eqv? a a)) (lambda (x) x))").to.equal(true)
expect(lisp read "(eqv? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)
it "Does special OR (backtracking without side-effect)", ->
expr1 = "((lambda (x) (or (begin (set! x (+ x 1)) #f) (if (= x 1) \"OK\" \"KO\"))) 1)"
expect(lisp read expr1).to.equal("OK")
expr2 = "((lambda (x) (or (begin (set! x (+ x 1)) #f) (if (= x 1) (begin (set! x 3) x) \"KO\"))) 1)"
expect(lisp read expr2).to.equal(3)

27
test/test_chapter5a.coffee
View File

@ -1,27 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
olisp = require '../chapter5/interpreter5a'
{read} = require '../chapter5/reader'
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
describe "Core interpreter #5: Now with more λ!", ->
it "Understands symbol inequality", ->
expect(lisp read "(eq? 'a 'b)").to.equal(false)
it "Understands symbol equality", ->
expect(lisp read "(eq? 'a 'a)").to.equal(true)
it "Understands separate allocation inequality", ->
expect(lisp read "(eq? (cons 1 2) (cons 1 2))").to.equal(false)
it "Understands address equality of values", ->
expect(lisp read "((lambda (a) (eq? a a)) (cons 1 2))").to.equal(true)
it "Understands address equality of functions", ->
expect(lisp read "((lambda (a) (eq? a a)) (lambda (x) x))").to.equal(true)
it "Understands function inequality", ->
expect(lisp read "(eq? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)

35
test/test_reader.coffee
View File

@ -1,35 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons, nil, nilp} = require "cons-lists/lists"
{read, readForms} = require '../chapter1/reader'
{normalizeForm} = require '../chapter1/astToList'
describe "Core reader functions", ->
samples = [
['nil', nil]
['0', 0]
['1', 1]
['500', 500]
['0xdeadbeef', 3735928559]
['"Foo"', 'Foo']
['(1)', cons(1)]
['(1 2)', cons(1, (cons 2))]
['(1 2 )', cons(1, (cons 2))]
['( 1 2 )', cons(1, (cons 2))]
['( 1 2 )', cons(1, (cons 2))]
['("a" "b")', cons("a", (cons "b"))]
['("a" . "b")', cons("a", "b")]
['[]', []]
['{}', {}]
['[1 2 3]', [1, 2, 3]]
# ['(1 2 3', 'error']
['{"foo" "bar"}', {foo: "bar"}]
]
for [t, v] in samples
do (t, v) ->
it "should interpret #{t} as #{v}", ->
res = normalizeForm read t
expect(res).to.deep.equal(v)

15
test/test_reader5a.coffee
View File

@ -1,15 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons, nil, nilp} = require "cons-lists/lists"
{read} = require '../chapter5/reader'
{normalize} = require '../chapter5/reader_rawtoform'
{samples} = require './reader5_samples'
describe "Lisp reader functions", ->
for [t, v] in samples
do (t, v) ->
it "should interpret #{t} as #{v}", ->
res = normalize read t
expect(res).to.deep.equal(v)

15
test/test_reader5b.coffee
View File

@ -1,15 +0,0 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons, nil, nilp} = require "cons-lists/lists"
{read} = require '../chapter5/tracking_reader'
{normalize} = require '../chapter5/reader_tracktoform'
{samples} = require './reader5_samples'
describe "Tracker reader functions", ->
for [t, v] in samples
do (t, v) ->
it "should interpret #{t} as #{v}", ->
res = normalize read t
expect(res).to.deep.equal(v)