carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-17 16:38:14 +03:00
Code Issues Projects Releases Wiki Activity

ready to roll

Browse Source
This commit is contained in:
Erik Svedäng 2016-01-13 14:09:27 +01:00
parent a98d619dc5
commit b26b62a5a2
20 changed files with 4635 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitignore vendored Normal file
View File

@ -0,0 +1,7 @@
/bin/carp-repl
*.dSYM
/gl-constants/gl_constants.o
/gl-constants/gl_constants.so
/out/*.c
/out/*.so
/src/*.o

12
Makefile Normal file
View File

@ -0,0 +1,12 @@
CFLAGS=-I/usr/local/opt/libffi/lib/libffi-3.0.13/include
LDFLAGS=-L/usr/local/opt/libffi/lib/
LDLIBS=-lffi
all: src/main.o
clang ./src/main.c -g -O0 -rdynamic -o ./bin/carp-repl -ldl $(CFLAGS) $(LDFLAGS) $(LDLIBS)
run:
./bin/carp
clean: rm -f ./bin/*.o ast

29
TODO.md Normal file
View File

@ -0,0 +1,29 @@
# Dynamic Runtime
- meta data on Objs: Line nr, line pos, source file,
- warn if a let statement has more than one body form (implicit do)
- add array as its own tag for Obj, [] syntax, etc
- split c program into several files: Runtime, Reader, Printer, Evaluator, Primops, Obj, Gc
- jump table in evaluator, use a 'dispatch' member with a label adress in Obj
- primops should have signatures
- remove globals to enable several instances of the runner in parallel
- nicer pretty printing of lists of lists
- better error handling and input validation for primops, clean up the C macros
- lambdas should be able to have their signature set/get
- profile the evaluator
- namespaces
- equality for dictionaries
# Maybes
- polymorphic math operators?
- matching/destructuring in let statements and function arguments too?
- reading of dotted pairs
# Compiler
- Track dependencies between functions
- Change :a and :b in binop and if to :left and :right
- Compilation of generic functions
- lambdas / lambda lifting
- compile a whole file to a single dylib
- nicer names for compiler generated variables
- speed up some passes by mutating a single variable instead of copying immutable versions around

6
bin/carp Executable file
View File

@ -0,0 +1,6 @@
#!/bin/bash
# Get the dir of this script (which is in the bin folder)
DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )"
CARP_DIR=$DIR/../ rlwrap $DIR/carp-repl

8
gl-constants/Makefile Normal file
View File

@ -0,0 +1,8 @@
CFLAGS=-I/usr/local/include
LDFLAGS=-L/usr/local/lib/
LDLIBS=-lGLEW -lglfw3 -framework OpenGL -framework Cocoa -framework IOKit
all: gl_constants.o
clang gl_constants.c -shared -g -o gl_constants.so $(CFLAGS) $(LDFLAGS) $(LDLIBS)
clean: rm -f *.o main

3
gl-constants/gl_constants.c Normal file
View File

@ -0,0 +1,3 @@
#include <GLFW/glfw3.h>
#include "gl_constants.h"

12
gl-constants/gl_constants.h Normal file
View File

@ -0,0 +1,12 @@
#ifndef GL_CONSTANTS
#define GL_CONSTANTS
#include <GLFW/glfw3.h>
int gl_color_buffer_bit = GL_COLOR_BUFFER_BIT;
int gl_lines = GL_LINES;
int gl_line_strip = GL_LINE_STRIP;
int gl_triangles = GL_TRIANGLES;
#endif

7
lisp/boot.carp Normal file
View File

@ -0,0 +1,7 @@
(def carp-dir (getenv "CARP_DIR"))
(load-lisp (str carp-dir "lisp/core.lisp"))
(load-lisp (str carp-dir "lisp/compiler.lisp"))
;;(load-lisp (str carp-dir "lisp/glfw_test.lisp"))
(load-lisp (str carp-dir "lisp/example.lisp"))

836
lisp/compiler.lisp Normal file
View File

@ -0,0 +1,836 @@
;; Gotchas
;; * Unloading of function/dylib doesn't work after another function has linked to it during its compilation.
;; * Variable shadowing doesn't work properly when referencing itself
;; Anatomy of AST nodes
;; { :node = The kind of node this is. Can be :function / :arg / :literal / :app (function application) / :binop
;; :type = The type that has been calculated for this node.
;; :name = Used by AST nodes where this makes sense. The name of a variable or function, etc.
;; }
;; Anatomy of a type
;; Before the type is known it is set to a typevar which is a string of the form "t0", "t1", etc
;; Types can be just a keyword like :int / :string
;; Complex types are lists, like the :arrow type (:arrow (:int :int) :string) which corresponds to (Int, Int) -> String
;; How to add forms
;; 1. Make the ast generator generate a new kind of AST :node for the form (see above)
;; 2. The AST node should generate new type vars for all places where the type is unknown
;; 3. Make the constraint generator generate type constraints for the node
;; 4. Extend the function (assign-types) that substitute type variables for concrete types in the AST
;; 5. TODO: Make the borrow checker know about the node, if needed
;; 6. Make the C generator spit out beautiful C for the AST node
;; 7. Profit!
(def typevar-counter 0)
(defn gen-typevar ()
(let (typevar (str "t" typevar-counter))
(do (swap! typevar-counter inc)
typevar)))
(defn arg-list-to-ast (args)
(map (fn (arg)
{:node :arg
:name arg
:type (gen-typevar)})
args))
(defn type-from-literal (lit)
(match (type lit)
:symbol (gen-typevar) ;; symbol means variable lookup, and we don't know the type of that variable
x x))
(defn binop? (form)
(match form
(x & _) (contains? '(+ - * / <) x)
_ false))
(defn gen-arrowtype (arg-count)
(list :arrow (repeatedly gen-typevar arg-count) (gen-typevar)))
(defn list-to-ast (l)
(if (binop? l)
(match l
(op a b) {:node :binop
:type (gen-typevar)
:op op
:a (form-to-ast a)
:b (form-to-ast b)})
(match l
('= left right) {:node :binop
:type :bool
:op '==
:a (form-to-ast left)
:b (form-to-ast right)}
_ {:node :app
:type (gen-typevar)
:head (assoc (form-to-ast (first l)) :type (gen-arrowtype (count (rest l))))
:tail (map form-to-ast (rest l))})))
(defn if-to-ast (expr a b)
{:node :if
:type (gen-typevar)
:expr (form-to-ast expr)
:a (form-to-ast a)
:b (form-to-ast b)})
(defn do-to-ast (forms)
{:node :do
:type (gen-typevar)
:forms (map form-to-ast forms)})
(defn bindings-to-ast (bindings)
(match bindings
(name value & rest-bindings) (cons {:node :binding
:type (gen-typevar)
:name name
:value (form-to-ast value)}
(bindings-to-ast rest-bindings))
_ ()))
(defn let-to-ast (bindings body)
{:node :let
:type (gen-typevar)
:bindings (bindings-to-ast bindings)
:body (form-to-ast body)})
(defn while-to-ast (expr body)
{:node :while
:type :void
:expr (form-to-ast expr)
:body (form-to-ast body)})
(defn form-to-ast (form)
(match form
('if expr a b) (if-to-ast expr a b)
('do & forms) (do-to-ast forms)
('let bindings body) (let-to-ast bindings body)
('while expr body) (while-to-ast expr body)
('include-c-code s) {:node :c-code :code s :type (gen-typevar)}
'NULL {:node :null :type (gen-typevar)}
'true {:node :literal :type :bool :value 1}
'false {:node :literal :type :bool :value 0}
x (if (= :list (type x))
(list-to-ast x)
{:node :literal
:type (type-from-literal x)
:value x})))
(defn body-to-ast (body)
(form-to-ast body))
;; Takes a list representation of a lambda and creates an AST from it
(defn lambda-to-ast (form)
(do (assert-eq :list (type form))
(match form
('fn args body) {:node :function
:type (gen-arrowtype (count args))
:args (arg-list-to-ast args)
:body (body-to-ast body)}
_ :failed-to-match-lambda-form)))
;;; Processing of the AST ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The type env is bindings from variable names to types or variables, i.e. {:x :int, :y "t10"}
(defn type-env-extend (type-env args)
(let [new-env (copy type-env)]
(do (reduce (fn (_ pair) (dict-set! new-env (nth pair 0) (nth pair 1)))
nil
(map2 list (map :name args) (map :type args)))
new-env)))
(defn is-self-recursive? (type-env app-f-name)
(let [x (get-maybe type-env app-f-name)]
(do
;;(println (str "app-f: " app-f-name ", x: " x))
(= x :self))))
(defn get-type-of-symbol (type-env sym)
(let [lookup (get-maybe type-env sym)]
(if (= () lookup)
(let [global-lookup (eval sym)]
(type global-lookup))
lookup)))
(defn math-op? (op)
(contains? '(+ - * /) op))
(defn generate-constraints-internal (constraints ast type-env)
(do
;;(println "gen constrs: \n" ast)
(match (get ast :node)
:function (let [extended-type-env (type-env-extend type-env (get ast :args))
extended-type-env-2 (let [fn-name (get-maybe ast :name)]
(if (string? fn-name)
(assoc extended-type-env fn-name :self)
extended-type-env))
new-constraints (generate-constraints-internal constraints (:body ast) extended-type-env-2)
func-ret-constr {:a (get-in ast '(:type 2)) ;; the return type of the arrow type
:b (get-in ast '(:body :type))
:doc (str "func-ret-constr")}
func-arg-constrs (map2 (fn (a b) {:a a :b b :doc "func-arg"})
(map :type (:args ast))
(get-in ast '(:type 1)))]
(concat func-arg-constrs (cons func-ret-constr new-constraints)))
:app (let [ret-constr {:a (get ast :type) :b (get-in ast '(:head :type 2)) :doc "ret-constr for :app"}
arg-constrs (map2 (fn (a b) {:a a :b b :doc "app-arg"}) (get-in ast '(:head :type 1)) (map :type (:tail ast)))
func-constrs (let [app-f-sym (get-in ast '(:head :value))
app-f-name (str app-f-sym)
app-f (eval app-f-sym)]
(if (foreign? app-f)
(list {:a (get-in ast '(:head :type)) :b (signature app-f) :doc "func-app"})
(if (is-self-recursive? type-env app-f-name)
() ;; no constraints needed when the function is calling itself
(do (println (str "Calling non-baked function: " app-f-name " of type " (type app-f-sym) "\nWill bake it now!"))
(bake-internal (new-builder) app-f-name (code (eval app-f-name)) '())
(println (str "Baking done, will resume job."))
(list {:a (get-in ast '(:head :type)) :b (signature (eval app-f-name)) :doc "freshly baked func-app"}))
)))
tail-constrs (reduce (fn (constrs tail-form) (generate-constraints-internal constrs tail-form type-env))
'() (:tail ast))
new-constraints (concat tail-constrs func-constrs (cons ret-constr arg-constrs))]
(concat new-constraints constraints))
:literal (let [val (:value ast)]
(if (symbol? val) ;; if it's a symbol it's a lookup
(cons {:a (get ast :type)
:b (get-type-of-symbol type-env val)
:doc (str "lit-constr, lookup " val)} constraints)
constraints)) ;; other literals don't need constraints, just return unchanged constraints
:binop (let [x0 (generate-constraints-internal constraints (get ast :a) type-env)
x1 (generate-constraints-internal x0 (get ast :b) type-env)
;;tvar (gen-typevar)
;;left-arg-constr {:a tvar :b (get-in ast '(:a :type)) :doc "left-arg-constr"}
;;right-arg-constr {:a tvar :b (get-in ast '(:b :type)) :doc "right-arg-constr"}
;;ret-constr {:a tvar :b (:type ast)}
same-arg-type-constr {:a (get-in ast '(:a :type)) :b (get-in ast '(:b :type)) :doc "same-arg-type-constr"}
maybe-constr (if (math-op? (:op ast))
(list {:a (get-in ast '(:a :type)) :b (:type ast)})
())
]
;;(concat x1 (list left-arg-constr right-arg-constr ret-constr)))
(concat maybe-constr (cons same-arg-type-constr x1)))
:if (let [x0 (generate-constraints-internal constraints (get ast :a) type-env)
x1 (generate-constraints-internal x0 (get ast :b) type-env)
x2 (generate-constraints-internal x1 (get ast :expr) type-env)
left-result-constr {:a (get-in ast '(:a :type)) :b (:type ast)}
right-result-constr {:a (get-in ast '(:b :type)) :b (:type ast)}
expr-must-be-bool {:a :bool :b (get-in ast '(:expr :type))}]
(concat x2 (list
expr-must-be-bool
left-result-constr
right-result-constr)))
:do (let [x0 (reduce (fn (constrs form) (generate-constraints-internal constrs form type-env))
constraints (:forms ast))
;;_ (log "count: " (count x0))
n (count (:forms ast))
ret-constr {:a (:type ast) :b (get-in ast (list :forms (- n 1) :type)) :doc "do-ret-constr"}]
(cons ret-constr x0))
:let (let [bindings (:bindings ast)
extended-type-env (reduce (fn (e b) (assoc e (:name b) (get-in b '(:value :type)))) type-env bindings)
;;_ (println "Extended type env: " extended-type-env)
let-constr {:a (:type ast) :b (get-in ast '(:body :type)) :doc "let-constr"}
bindings-constr (mapcat (fn (binding) (let [bind-constr {:a (:type binding) :b (get-in binding '(:value :type))}
value-constrs (generate-constraints-internal constraints (:value binding) type-env)]
(cons bind-constr value-constrs)))
bindings)
body-constrs (generate-constraints-internal constraints (:body ast) extended-type-env)]
(cons let-constr (concat bindings-constr body-constrs)))
:while (let [x0 (generate-constraints-internal constraints (get ast :body) type-env)
x1 (generate-constraints-internal x0 (get ast :expr) type-env)
body-result-constr {:a (get-in ast '(:body :type)) :b (:type ast)}
expr-must-be-bool {:a :bool :b (get-in ast '(:expr :type))}]
(concat x1 (list expr-must-be-bool )))
:null constraints
_ constraints
)))
(defn generate-constraints (ast)
(let [constraints '()]
(generate-constraints-internal constraints ast {})))
(def gencon generate-constraints)
(defn lookup (substs b)
(let [val (get-maybe substs b)]
(if (= () val)
b
(if (= b val)
val
(if (= :string (type val))
(lookup substs val) ; keep looking
val)) ; found the actual type
)))
;; Replacement function for replacing "from the right" in an associative map2
;; Example usage:
;; (replace-subst-from-right {:a :b, :c :d} :d :e)
;; =>
;; {:c :e,
;; :a :b}
(defn maybe-replace-binding (key value replace-this with-this)
(if (= replace-this value)
{:key key :value with-this}
{:key key :value value}))
(defn replace-subst-from-right (substs existing b)
(reduce (fn (new-substs pair) (assoc new-substs (:key pair) (:value pair)))
{}
(map2 (fn (k v) (maybe-replace-binding k v existing b)) (keys substs) (values substs))))
(def log-substs false)
(defn typevar? (x) (string? x))
(defn extend-substitutions (substs a b)
(do (when log-substs (println (str "\n" substs)))
(when log-substs (println (str "\nEXTEND " a " " b)))
(let [existing (get-maybe substs a)]
(if (= () existing)
(do (when log-substs (println (str "New substitution: " a " = " b)))
(assoc substs a (lookup substs b)))
(do (when log-substs (println (str "Found existing substitution for " a ", it was = " existing)))
(let [replacement (lookup substs b)]
(do
(when log-substs (println (str "Replacement: " replacement)))
(if (unify existing replacement)
(do (when log-substs (println "OK, replacement is the same."))
substs)
(if (typevar? replacement)
(if (typevar? (lookup substs a))
(do (when log-substs (println "Replace from right"))
(replace-subst-from-right substs existing replacement))
(do (when log-substs (println "Ignore this one"))
substs))
(if (typevar? existing)
(do (when log-substs (println "Replace existing typevar from right"))
(replace-subst-from-right substs existing replacement))
(error (str "Type checking failed, can't unify " replacement " with " existing))))))))))))
;; \nSubstitutions:\n" substs
(defn unify (a b)
(if (and (list? a) (list? b))
(all? true? (map2 unify a b))
(if (= :any a)
true
(if (= :any b)
true
(= a b))))) ;; else clause
(defn solve-list (substs a-list b-list)
(match (list a-list b-list)
(() ()) substs
((a & as) (b & bs)) (solve (solve substs a b) as bs)
_ (error (str "Lists not matching: " a-list " - vs - " b-list ", substs: \n" substs))))
(defn solve (substs a b)
(if (and (list? a) (list? b))
(solve-list substs a b)
(if (string? a)
(extend-substitutions substs a b)
substs)))
(defn solve-contraint-internal (substs constraint)
(let [a (:a constraint)
b (:b constraint)]
(solve (solve substs a b) b a))) ; Solving from both directions!
;; Returns a substitution map from type variables to actual types
(defn solve-constraints (constraints)
(reduce solve-contraint-internal {} constraints))
(defn make-type-list (substs typevars)
(map (fn (t) (if (string? t) (get-type substs t)
(if (list? t)
(make-type-list substs t)
t)))
typevars))
(defn get-type (substs typevar)
(if (list? typevar)
(make-type-list substs typevar)
(let [maybe-type (get-maybe substs typevar)]
(if (= maybe-type ())
typevar ;; lookup failed, there is no substitution for this type variable (= it's generic)
maybe-type))))
(defn assign-types-to-list (asts substs)
(map (fn (x) (assign-types x substs)) asts))
(defn assign-types-to-binding (b substs)
(let [x0 (assoc b :type (get-type substs (:type b)))
x1 (assoc x0 :value (assign-types (:value b) substs))]
x1))
(defn assign-types (ast substs)
(match (:node ast)
:function (let [a (assoc ast :type (get-type substs (:type ast)))
b (assoc a :body (assign-types (:body ast) substs))
c (assoc b :args (assign-types-to-list (:args ast) substs))]
c)
:app (let [app-ret-type (get-type substs (:type ast))]
(assoc (assoc (assoc ast :type app-ret-type)
:head (assign-types (:head ast) substs))
:tail (map (fn (x) (assign-types x substs)) (:tail ast))))
:literal (assoc ast :type (get-type substs (:type ast)))
:arg (assoc ast :type (get-type substs (:type ast)))
:binop (let [x0 (assoc ast :type (get-type substs (:type ast)))
x1 (assoc x0 :a (assign-types (:a ast) substs))
x2 (assoc x1 :b (assign-types (:b ast) substs))]
x2)
:if (let [x0 (assoc ast :type (get-type substs (:type ast)))
x1 (assoc x0 :a (assign-types (:a ast) substs))
x2 (assoc x1 :b (assign-types (:b ast) substs))
x3 (assoc x2 :expr (assign-types (:expr ast) substs))]
x3)
:do (let [x0 (assoc ast :forms (map (fn (x) (assign-types x substs)) (:forms ast)))
x1 (assoc x0 :type (get-type substs (:type ast)))]
x1)
:let (let [x0 (assoc ast :bindings (map (fn (b) (assign-types-to-binding b substs)) (:bindings ast)))
x1 (assoc x0 :body (assign-types (:body x0) substs))
x2 (assoc x1 :type (get-type substs (:type ast)))]
x2)
:while (let [x0 (assoc ast :type (get-type substs (:type ast)))
x1 (assoc x0 :body (assign-types (:body ast) substs))
x2 (assoc x1 :expr (assign-types (:expr ast) substs))]
x2)
:null ast
:c-code (assoc ast :type (get-type substs (:type ast)))
_ (error (str "Can't assign types to ast node " ast))))
;; x1 (assoc-in x0 '(:body :type) (get-type substs (get-in x0 '(:body :type))))
(defn get-deps (ast)
(do
;;(println (str "visiting " ast))
(if (dict? ast)
(if (= :literal (:node ast))
(if (symbol? (:value ast))
(if (def? (:value ast))
(if (ffi? (eval (:value ast)))
'()
(do (println (eval (:value ast))) (list (:value ast))))
(do (println (str (:value ast) " " (type (:value ast)) " not defined")) (list (:value ast))))
'())
(mapcat get-deps (values ast)))
(if (list? ast)
(mapcat get-deps ast)
'()))))
(def name-counter 0)
(defn gen-name ()
(do (swap! name-counter inc)
(str "" name-counter)))
(defn generate-names (ast)
(do
;;(println (str "genname for " (:node ast)))
(match (:node ast)
:function (let [ast1 (assoc ast :body (generate-names (:body ast)))]
ast1)
:if (let [if-result-name (str "if_result_" (gen-name))
if-expr-name (str "if_expr_" (gen-name))
ast1 (assoc ast :if-result-name if-result-name)
ast2 (assoc ast1 :if-expr-name if-expr-name)
ast3 (assoc ast2 :a (generate-names (:a ast)))
ast4 (assoc ast3 :b (generate-names (:b ast)))]
ast4)
:while (let [while-expr-name (str "while_expr_" (gen-name))
ast1 (assoc ast :while-expr-name while-expr-name)
ast2 (assoc ast1 :body (generate-names (:body ast)))]
ast2)
:let (let [let-result-name (str "let_result_" (gen-name))
ast1 (assoc ast :bindings (map generate-names (:bindings ast)))
ast2 (assoc ast :body (generate-names (:body ast)))
ast3 (assoc ast2 :let-result-name let-result-name)]
ast3)
:binding ast ;; (let [] (log "binding:\n" ast))
:app (let [head (:head ast)
func-name (:value head)
c-func-name (c-ify-name (str func-name))
app-result-name (str c-func-name "_result_" (gen-name))
args (:tail ast)
arg-names (repeatedly (fn () (str "arg_" (gen-name))) (count args))
ast1 (assoc ast :head (generate-names (:head ast)))
ast2 (assoc ast1 :tail (map (fn (node) (generate-names node)) (:tail ast1)))
ast3 (assoc ast2 :app-result-name app-result-name)
ast4 (assoc ast3 :tail (map2 (fn (arg arg-name) (assoc arg :arg-name arg-name)) (:tail ast3) arg-names))
]
ast4)
:binop (let [ast1 (assoc ast :a (generate-names (:a ast)))
ast2 (assoc ast1 :b (generate-names (:b ast)))]
ast2)
:do ast
:literal ast
_ (error (str "Can't generate name for node " ast))
)))
(defn calculate-lifetimes (ast)
ast)
(defn annotate-ast (ast)
(let [constraints (generate-constraints ast)
substs (solve-constraints constraints)
ast-typed (assign-types ast substs)
ast-names (generate-names ast-typed)
ast-lifetimes (calculate-lifetimes ast-names)]
ast-lifetimes))
;;; Code gen ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn c-ify-name (lisp-name)
(let [x0 (str-replace lisp-name "-" "_")
x1 (str-replace x0 "?" "QMARK")
x2 (str-replace x1 "!" "BANG")]
x2))
(defn type-build (t)
(if (string? t)
"typevar"
(match t
:? "unknown"
(:arrow _ _) "arrow"
(:ptr p) (str (name p) "*")
x (name x))))
;; Creates a C code builder which allows for out-of-order generation of C from the AST
(defn new-builder ()
{:headers ()
:functions ()})
(defn builder-add (builder category block)
(update-in builder (list category) (fn (blocks) (cons-last blocks block))))
;; Takes a completed C code builder and returns its string with C code
(defn builder-merge-to-c (builder)
(let [funcs (get builder :functions)
headers (get builder :headers)]
(join "\n\n"
(list (join "\n" headers)
(join "\n" funcs)))))
(def indent-level 1)
(defn indent ()
(join "" (replicate " " indent-level)))
(defn indent-in! ()
(swap! indent-level inc))
(defn indent-out! ()
(swap! indent-level dec))
(defn free-variables! (c free-list)
(do
(str-append! c (str (indent) "/* FREE: */\n"))
(map (fn (variable)
(str-append! c (str (indent) "free(" variable ")")))
free-list)
(str-append! c (str (indent) "/* * * * */\n"))))
(defn visit-arg (c arg)
(let [result (visit-form c arg true)]
(str-append! c (str (indent) (type-build (:type arg)) " " (:arg-name arg) " = " (get result :c) ";\n"))))
(defn visit-args (c args)
(let []
(do
;;(println "visit args:" args)
(map (fn (arg) (visit-arg c arg)) args)
(map (fn (arg) {:c (:arg-name arg)}) args))))
(defn visit-bindings (c bindings)
;;(println bindings)
(map (fn (b) (let [value-result (visit-form c (:value b) false)]
(str-append! c (str (indent) (type-build (:type b)) " " (:name b) " = " (:c value-result) ";\n"))))
bindings))
(defn visit-form (c form toplevel)
(match (get form :node)
:binop (let [result-a (visit-form c (get form :a) false)
result-b (visit-form c (get form :b) false)]
{:c (str (if toplevel "" "(") (:c result-a) " " (:op form) " " (:c result-b) (if toplevel "" ")"))})
:literal (let [val (:value form)]
(if (symbol? val)
{:c (c-ify-name (name val))}
(if (string? val)
{:c (str "strdup(" (prn val) ")")}
{:c (prn val)})))
:if (let [if-expr (visit-form c (get form :expr) true)
n (get form :if-result-name)
ifexpr (get form :if-expr-name)]
(do (str-append! c (str (indent) (type-build (get-in form '(:expr :type))) " " ifexpr " = " (get if-expr :c) ";\n"))
(if (= :void (:type form))
() ;; no result variable needed
(str-append! c (str (indent) (type-build (:type form)) " " n ";\n")))
(str-append! c (str (indent) "if(" ifexpr ")"))
;; true-block begins
(str-append! c " {\n")
(indent-in!)
(let [result-a (visit-form c (get form :a) true)]
(do
(if (= :void (:type form))
() ;; no-op
(str-append! c (str (indent) n " = " (get result-a :c) ";\n")))
(indent-out!)
(str-append! c (str (indent) "} else {\n"))))
(indent-in!) ;; false-block-begins
(let [result-b (visit-form c (get form :b) true)]
(do
(if (= :void (:type form))
() ;; no-op
(str-append! c (str (indent) n " = " (get result-b :c) ";\n")))
(indent-out!)
(str-append! c (str (indent) "}\n"))))
{:c n}))
:app (let [head (get form :head)
func-name (get head :value)
c-func-name (c-ify-name (str func-name))
n (:app-result-name form)
arg-results (visit-args c (get form :tail))
arg-vars (map (fn (x) (get x :c)) arg-results)]
(do (if (= :void (:type form))
(str-append! c (str (indent) c-func-name "(" (join ", " arg-vars) ");\n"))
(str-append! c (str (indent) (type-build (:type form)) " " n " = " c-func-name "(" (join ", " arg-vars) ");\n")))
{:c n}))
:do (let [forms (:forms form)
results (map (fn (x) (visit-form c x toplevel)) forms)]
{:c (:c (last results))})
:let (let [n (:let-result-name form)]
(do (if (= :void (:type form))
() ;; nothing
(str-append! c (str (indent) (type-build (:type form)) " " n ";\n")))
(str-append! c (str (indent) "{\n"))
(indent-in!)
(let [body (:body form)
_ (visit-bindings c (:bindings form))
result (visit-form c body false)]
(do (if (= :void (:type form))
()
(str-append! c (str (indent) n " = " (:c result) ";\n")))
;;(free-variables! c )
))
(indent-out!)
(str-append! c (str (indent) "}\n"))
{:c n}))
:while (let [while-expr (visit-form c (get form :expr) true)
while-expr-name (:while-expr-name form)]
(do (str-append! c (str (indent) (type-build (get-in form '(:expr :type))) " " while-expr-name " = " (get while-expr :c) ";\n"))
(str-append! c (str (indent) "while(" while-expr-name ") {\n"))
(indent-in!)
(let [body (:body form)]
(visit-form c body false))
(let [while-expr-again (visit-form c (get form :expr) true)]
(str-append! c (str (indent) while-expr-name " = " (get while-expr-again :c) ";\n")))
(indent-out!)
(str-append! c (str (indent) "}\n"))))
:c-code (do
;;(str-append! c )
{:c (:code form)})
:null {:c "NULL"}
x (error (str "visit-form failed to match " x))))
(defn arg-list-build (args)
(join ", " (map (fn (arg) (str (type-build (get arg :type)) " " (get arg :name)))args)))
(defn visit-function (builder ast func-name)
(let [t (:type ast)
_ (when (not (list? t)) (error "Can't generate code for function, it's type is not a list."))
return-type (nth t 2)
args (get ast :args)
body (get ast :body)
c (copy "") ;; mutable string holding the resulting C code for the function
result (visit-form c body true)
]
(do
;;(println "visit-function: \n" ast)
(let [code (str (name return-type) " " (c-ify-name func-name)
"(" (arg-list-build args) ") {\n"
c
(if (= :void (:type body))
"" ;; no return
(str (indent) "return " (get result :c) ";\n"))
"}")]
(builder-add builder :functions code)))))
(defn get-function-prototype (ast func-name)
(let [t (get ast :type)
return-type (nth t 2)
args (get ast :args)]
(str (name return-type) " " func-name "(" (arg-list-build args) ");")))
(defn ast-build (builder ast func-name)
(match (get ast :node)
:function (visit-function builder ast func-name)
x (error (str "Can't match :ast '" x "' in ast-to-c."))))
(def files (list "\"functions.h\"" "\"shared.h\""))
(defn add-headers (builder)
(reduce (fn (b file) (builder-add b :headers (str "#include " file)))
builder
files))
(def funcs {})
(defn add-func! (func-name func-proto func-dylib)
(swap! funcs (fn (fs) (assoc fs func-name {:func-name func-name
:func-proto func-proto
:func-dylib func-dylib}))))
(defn unload-if-necessary (func-name)
(map (fn (f)
(when (= func-name (get f :func-name))
(let [dylib (get f :func-dylib)]
(do (println (str "Unloading dylib " dylib " for function " func-name "."))
(unload-dylib dylib)
(dict-remove! funcs func-name)))))
(values funcs)))
(defn unload-all ()
(join "\n" (map (fn (x) (str (unload-dylib (:func-dylib x)))) (values funcs))))
(defn save-prototypes ()
(save "out/functions.h"
(str
"#include \"shared.h\"\n"
(join "\n" (map c-ify-name (map :func-proto (values funcs)))))))
(defn link (ignore-this)
(join " " (map (fn (f) (str "./out/" f ".so"))
(filter (fn (x) (not (= x ignore-this))) (map :func-name (values funcs))))))
(defn link-libs (dependencies)
(join " " (map (fn (f) (str "./out/" (c-ify-name (str f)) ".so")) dependencies)))
(defn include-paths ()
"-I/usr/local/include")
(defn lib-paths ()
"-L/usr/local/lib/ -lglfw3")
(defn framework-paths ()
"-framework OpenGL -framework Cocoa -framework IOKit")
(defn pretty-signature (t)
(match t
(:arrow args ret) (str "(" (join ", " (map pretty-signature args)) ") -> " (pretty-signature ret))
x (if (keyword? t) (name t)
(error (str "Invalid type signature: " t)))))
(def compile-exe false)
;; Takes a function name and the list representation of the lambda
(defn bake-internal (builder func-name func-code dependencies)
(let [ast (lambda-to-ast func-code)
ast-named (assoc ast :name func-name)
ast-annotated (annotate-ast ast-named)
builder-with-headers (add-headers builder)
new-builder (ast-build builder-with-headers ast-annotated func-name)
c-program-string (builder-merge-to-c new-builder)
proto (get-function-prototype ast-annotated func-name)
c-file-name (str "out/" func-name ".c")
c-func-name (c-ify-name func-name)]
(do
(def ast ast-annotated)
(def c c-program-string)
(match (get ast-annotated :type)
(:arrow arg-types return-type)
(do
(save-prototypes)
(save c-file-name c-program-string)
(let [clang-command (str "clang "
(if compile-exe
(str "-o out/a.out ")
(str "-shared -o out/" c-func-name ".so "))
c-file-name " "
(include-paths) " "
(lib-paths) " "
(framework-paths) " "
(link-libs dependencies))]
(do
(println clang-command)
(def cmd clang-command)
(system clang-command)))
(unload-if-necessary func-name)
(def out-lib (load-dylib (str "./out/" c-func-name ".so")))
(register out-lib c-func-name arg-types return-type)
(add-func! func-name proto out-lib)
(let [f (eval (read func-name))]
(do (def s (pretty-signature (signature f)))
f)))
_ (error "Must bake function with type (:arrow ...)")))))
;; Bake a function in the current environment, just give it's symbol
(defmacro bake (func-symbol)
(list 'bake-internal (new-builder) (str func-symbol) (list 'code func-symbol) '()))
(defmacro bake* (func-symbol dependencies)
(list 'bake-internal (new-builder) (str func-symbol) (list 'code func-symbol) dependencies))
(defn run-compiler-tests () (load "compiler_tests.lisp"))
(load (str carp-dir "lisp/compiler_tests.lisp"))

155
lisp/compiler_tests.lisp Normal file
View File

@ -0,0 +1,155 @@
(defn test-constraint-solving-1 ()
(let [constraints (list {:a :int :b "t0"}
{:a :string :b "t0"})]
(do ;;(println "\nCon1:\n" (solve-constraints constraints))
(println "\nCon1 reversed:\n" (solve-constraints (reverse constraints))))))
(defn test-constraint-solving-2 ()
(let [constraints (list {:a :int :b "t0"}
{:a :int :b "t0"})]
(do (println "\nCon1:\n" (solve-constraints constraints))
(println "\nCon1 reversed:\n" (solve-constraints (reverse constraints))))))
(defn test-constraint-solving-3 ()
(let [constraints (list {:a :int :b "t0"}
{:a :string :b "t1"})]
(do (println "\nCon3:\n" (solve-constraints constraints))
(println "\nCon3 reversed:\n" (solve-constraints (reverse constraints))))))
(defn test-constraint-solving-4 ()
(let [constraints (list {:a "t0" :b "t0"}
{:a "t0" :b "t1"}
{:a "t1" :b "t1"})]
(do (println "\nCon4:\n" (solve-constraints constraints))
(println "\nCon4 reversed:\n" (solve-constraints (reverse constraints))))))
(defn test-constraint-solving-5 ()
(let [constraints (list {:a "t0" :b "t0"}
{:a "t0" :b "t1"}
{:a "t1" :b :float}
{:a "t1" :b "t1"})]
(do (println "\nCon5:\n" (solve-constraints constraints))
(println "\nCon5 reversed:\n" (solve-constraints (reverse constraints))))))
;; (test-constraint-solving-2)
;; (test-constraint-solving-3)
;; (test-constraint-solving-4)
;; (test-constraint-solving-5)
(defn test-fib ()
(do
(def fibast (lambda-to-ast (code fib)))
(def fibcon (gencon fibast))
(def fibsolved (solve-constraints fibcon))
(def fibasta (annotate-ast fibast))))
(defn foo (x)
(+ (- x 100) 1))
(defn test-foo ()
(do (bake foo)
(assert-eq (foo 200) 101)
(assert-eq (type foo) :foreign)
:foo-is-ok))
;;(test-foo)
(defn hypo (x y)
(sqrtf (+ (* x x) (* y y))))
(defn test-hypo ()
(do (bake hypo)
(assert-approx-eq (hypo 3.0 4.0) 5.0)
(assert-eq (type hypo) :foreign)
:hypo-is-ok))
;;(test-hypo)
(defn f (s)
(strlen s))
(defn g (x s)
(* x (f s)))
(defn h (x)
(if "blorg" "Hej" x))
(def fast (lambda-to-ast (code f)))
(def fcon (gencon fast))
(def fasta (annotate-ast fast))
(def hast (lambda-to-ast (code h)))
(def hcon (gencon hast))
(def hasta (annotate-ast hast))
(defn fuck ()
(+ "hej" 23))
(def fuckast (lambda-to-ast (code fuck)))
(def fuckcon (gencon fuckast))
;;(def fuckasta (annotate-ast fuckast))
(defn mix (x y z)
(if (< (strlen z) 3) (* (itof y) x) x))
;; (def mixast (lambda-to-ast (code mix)))
;; (def mixcon (gencon mixast))
;; (def mixasta (annotate-ast mixast))
(defn monad ()
(do (strlen "hej")
(strlen "svej")
(strlen "yay")))
(def monast (lambda-to-ast (code monad)))
(def moncon (gencon monast))
(def monasta (annotate-ast monast))
(defn test-loading ()
(do
(save "out/out.c" "int f() { return 100; }")
(system "clang -shared -o out/f.so out/out.c")
(def flib (load-dylib "out/f.so"))
(register flib "f" () :int)
(assert-eq 100 (f))
(save "out/out.c" "int g() { return 150; }")
(system "clang -shared -o out/g.so out/out.c")
(def glib (load-dylib "out/g.so"))
(register glib "g" () :int)
(assert-eq 150 (g))
(unload-dylib flib)
(save "out/out.c" "int f() { return 200; }")
(system "clang -shared -o out/f.so out/out.c")
(def flib (load-dylib "out/f.so"))
(register flib "f" () :int)
(assert-eq 200 (f))
))
;; This does NOT work!
(defn shadow (x)
(let [x (* x 3)]
x))
;; (def shadowast (lambda-to-ast (code shadow)))
;; (def shadowcon (gencon shadowast))
;; (def shadowasta (annotate-ast shadowast))
(defn own1 ()
(let [s "yeah"]
(strlen s)))
(defn own2 ()
(if true 10 20))
(defn own3 ()
(while true (println "hello")))
(defn own4 (x)
(+ (* 2 x) (+ 1 x)))

164
lisp/core.lisp Normal file
View File

@ -0,0 +1,164 @@
;; TODO
;; -> and ->>
;; shuffle
;; conversions between a list of pairs and dictionaries
(def defmacro (macro (name args body) (list 'def name (list 'macro args body))))
(defmacro when (expr a) (list 'if expr a nil))
(defmacro if-not (expr a b) (list 'if (list 'not expr) a b))
(defmacro comment (form) nil)
(defmacro assert-eq (a b)
(list 'if-not (list '= a b)
(list 'error (list 'str "assert-eq fail: " (str a) " => " a " - VS - " (str b) " => " b))
nil))
(defmacro defn (name args body)
(list 'def name (list 'fn args body)))
(defn assert-approx-eq (target x)
(do
(assert-eq true (< x (+ target 0.1)))
(assert-eq true (< (- target 0.1) x))))
(defn id (x) x)
(defn get-in (dict keys)
(if (= () keys)
dict
(get-in (get dict (first keys)) (rest keys))))
(defn dict-set-in! (dict keys value)
(if (= 1 (count keys))
(dict-set! dict (first keys) value)
(dict-set-in! (get dict (first keys)) (rest keys) value)))
(defn update-in! (dict key-path f)
(dict-set-in! dict key-path (f (get-in dict key-path))))
(defn update-in (dict key-path f)
(let (new (copy dict))
(do (update-in! new key-path f)
new)))
(defn assoc (dict key val)
(let [new (copy dict)]
(do
(dict-set! new key val)
new)))
(defn assoc-in (dict keys val)
(let [new (copy dict)]
(do
(dict-set-in! new keys val)
new)))
(defn join (separator xs)
(match (count xs)
0 ""
1 (str (first xs))
_ (str (first xs) separator (join separator (rest xs)))))
(defn replicate (thing times)
(if (< times 1)
'()
(cons thing (replicate thing (- times 1)))))
(defn repeatedly (f times)
(if (< times 1)
'()
(cons (f) (repeatedly f (- times 1)))))
(defmacro time (form)
(list 'let (list 't1 (list 'now))
(list 'do
(list 'let (list 'result form)
(list 'println (list 'str "Evaluating form took " (list '- (list 'now) 't1) "ms. Result = " 'result))))))
(defmacro swap! (sym f)
(list 'reset! sym (list f sym)))
(defn inc (x) (+ x 1))
(defn dec (x) (- x 1))
(defn contains? (items item)
(match items
() false
(x & xs) (if (= x item)
true
(contains? xs item))))
(defn log (message value)
(do
(println (str message value))
value))
(defn nil? (x) (= nil x))
(defn int? (x) (= :int (type x)))
(defn string? (x) (= :string (type x)))
(defn symbol? (x) (= :symbol (type x)))
(defn keyword? (x) (= :keyword (type x)))
(defn env? (x) (= :env (type x)))
(def dict? env?)
(defn list? (x) (= :list (type x)))
(defn macro? (x) (= :macro (type x)))
(defn lambda? (x) (= :lambda (type x)))
(defn foreign? (x) (= :foreign (type x)))
(defn primop? (x) (= :primop (type x)))
(defn range (start stop)
(if (< start stop)
(cons start (range (inc start) stop))
'()))
(defn range-f (start stop step)
(if (< start stop)
(cons start (range-f (+ start step) stop step))
'()))
(defn reverse (l)
(match l
() ()
(x) (list x)
(x & xs) (cons-last (reverse xs) x)))
(defn has-key? (dict key)
(not (= () (get-maybe dict key))))
(defn even? (x) (= 0 (mod x 2)))
(defn odd? (x) (= 1 (mod x 2)))
(defn last (xs)
(match xs
() (error "Can't call last on empty list.")
(x) x
_ (last (rest xs))))
(defn mapcat (f xs)
(apply concat (map f xs)))
(def load load-lisp) ;; alias to allow inferior-lisp-mode to load file
(defn true? (x) (= true x))
(defn false? (x) (= false x))
(defn all? (pred xs)
(= (count xs) (count (filter pred xs))))
(register-builtin "srand" '(:int) :void)
(register-builtin "rand" '() :int)
(register-builtin "strlen" '(:string) :int)
(register-builtin "sinf" '(:float) :float)
(register-builtin "cosf" '(:float) :float)
(register-builtin "sqrtf" '(:float) :float)
(register-builtin "itof" '(:int) :float)
(register-builtin "itos" '(:int) :string)
(register-builtin "panic" '(:string) :void)
(register-builtin "printf" '(:string) :void)
(register-builtin "print" '(:string) :void)
(register-builtin "println" '(:string) :void)
(register-builtin "sleep" '(:int) :void)
(register-builtin "nullQMARK" '((:ptr :any)) :bool)
(register-builtin "not" '(:bool) :bool)

36
lisp/example.lisp Normal file
View File

@ -0,0 +1,36 @@
(defn max (a b)
(if (< a b) b a))
(defn fib (n)
(if (< n 2)
1
(+ (fib (- n 2)) (fib (- n 1)))))
(defn blah (x s)
(* x (strlen s)))
(defn fiz (x)
(* 3.3 x))
(defn three (x)
(if (= x 3)
(println "Three!!!")
(println "Not three...")))
(defn say ()
(do (println "A")
(println "B")
(println "C")))
(defn eternal ()
(while true
(println "eternal")))
(register-builtin "fake" '() '(:ptr :int))
(register-builtin "fake2" '((:ptr :string)) :void)
(defn nullf ()
(let [x (fake)]
(null? x)))

71
lisp/glfw_test.lisp Normal file
View File

@ -0,0 +1,71 @@
(defn register-glfw ()
(let [glfw (load-dylib "libglfw3.dylib")
gl-constants (load-dylib (str carp-dir "gl-constants/gl_constants.so"))]
(do
(reset! files (cons "<GLFW/glfw3.h>" files))
(reset! files (cons "\"../gl-constants/gl_constants.h\"" files))
(register glfw "glfwInit" '() :bool)
(register glfw "glfwCreateWindow" '(:int :int :string (:ptr :GLFWmonitor) (:ptr :GLFWwindow)) '(:ptr :GLFWwindow))
(register glfw "glfwMakeContextCurrent" '((:ptr :GLFWwindow)) :void)
(register glfw "glfwTerminate" '() :void)
(register glfw "glfwPollEvents" '() :void)
(register glfw "glfwWindowShouldClose" '((:ptr :GLFWwindow)) :bool)
(register glfw "glfwSwapBuffers" '((:ptr :GLFWwindow)) :void)
(register glfw "glClearColor" '(:float :float :float :float) :void)
(register glfw "glClear" '(:int) :void)
(register glfw "glColor3f" '(:float :float :float) :void)
(register glfw "glBegin" '(:int) :void)
(register glfw "glEnd" '() :void)
(register glfw "glVertex3f" '(:float, :float, :float) :void)
(register-variable gl-constants "gl_color_buffer_bit" :int)
(register-variable gl-constants "gl_lines" :int)
(register-variable gl-constants "gl_line_strip" :int)
(register-variable gl-constants "gl_triangles" :int)
)))
(register-glfw)
(defn set-clear-color ()
(glClearColor 0.0f 0.95f 0.75f 1.0f))
(defn draw-rect (x y w h)
(do (glBegin gl-triangles)
(glVertex3f x y 0.0f)
(glVertex3f (+ x w) y 0.0f)
(glVertex3f (+ x w) (+ y h) 0.0f)
(glVertex3f (+ x w) (+ y h) 0.0f)
(glVertex3f x (+ y h) 0.0f)
(glVertex3f x y 0.0f)
(glEnd)))
(defn app ()
(if (glfwInit)
(let [window (glfwCreateWindow 640 480 "Yeah!" NULL NULL)]
(if (null? window)
(panic "No window.")
(do (println "Window OK.")
(glfwMakeContextCurrent window)
(while (not (glfwWindowShouldClose window))
(do
(glClearColor 0.0f 0.95f 0.75f 1.0f)
(glClear gl-color-buffer-bit)
(glColor3f 1.0f 1.0f 1.0f)
(draw-rect 0f 0f 0.2f 0.4f)
(glfwSwapBuffers window)
(glfwPollEvents)))
(glfwTerminate))))
(panic "Failed to initialize glfw.")))
(defn main ()
(do (app)
0))
(def app-ast (lambda-to-ast (code app)))
;; (def glcon (gencon glast))
;; (def glasta (annotate-ast glast))

47
lisp/misc.lisp Normal file
View File

@ -0,0 +1,47 @@
(defn f-f ()
123)
(defn g-g ()
(f-f))
(defn conso2 (a b c)
(do
;;(glVertex3f a b c) ;; 8
;;(glVertex3f b c a) ;; 40
;;(glVertex3f c a b) ;; 168
;;(glVertex3f c a b) ;; 680
;;(glVertex3f c a b) ;; 2728
;;(glVertex3f c a b) ;; 10920
))
(defn conso1 (x)
(do
(cosf x)
(cosf x) ;; 12
(cosf x) ;; 28
(cosf x) ;; 60
;;(cosf x) ;; 124
))
(defn test-conso ()
(do
;;(def conso-ast (form-to-ast '(cosf x)))
(def conso-ast (form-to-ast '(let [x 10f] (do (cosf x) (cosf x) (cosf x))))) ;; (cosf x) (cosf x))))
(def conso-con (generate-constraints conso-ast))
(def conso-asta (annotate-ast conso-ast))
))
;;(test-conso)
;; (def v-ast (form-to-ast '(glVertex3f (+ 0.0f 0.8f) (+ 0.0f 0.7f) 0.0f)))
;; (def v-con (gencon v-ast))
;; (def v-asta (annotate-ast v-ast))
;; (defn vg (x)
;; (glVertex3f x (+ 1.0f x) 2.0f))
;; (def vg-ast (lambda-to-ast (code vg)))
;; (def vg-con (gencon vg-ast))
;; (def vg-asta (annotate-ast v-ast))

296
lisp/tests.lisp Normal file
View File

@ -0,0 +1,296 @@
(defn test-negative-numbers ()
(do
(assert-eq (- 10) -10)
(assert-eq 123 (- 0 -123))))
(defn test-str-replace ()
(do
(assert-eq "Erik" (str-replace "erik" "e" "E"))))
(defn test-all-predicate ()
(do
(assert-eq true (all? even? (list 2 4 6 8)))
(assert-eq false (all? even? (list 2 4 6 9)))
(assert-eq true (all? even? ()))))
(defn test-while-loop ()
(let [x 0
s ""]
(do
(while (< x 10)
(do
(str-append! s (str x))
(swap! x inc)))
(assert-eq "0123456789" s))))
(defn test-mapcat ()
(assert-eq '(1 2 3 1 2 3 4 1 2 3 4 5) (mapcat (fn (x) (range 1 (inc x))) '(3 4 5))))
(defn test-floats ()
(do
(let [x 3.5f
y 2.0f]
(do
(assert-eq false (< x y))
(assert-eq true (< y x))
(assert-approx-eq 5.5 (+ x y))
(assert-approx-eq 7.0 (* x y))
(assert-approx-eq 1.5 (- x y))
(assert-approx-eq 1.75 (/ x y))
))))
(defn test-shadowing ()
(let [x 100
shadow-fn (fn (x)
(do
(reset! x 42)
(assert-eq x 42)))]
(do
(shadow-fn 0)
(assert-eq 100 x))))
(defn test-keyword-in-list-in-match ()
(assert-eq (match true
true '(:a :b (:c) :d))
(list :a :b (list :c) :d)))
(defn test-varable-capture ()
(let [x 3
capture (fn ()
(fn (y) (* x y)))
captured (capture)]
(assert-eq (captured 4) 12)))
(defn test-cons-last ()
(assert-eq '(100 200 300 400 500) (cons-last '(100 200 300 400) 500)))
(defn test-match-2 ()
(assert-eq (match '(hej du)
('blargh _) :error
('hej _) :correct
_ :also-error)
:correct))
(defn test-assoc ()
(let [m {:a 10}]
(do
(assert-eq 100 (get (assoc m :a 100) :a))
(assert-eq 200 (get (assoc m :b 200) :b))
(assert-eq 10 (get m :a)))))
(defn test-has-key ()
(do
(assert-eq true (has-key? {:a 10 :b 20} :a))
(assert-eq true (has-key? {:a 10 :b 20} :b))
(assert-eq false (has-key? {:a 10 :b 20} :c))))
(defn test-keyword-lookup ()
(assert-eq 20 (:b {:a 10 :b 20 :c 30})))
(defn test-range ()
(do
(assert-eq '(3 4 5 6) (range 3 7))
(assert-eq () (range 20 10))))
(defn test-assoc-in ()
(let [m2 {:a {:b 20}}]
(do
(assert-eq 200 (get-in (assoc-in m2 '(:a :b) 200) '(:a :b))) ; change local copy
(assert-eq 20 (get-in m2 '(:a :b)))))) ; unchanged)
(defn test-swap ()
(let [x 10]
(swap! x inc)
(assert-eq 11 x)))
(defn test-str-append ()
(let [greeting "hej"]
(do
(str-append! greeting "!")
(str-append! greeting "!")
(str-append! greeting "!")
(assert-eq "hej!!!" greeting))))
(defn test-str-join ()
(do
(assert-eq "" (join "," '()))
(assert-eq "10" (join "," '(10)))
(assert-eq "10,20,30" (join "," '(10 20 30)))))
(defn test-apply-str ()
(assert-eq "erikisaksvedang" (apply str (list "erik" "isak" "svedang"))))
(defn test-contains ()
(do
(assert-eq true (contains? (list 10 20 30) 20))
(assert-eq true (contains? '(30) 30))
(assert-eq false (contains? (list 10 20 30) 50))
(assert-eq false (contains? () 100))))
(defn test-fib ()
(let [fib (fn (n)
(match n
0 0
1 1
2 1
x (+ (fib (- x 2)) (fib (- x 1)))))]
(assert-eq '(1 1 2 3 5 8 13 21 34) (map fib '(1 2 3 4 5 6 7 8 9)))))
(defn test-dictionary-mutation ()
(let [stuff {:a 100 :b 200 :c 300 123 102030 :d () :e (+ 2 3)}
gruff (list "hej" :boo 'nice)
tree {:a 10 :b {:a 20 :b 30} :c {:a 40 :b 50}}]
(do
(dict-set-in! tree '(:b :a) "hejsan")
(assert-eq (get-in tree '(:b :a)) "hejsan")
(update-in! tree '(:c :a) (fn (x) (* x 1000)))
(assert-eq (get-in tree '(:c :a)) 40000)
(let [tree-2 (update-in tree '(:c :a) (fn (x) (- x 1)))]
(do
(assert-eq (get-in tree '(:c :a)) 40000)
(assert-eq (get-in tree-2 '(:c :a)) 39999))))))
(defn test-dictionary-copy ()
(let [a {:x 100}
b (copy a)
c a]
(do
(dict-set-in! a '(:x) 200)
(assert-eq 200 (get a :x))
(assert-eq 100 (get b :x)) ; unchanged, because of copy
(assert-eq 200 (get c :x)) ; changed, just an alias
)))
(defn test-dictionary-evaluation ()
;; Evaluation of dictionaries should not modify the literal
(let [self-destruct ( fn (x)
{:x x}
(assert-eq (str (fn (x) {:x x})) (str self-destruct))
(self-destruct 10))]
(assert-eq (str (fn (x) {:x x})) (str self-destruct))))
(defn test-map ()
(assert-eq (map (fn (x) (* x x)) '(1 2 3 4 5))
(list 1 4 9 16 25)))
(defn test-filter ()
(assert-eq (filter even? '(1 2 3 4 5 6))
(list 2 4 6)))
(defn test-reduce ()
(assert-eq (reduce + 0 '(1 2 3 4 5))
15))
(defn test-match ()
(do
(assert-eq 123 (match 123 x x))
(assert-eq (match 20
10 :a
20 :b
30 :c)
:b)
(assert-eq (match 42
a (+ a 10))
52)
(assert-eq (match '(1 2 3)
(a b c) (+ a b (* c c)))
12)
(let [me (list "erik" 29)
me-2 (match me (name age) {:name name :age age})]
(assert-eq (get me-2 :age) 29))))
(defn test-not ()
(do
(assert-eq true (not false))
(assert-eq true (not (not true)))
(assert-eq true (not false false false))
(assert-eq false (not false false true false))
(assert-eq false (not true))
(assert-eq false (not (not false)))))
(defn test-misc ()
(do
(assert-eq 10 (id 10))))
(defn test-concat ()
(do
(assert-eq (concat '(1 2) '(3 4)) '(1 2 3 4))
(assert-eq (concat '(1 ) '(2 3 4)) '(1 2 3 4))
(assert-eq (concat '() '(1 2 3 4)) '(1 2 3 4))
(assert-eq (concat '(1 2 3) '(4)) '(1 2 3 4))
(assert-eq (concat '(1 2 3 4) '()) '(1 2 3 4))
(assert-eq (concat '(1 2) '(3) '(4)) '(1 2 3 4))
(assert-eq (concat '(1 2) () '(3) () '(4)) '(1 2 3 4))
(assert-eq (concat '() '(1) () '(2) () '(3) () '(4) ()) '(1 2 3 4))
(assert-eq (concat '() '()) '())
(assert-eq (concat '() '() '()) '())))
(defn test-reset ()
(let [temp ""
abc (fn (x)
(do
(reset! temp (str temp "Ole, "))
(reset! temp (str temp "dole, "))
(reset! temp (str temp "doff!"))
x))]
(do
(assert-eq "hej" (abc "hej"))
(assert-eq "Ole, dole, doff!" temp))))
(defn test-self-destruct-2 ()
;; Doesn't work when pretty printing of lambda bodies is turned off
(do
(defn self-destruct-2 (x)
(list 1 2 x 4 5))
(assert-eq "(fn (x) (list 1 2 x 4 5))" (str self-destruct-2))
(self-destruct-2 10)
(assert-eq "(fn (x) (list 1 2 x 4 5))" (str self-destruct-2))
(reset! print-lambda-body before)))
(defn run-core-tests ()
(do
(test-keyword-in-list-in-match)
(test-shadowing)
(test-varable-capture)
(test-str-append)
(test-str-join)
(test-apply-str)
(test-not)
(test-misc)
(test-map)
(test-filter)
(test-reduce)
(test-match)
(test-concat)
(test-contains)
(test-fib)
(test-dictionary-mutation)
(test-dictionary-copy)
(test-dictionary-evaluation)
(test-reset)
(test-swap)
(test-assoc)
(test-has-key)
(test-keyword-lookup)
(test-range)
(test-assoc-in)
(test-cons-last)
(test-match-2)
(test-floats)
(test-mapcat)
(test-while-loop)
(test-all-predicate)
(test-str-replace)
(test-negative-numbers)
))
(run-core-tests)
;; Can't test this inside a function:
(defn define-at-toplevel ()
(def top-var :mountain-high))
(define-at-toplevel)
(assert-eq :mountain-high top-var)

1
out/functions.h Normal file
View File

@ -0,0 +1 @@
#include "shared.h"

54
out/shared.h Normal file
View File

@ -0,0 +1,54 @@
#ifndef SHARED_H
#define SHARED_H
#include <math.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <stdbool.h>
typedef int unknown;
typedef void* typevar;
typedef void* any;
typedef char* string;
int intsqrt(int x) { return sqrt(x); }
float itof(int x) { return (float)x; }
string itos(int x) {
char *s = malloc(sizeof(char) * 32);
snprintf(s, 32, "%d", x);
return s;
}
bool nullQMARK(void *p) {
return p == NULL;
}
bool not(bool x) {
return !x;
}
void panic(string msg) {
printf("Error: %s\n", msg);
exit(1);
}
void print(string msg) {
printf("%s", msg);
}
void println(string msg) {
printf("%s\n", msg);
}
int* fake() {
return (int*)123;
}
void fake2(string *s) {
}
#endif

0
out/temp Normal file
View File

10
src/main.c Normal file
View File

@ -0,0 +1,10 @@
#include <stdio.h>
#include <string.h>
#include "mini.h"
int main() {
env_new_global();
eval_text(global_env, "(load-lisp (str (getenv \"CARP_DIR\") \"lisp/boot.carp\"))", false);
repl(global_env);
assert(obj_total == 0);
}

2881
src/mini.h Normal file
View File

File diff suppressed because it is too large Load Diff