Ferret Programmer's Manual

Table of Contents

Getting Started

What Is Ferret

Ferret is a free software Clojure implementation, it compiles a restricted subset of the Clojure language to self contained ISO C++11 which allows for the use of Clojure in real time embedded control systems.

Generated code is self contained ISO C++11, it is not tied to any one compiler, generated code should be portable between any Operating System and/or Microcontroller that supports a C++11 compliant compiler. It has been verified to run on architectures ranging from embedded systems with as little as 2KB of RAM to general purpose computers running Linux/Mac OS X/Windows.

  • General Purpose Computers
    • Clang on Mac OS X
    • GCC & Clang on Linux
  • Microcontrollers
    • Arduino
      • Uno / Atmega328
      • Due / AT91SAM3X8E
      • 101 / Intel Curie
    • Teensy
      • 3.2 / Cortex-M4
      • 3.6 / Cortex-M4F
    • SparkFun SAMD21 Mini / ATSAMD21G18 - ARM Cortex-M0+
    • NodeMcu - ESP8266
  • Hardware / Operating System Support

Features

  • Tailored for Real Time Control Applications. (Deterministic Execution.)
  • Immutable Data Structures
  • Functional
  • Macros
  • Easy FFI (Inline C,C++. See Accessing C,C++ Libraries)
  • Easily Embeddable (i.e Ferret fns are just C++ functors.)
  • Memory Pooling (Ability to run without heap memory. See Memory Management)
  • Destructuring
  • Module System

Download

Ferret is available as prebuilt and source code distributions. See Building From Sources for links to source distribution.

Platform independent builds (requires JVM),

Platform dependent builds (with bundled 64 bit JVM 1.7),

A glimpse of Ferret

On any system, we can just compile a program directly into an executable. Here's a program that sums the first 5 positive numbers.

;;; lazy-sum.clj
(defn positive-numbers
  ([]
   (positive-numbers 1))
  ([n]
   (cons n (lazy-seq (positive-numbers (inc n))))))

(println (->> (positive-numbers)
              (take 5)
              (apply +)))

We can compile this program using ferret, creating an executable named a.out.

$ ./ferret -i lazy-sum.clj
$ g++ -std=c++11 -pthread lazy-sum.cpp
$ ./a.out
15

Output will be placed in a a file called lazy-sum.cpp. When -c flag is used ferret will call g++ or if set CXX environment variable on the resulting cpp file.

$ ./ferret -i lazy-sum.clj -c
$ ./a.out
15

Following shows a blink example for Arduino. (See section Arduino Boards for more info on how to use Ferret lisp on Arduino boards.)

;;; blink.clj
(pin-mode 13 :output)

(forever
 (digital-write 13 1)
 (sleep 500)
 (digital-write 13 0)
 (sleep 500))
$ ./ferret -i blink.clj -o blink/blink.ino

Then upload as usual. Following is another example, showing the usage of Memory Pooling. Program will blink two LEDs simultaneously at different frequencies (Yellow LED at 5 hz Blue LED at 20 hz). It uses a memory pool of 512 bytes allocated at compile time instead of calling malloc/free at runtime.

(configure-runtime! FERRET_MEMORY_POOL_SIZE 512
                    FERRET_MEMORY_POOL_PAGE_TYPE char)

(def yellow-led 13)
(def blue-led   12)

(pin-mode yellow-led :output)
(pin-mode blue-led   :output)

(defn make-led-toggler [pin]
  (fn []
    (->> (digital-read pin)
         (bit-xor 1)
         (digital-write pin))))

(def job-one
  (fn-throttler (make-led-toggler yellow-led) 5 :second :non-blocking))

(def job-two
  (fn-throttler (make-led-toggler blue-led)  20 :second :non-blocking))

(forever
 (job-one)
 (job-two))
$ ./ferret -i ferret-multi-led.clj -o ferret-multi-led/ferret-multi-led.ino

Support

Examples

Projects

Wrappers

License

BSD 2-Clause License

Copyright (c) 2017, Nurullah Akkaya All rights reserved.

Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

  • Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
  • Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Overview

Ferret is a functional, lazy language. All functions should mimic their Clojure counter parts. If they don't it is considered a bug. (or not possible to implement with the current implementation.)

This document is not intended to be a full Clojure tutorial. It is a specification of the subset of Clojure implemented by Ferret, and the particular workings of the Object / Runtime system.

Documentation Structure

This is a literate program, inspired by Donald Knuth (Knuth, Donald “Literate Programming (1984)” Literate Programming CSLI, p99). It is intended to be read like a novel from cover to cover. The ideas are expressed clearly but they are grounded in the actual source code.

The compiler and the C++ runtime needed is split into three sections.

Compiler section contains the actual compiler written in Clojure. It takes the Clojure code and converts it to a Intermediate representation by taking the Clojure form and running it through some transformations. This IR is then run through Code Generation module to create C++ code. Native Core contains the C++ runtime needed to support Ferret such as Object System, Memory Pooling, Garbage Collection. It is written in a mixture of C++ and Ferret DSL. Clojure Core corresponds to clojure.core, contains all Clojure functions supported by Ferret.

Hardware / Operating System Support

Ferret does not depend on any external dependencies (Including the C++ Standard Library). Unit tests are run on Mac OS X and Linux, any operating system with a C++11 compiler is supported. When running on a microcontroller ferret will check if it is a supported platform during compile time and enable hardware specific features. (Currently only UART is hardware specific.) If running on an unknown hardware it will run in safe mode (UART disabled.). Everything else is supported in safe mode. Like operating system support any embedded system with a C++11 compiler is supported. See What Is Ferret for a list of currently supported microcontrollers.

Arduino Boards

Ferret standard library has built in support for Arduino library. Any board that Arduino IDE supports should work with Ferret lisp.

Post Arduino 1.5.0, Ferret compiler can upload directly to a Arduino board by adding the following build command to the top of the file,

(configure-ferret! :command "~/apps/arduino-1.8.0/arduino \\
                               --board arduino:sam:arduino_due_x_dbg \\
                               --port /dev/ttyACM0 \\
                               --upload ./blink.cpp")

When -c option is passed Ferret will execute the above command and upload the solution to the board. (See ARDUINO(1) Manual Page for details.)

$ ./ferret -i blink.clj -c

Pre Arduino 1.5.0, recommended way is to go to preferences and set Arduino IDE to use an External Editor. This way when Ferret recompiles the sketch changes will be automatically picked up by the IDE ready to be uploaded. To automatically rename the cpp file to ino or pde use the following option,

(configure-ferret! :command "mv blink.cpp blink.ino")

Then compile with,

$ ./ferret -i blink.clj -c

Result will be blink.ino ready to be uploaded. Any changes to the clj file should be picked up by the IDE.

Building From Sources

The code in this document is the executable source. Use the build script in the source distribution to extract source code.

The latest sources are available at,

Dependencies,

  • Java
  • Emacs >= 24.5
  • Clojure
  • Leiningen

Assuming all of the above is in your path just run,

./build

This will extract the source from this file to src/ directory and build the jar and executable distributions. build script assumes it is running on a *NIX based system if not, open this file using emacs and run,

M-x org-babel-tangle

that will extract the source code then you can threat it as any other Clojure/Lein project.

Compiler

Ferret has a similar architecture to other modern compilers,

compiler_arch.png

Figure 1: Ferret Compiler Architecture

First, an input file containing Clojure code is loaded from the command line. From there a series of source-to-source transformations are performed on the AST to expand macros, perform optimizations, and make the code easier to compile to C++. (Optionally these intermediate representations (IR) can be printed out in a readable format to aid debugging.) The final AST is then output as a .cpp file and the C++ compiler is invoked to create the final executable or object file.

Compilation

Clojure (or any other Lisp) has features not provided by C++ such as automatic memory management i.e. garbage collection (GC), closures etc. Source-to-source transformations are used to add constructs required by C++, restructure Clojure forms in preparation to generate C++ code. Final intermediate representation can be directly compiled to C++. Any Clojure form go through nine transformations before they are passed to the code generation phase. Each transformation makes a separate pass over the form, this makes the compiler easier to maintain.

(defn compile [form options]
  (->> (ferret-runtime options form)
       (remove-assertions options)
       (expand-macros-all)
       (let->fn)
       (do->fn)
       (closure-conversion)
       (replace-fn-call-sites options)
       (escape-analysis)
       (symbol-conversion)))

Runtime

Import all modules in the given form. Supported require forms,

(require 'package.io)

(require '[package.io :as io])

(require '[package.io :as io]
         '[package.udp :as udp])

Compiler will look for a file under current working directory called, package/io.clj all expression in the that file will be added to the front of the current form with symbols renamed to some-fn => io/some-function.

(defn import-modules-select-require [form]
  (let [norm-require (fn [f]
                       (if (symbol? f)
                         [f :as f]
                         f))]
    (->> (select-form form (is-form-fn? 'require))
         (reduce (fn[h v]
                   (if (= 2 (count v))
                     ;; require single module
                     (conj h (norm-require (->> v last last)))
                     ;; require multiple modules
                     (concat h (map #(norm-require (last %)) (rest v))))) [])
         (map (fn [[mod _ as]] [mod as]))
         (reduce (fn[h [mod as]]
                   (if (h mod)
                     (assoc h mod (conj (h mod) as))
                     (assoc h mod [as]))) {}))))

Extract the list of packages and aliases from the form. Returns a map of mod -> aliases pairs.

(defn import-modules-load-modules [package-list options]
  (->> package-list
       (reduce (fn[h [m aliases]]
                 (let [mod           (-> (str (:path options) (.replace (str m) "." "/") ".clj")
                                         (read-clojure-file)
                                         (remove-form (is-form-fn? 'configure-runtime!))
                                         (remove-form (is-form-fn? 'configure-ferret!)))
                       macro-symbols (->> (select-form mod (is-form-fn? 'defmacro))
                                          (map second)
                                          (into #{}))
                       def-symbols    (->> (select-form (expand-macros-all mod) (is-form-fn? 'def))
                                           (map second)
                                           (into #{}))
                       replace?        (set/union macro-symbols def-symbols)
                       mod             (morph-form
                                        mod #(and (symbol? %) (replace? %))
                                        #(symbol (str (.replace (str m) "." "_") "_" %)))]
                   (reduce (fn [h v] (conj h v)) h mod)))
               [])
       lazy-seq))

Loads all modules listed in the package list. When a module is loaded all its symbols are replaced with its module name except core functions. Module names acts as namespaces. Returns a form that the is concatenation of all modules listed in form.

(defn import-modules-convert-alias-to-module [package-list form]
  (let [alias-to-mod (reduce (fn[h [mod aliases]]
                               (reduce (fn[h v] (assoc h v mod)) h aliases))
                             {} package-list)]
    (morph-form form symbol?
                (fn [f]
                  (if-let [[_ alias fn] (re-find #"(.*?)/(.*)" (str f))]
                    (if-let [mod-sym (alias-to-mod (symbol alias))]
                      (symbol (str (.replace (str mod-sym) "." "_") "_" fn))
                      f)
                    f)))))

Convert all aliased symbols in the form to their fully qualified modules names. So helper-a defined in module util.db becomes util_db_helper-a.

(defn import-modules [form options]
  (let [package-list (import-modules-select-require form)
        form         (remove-form form (is-form-fn? 'require))
        modules      (import-modules-load-modules package-list options)
        form         (import-modules-convert-alias-to-module package-list form)]
    (shake-concat modules form)))

(defn import-modules-all [form options]
  (loop [f form]
    (let [expanded (import-modules f options)]
      (if (= f expanded)
        expanded
        (recur expanded)))))

Generates the required runtime for the form by importing the required modules and concatenate the required runtime from clojure.core (src/ferret/runtime.clj)

(defn ferret-runtime [options form]
  (->> (-> form
           (import-modules-all options)
           (expand-reader-macros))
       (shake-concat (read-clojure-file "ferret/runtime.clj"))
       ;; tag form with the build info
       (cons `(~'native-define ~(try
                                  (let [version (read-file-from-url "build.info")]
                                    (str "// ferret-lisp build:" version))
                                  (catch Exception e
                                    (str "// ferret-lisp")))))))

Expand Macros

Process some supported reader macros, @ and #(some-fn) and convert map reader forms to Ferret d-list. Maps are zero or more key/value pairs enclosed in braces: {:a 1 :b 2}.

(defn expand-reader-macros [form]
  (-> form
      (morph-form (is-form-fn? 'clojure.core/deref)
                  (fn [f] `(~'deref ~@(rest f))))
      (morph-form map? (fn [x] (cons 'new-d-list (-> x seq flatten))))))

Prepare form f for macro expansion,

(defn macro-normalize [f]
  (morph-form f
              (is-form-fn? 'let)
              (fn [[_ bindings & body]]
                `(~'let* ~(apply list bindings) ~@body))))

Macro expansion is done by reading all the macros present in src/ferret/runtime.clj and combining them with user defined macros. They are evaluated in a temporary namespace, using morph-form we iterate all the macros used in the code that we are compiling and expand them in the temporary namespace then the node is replaced with its expanded form.

(declare expand-macros-all)

(defn expand-macros [form]
  (let [core-macros (->> (read-clojure-file "ferret/runtime.clj")
                         (filter (is-form-fn? 'defmacro)))
        core-macro-symbols (into #{} (map second core-macros))
        form-macros (->> (filter (is-form-fn? 'defmacro) form)
                         (filter (fn [[_ name]]
                                   (not (core-macro-symbols name)))))
        form-macro-symbols (map second form-macros)
        form (remove-form form (is-form-fn? 'defmacro))
        temp-ns (gensym)
        macro-symbols (concat core-macro-symbols form-macro-symbols)]

    (create-ns temp-ns)
    (binding [*ns* (the-ns temp-ns)]
      (refer 'clojure.core :exclude (concat macro-symbols ['fn 'def]))
      (use '[ferret.core :only [symbol-conversion fn->unique-args]])

      (doseq [m (concat core-macros form-macros)]
        (eval m)))

    (let [form (-> form
                   (macro-normalize)
                   (expand-reader-macros)
                   (morph-form (apply is-form-fn? macro-symbols)
                               (fn [f]
                                 (binding [*ns* (the-ns temp-ns)]
                                   (walk/macroexpand-all f)))))]
      (remove-ns temp-ns)
      form)))

(defn expand-macros-all-aux [form]
  (loop [f form]
    (let [expanded (expand-macros f)]
      (if (= f expanded)
        expanded
        (recur expanded)))))

(def expand-macros-all (memoize expand-macros-all-aux))

Takes a fn form and converts all argument symbols with their unique replacements. This is needed because most Clojure/Lisp forms are represented as fn's and some forms such as let need to be able to shadow already defined variable names.

(fn [a b] (list a b))
;;becomes
(fn [a__1510 b__1511] (list a__1510 b__1511))
(defn fn->unique-args [form]
  (let [valid-symbol? (fn [s] (and (symbol? s) (not= s '&) (not= s '_)))
        [args & body] form]
    (if (string?  (->> body
                       (filter #(not (is-form? 'native-declare %)))
                       first))
      `(~'fn* ~args ~@body)
      (let [unique-args (->> args
                             flatten
                             (filter valid-symbol?)
                             (map #(symbol (str % (gensym "__")))))
            replace? (->> (interleave (->> args
                                           flatten
                                           (filter valid-symbol?))
                                      unique-args)
                          (apply hash-map))
            unique-body (walk/prewalk
                         (fn [x]
                           (if (and (symbol? x)
                                    (replace? x))
                             (replace? x)
                             x)) body)
            args (->> (morph-form args #(replace? %) #(replace? %))
                      (into []))]
        `(~'fn* ~args ~@unique-body)))))

let->fn

let forms are transformed into nested functions which are then called immediately, bindings are setup in the outer function, expressions are placed in the inner function which takes the bindings as arguments.

So following form,

(let->fn '(let [a 1
                b 2]
            (+ a b)))

after transformation becomes,

((fn [a__1331] ((fn [b__1332] (+ a__1331 b__1332)) 2)) 1)
(defn let->fn [form]
  (-> form

      (morph-form (is-form-fn? 'let*)
                  (fn [[_ bindings & body]]
                    (if (empty? bindings)
                      `((~'fn () ~@body))
                      (apply
                       (fn close [[arg val] & more]
                         (if (empty? more)
                           `((~'fn [~arg] ~@body) ~val)
                           `((~'fn [~arg] ~(apply close more)) ~val)))
                       (partition 2 bindings)))))

      (morph-form (is-form-fn? 'fn)
                  (fn [[_ & body]]
                    (fn->unique-args body)))))

do->fn

A similar method is used for the do form, expressions are wrapped in a fn that takes no parameters and executed in place.

(do->fn '(do (+ 1 1)))
((fn [] (+ 1 1)))
(defn do->fn [form]
  (morph-form form
              (is-form-fn? 'do)
              (fn [f] `((~'fn* () ~@(rest f))))))

Closure Conversion

closure-conversion handles the problem of free variables. Free variables passed to a nested function must be captured in a closure so they can be referenced at runtime. The closure conversion transformation modifies lambda definitions as necessary to create new closures.

(defn make-adder [x]
  (fn [n] (+ x n)))

in the above snippet x is a free variable, when the function make-adder returns, it needs to have a way of referencing that variable when it is used. The way Ferret handles this is that, every function will pass its arguments to inner functions (if any) it contains.

(closure-conversion '(fn* [x]
                          (fn* [n] (+ x n))))

Above form will be converted to,

(fir-lambda G__1333  (x) (n)  (+ x n))
(fir-lambda G__1334  ()  (x)  (fir-new-lambda G__1333 x))
(fir-new-lambda G__1334)

What this means is, define a functor named G__3154 that holds a reference to x, and another functor G__1334 that has no state. When we create an instance of G__1333 we pass x to its constructor. Since every thing is already converted to fns this mechanism allows variables to be referenced down the line and solves the free variable problem.

(defn lambda-defined? [fns env args body]
  (if-let [fn-name (@fns (concat [env args] body))]
    (apply list 'fir-new-lambda fn-name env)))

(defn define-lambda [fns env args body]
  (let [n (gensym)]
    (swap! fns assoc (concat [env args] body) n)
    (apply list 'fir-new-lambda n env)))

(defn closure-conversion
  ([form]
   (let [fns  (atom {})
         form (closure-conversion form fns)
         fns  (map (fn [[body name]] (concat ['fir-lambda name] body)) @fns)]
     (concat form fns)))
  ([form fns & env]
   (morph-form form
               (is-form-fn? 'fn*)
               (fn [[_ args & body]]
                 (let [env  (if (nil? env) '() (first env))
                       body (closure-conversion body fns (concat args env))]
                   (if-let [n (lambda-defined? fns env args body)]
                     n
                     (define-lambda fns env args body)))))))

Symbol Conversion

Some symbols valid in Clojure are not valid C++ identifiers. This transformation converts all symbols that are not legal C++ identifiers into legal ones.

(defn symbol-conversion [form]
  (let [c (comp #(symbol (clojure.string/escape
                          (str %)
                          {\- \_ \* "_star_" \+ "_plus_" \/ "_slash_"
                           \< "_lt_" \> "_gt_" \= "_eq_" \? "_QMARK_"
                           \! "_BANG_" \# "_"}))
                #(cond (= 'not %) '_not_
                       :default %))]
    (morph-form form symbol? c)))

Remove Assertions

(defn remove-assertions [options form]
  (if (:release options)
    (do (info "option => release mode")
        (remove-form form (is-form-fn? 'assert)))
    form))

Optimizations

Replace Fn Call Sites

Final step replaces all functions calls with new function objects define_lambda are renamed to fn. This removes all globals variables unless the fn defined is a closure. In which case it is left as a global variable and the class implementation is prepended with the global name for readability.

(compile '((let [a 1]
             (defn adder [x]
               (+ a x)))
           (defn my-inc [x] (+ 1 x))))

(replace-fn-call-sites
 '((define_lambda G__3885 (a) (x) (_plus_ a x))
   (define_lambda G__3886 () (a) (def adder (lambda_object G__3885 a)))
   (define_lambda G__3887 () () (define_var a 1) ((lambda_object G__3886) a))
   (define_lambda G__3888 () (x) (_plus_ 1 x))
   ((lambda_object G__3887))
   (def my_inc (lambda_object G__3888))))

((define_lambda adder_G__3885 (a) (x) (_plus_ a x))
 (define_lambda G__3886 () (a) (def adder (lambda_object adder_G__3885 a)))
 (define_lambda G__3887 () () (define_var a 1) ((lambda_object G__3886) a))
 (define_lambda my_inc () (x) (_plus_ 1 x))
 ((lambda_object G__3887)))
(defn select-def-fn [form]
  (->> (select-form form (is-form-fn? 'def))
       (filter (fn [[_ name val]]
                 (and (seq? val)
                      (= 'fir-new-lambda (first val)))))))

(defn replace-fn-call-sites-pure [form fn-defs fn-table]
  (let [no-global-fn (reduce (fn[h v]
                               (remove-form h (fn [f]
                                                (and (seq? f)
                                                     (= 'def (first f))
                                                     (every? true? (map = f v))))))
                             form fn-defs)        
        embeded-fn-calls (reduce (fn[h [name gensym]]
                                   (morph-form h  #(and (symbol? %)
                                                        (= % name))
                                               (fn [_] (list 'fir-new-lambda gensym))))
                                 no-global-fn fn-table)
        embed-fn-names (reduce (fn[h [name gensym]]
                                 (morph-form h #(and (symbol? %)
                                                     (= % gensym))
                                             (fn [_] (identity name))))
                               embeded-fn-calls fn-table)]
    embed-fn-names))

(defn replace-fn-call-sites [options form]
  (if (:global-functions options)
    form
    (let [pure-fn-defs (->> (select-def-fn form)
                            (filter #(= 2 (-> % last count))))
          pure-fn-table (map (fn [[_ name [_ gensym]]] [name gensym]) pure-fn-defs)
          form (replace-fn-call-sites-pure form pure-fn-defs pure-fn-table)
          closure-fn-defs (->> (select-def-fn form)
                               (filter #(not= 2 (-> % last count))))
          closure-fn-table (map (fn [[_ name [_ gensym]]] [name gensym]) closure-fn-defs)]
      (reduce (fn[h [name gensym]]
                (morph-form h #(and (symbol? %)
                                    (= % gensym))
                            (fn [_] (symbol (str name "_" gensym)))))
              form closure-fn-table))))
Tree Shaking

Concats two forms. Shakes the first form by removing any symbols not present in second form.

In order to keep the generated C++ code compact only the functions used will be present in the generated source file. Which means if you don't use println anywhere in the code it won't be defined in the final C++ file, but if you use it, it and everything it uses will be defined, in the case of println it will pull apply, print and newline with it.

(defn shake-concat
  ([header form]
   (let [shakeable? (fn [f]
                      (or (is-form? 'defn f)
                          (is-form? 'defnative f)))
         header-symbols (->> (select-form header seq?)
                             flatten
                             (filter symbol?)
                             (into #{}))
         header-fns (->> (select-form header shakeable?)
                         (map #(vector (second %) %))
                         (into {}))
         header-non-shakeable (remove-form header shakeable?)
         form-expanded (expand-macros-all (concat header-non-shakeable form))
         fns (atom #{})
         _ (shake-concat form-expanded header-fns fns header-non-shakeable)
         header-shaked (remove-form header (fn [f]
                                             (and (shakeable? f)
                                                  (not (@fns (second f))))))]
     (concat header-shaked form)))
  ([form built-in fns non-shakeable]
   (morph-form form symbol?
               #(do
                  (if-let [f (built-in %)]
                    (when (not (@fns %))
                      (swap! fns conj %)
                      (shake-concat (expand-macros-all (concat non-shakeable f))
                                    built-in fns non-shakeable))) %))))
Escape Analysis

Determines that a certain allocation never escapes the local function. This means that allocation can be done on the stack.

(defn escape-analysis [form]
  (->> (escape-fn-calls form)
       (escape-fn-dispatch)
       (escape-lambdas)))
Escape Function Calls
(defn escape-fn-calls [form]
  (morph-form form
              (fn [f]
                (and (seq? f)
                     (is-form? 'fir-new-lambda (first f))))
              (fn [f]
                (let [[[_ & fn] & args] f]
                  `((~'fir-new-lambda-stack ~@fn) ~@args)))))
Escape Dispatch Functions
(defn escape-fn-dispatch [form]
  (morph-form form
              (is-form-fn? 'fn-multi-arity)
              (fn [f]
                (morph-form f
                            (is-form-fn? 'fir-new-lambda)
                            (fn [[_ & f]]
                              `(~'fir-new-lambda-stack ~@f))))))
Escape Lambda Classes
(defn escape-lambdas [form]
  (let [stack-lambda-pred (fn [f]
                            (and (seq? f)
                                 (is-form? 'fir-new-lambda (first f))))
        heap-lambdas (->> (select-form form (fn [f]
                                              (and (seq? f)
                                                   (is-form? 'fir-new-lambda f))))
                          (map second)
                          (into #{}))
        stack-lambdas (->> (select-form form (fn [f]
                                               (and (seq? f)
                                                    (is-form? 'fir-new-lambda-stack f))))
                           (map second)
                           (into #{}))
        escapeable-lambdas (clojure.set/difference stack-lambdas heap-lambdas)]
    (morph-form form
                (fn [f]
                  (and (seq? f)
                       (= (first f) 'fir-lambda)
                       (escapeable-lambdas (second f))))
                (fn [[_ & f]]
                  `(~'fir-lambda-stack ~@f)))))

Helpers

During each pass we iterate over the nodes in the form using morph-form and remove-form, they both take a s-expression and a predicate if the predicate returns true, morph-form will call f passing the current node as an argument and replace that node with f's return value, remove-form on the other hand does what its name suggests and removes the node when predicate returns true.

(defn morph-form [tree pred f]
  (walk/prewalk (fn [x]
                  (if (pred x)
                    (f x)
                    x)) tree))

(defn remove-form [tree pred]
  (if (every? true? (map #(pred %) tree))
    (list )
    (loop [loc (zip/seq-zip tree)]
      (if (zip/end? loc)
        (zip/root loc)
        (recur
         (zip/next
          (if (pred (zip/node loc))
            (zip/remove loc)
            loc)))))))

(defn select-form [tree pred]
  (loop [loc (zip/seq-zip tree)
         nodes []]
    (if (zip/end? loc)
      nodes
      (recur
       (zip/next loc)
       (if (pred (zip/node loc))
         (conj nodes (zip/node loc))
         nodes)))))

(defn is-form? [s f]
  (and (seq? f)
       (= (first f) s)))

(defn is-form-fn? [& s]
  (fn [f]
    (some true? (map #(is-form? % f) s))))

File I/O

(defn os-name []
  (let [os (-> (System/getProperty "os.name") .toLowerCase)]
    (cond (.contains os "win")      :windows
          (.contains os "mac")      :mac
          (or (.contains os "nix")
              (.contains os "nux")
              (.contains os "aix")) :unix
              (.contains os "sunos")    :solaris)))

(defn read-file-from-url [f]
  (with-open [in (.getResourceAsStream (ClassLoader/getSystemClassLoader) f)
              rdr (BufferedReader. (InputStreamReader. in))]
    (apply str (interpose \newline (line-seq rdr)))))

(defn read-file [f & [options]]
  (try
    (read-file-from-url f)
    (catch Exception e-url
      (try
        (if (nil? options)
          (FileUtils/readFileToString (file f))
          (FileUtils/readFileToString (file (str (:path options) f))))
        (catch Exception e-path
          (warn "error reading =>" f)
          (System/exit 1))))))

(defn read-clojure-file [f]
  (read-string (str \( (read-file f) \))))

(defn write-to-file [f s]
  (FileUtils/writeStringToFile (file f) (.trim s)))

(defn escape-string [s]
  (org.apache.commons.lang.StringEscapeUtils/escapeJava s))

(defn file-path [file]
  (let [path (str (org.apache.commons.io.FilenameUtils/getPrefix file)
                  (org.apache.commons.io.FilenameUtils/getPath file))]
    (if (empty? path)
      "./"
      path)))

(def default-cpp-extension "cpp")

(defn file-extension [f]
  (org.apache.commons.io.FilenameUtils/getExtension f))

(defn file-base-name [f]
  (org.apache.commons.io.FilenameUtils/getBaseName f))

(defn file-exists [f]
  (.exists (file f)))

(defn make-file [p n e]
  (file (str p n "." e)))

Code Generation

The compiler's code generation phase takes a single pass over the transformed Clojure code and outputs C++ code. All Ferret modules and the program code is amalgamated in to a single source file which allows the generated code to be compiled as a single translation unit.This allows many compilers to do optimization's that would not be possible if the files were compiled separately. Code generation is done by running emit on the final intermediate representation.

Generated C++ code has the following structure, (All Ferret code is defined within ferret namespace. All Ferret macros starts with FERRET_.)

  • Detect Hardware
  • Include files
  • Ferret Header (src/ferret/runtime.h)
  • Ferret Native Runtime Prototypes (runtime::first, runtime::rest etc.)
  • Native Declarations
  • Object Definitions
  • Symbol Definitions
  • Native Runtime Implementations
  • Lambda Prototypes
  • Lambda Implementations
  • Ferret Main
  • Hardware Dependent Main Functions
(defmulti emit (fn [_ form _]
                 (cond (is-form? 'fir_lambda form) 'fir_lambda
                       (is-form? 'fir_lambda_stack form) 'fir_lambda_stack
                       (is-form? 'fn_multi_arity form) 'fn_multi_arity
                       (is-form? 'fir_new_lambda form) 'fir_new_lambda
                       (is-form? 'fir_new_lambda_stack form) 'fir_new_lambda_stack
                       (is-form? 'defobject form) 'defobject
                       (is-form? 'native_header form) 'native_header
                       (is-form? 'native_declare form) 'native_declare
                       (is-form? 'native_define form) 'native_define
                       (is-form? 'if form) 'if
                       (is-form? 'def form) 'def
                       (symbol? form) :symbol
                       (keyword? form) :keyword
                       (number? form) :number
                       (nil? form) :nil
                       (char? form) :char
                       (string? form) :string
                       (or (true? form) (false? form)) :boolean
                       (seq? form) :invoke-lambda)))

(defn emit-ast
  [options ast state]
  (reduce (fn[h v]
            (conj h (emit options v state)))
          [] ast))

Without preprocessing following forms,

(emit options '(list 1 2 3) (ref {}))

(emit options '(+ 1 2) (ref {}))

(emit options '(if (< a b)
                 b a)
              (ref {}))

would evaluate to,

"run(list,obj<number>(1),obj<number>(2),obj<number>(3))"
"run(+,obj<number>(1),obj<number>(2))"
"((<,b,a) ? a : b)"

So the actual compilation will just map emit to all forms passed and string-template will handle the job of putting them into an empty C++ skeleton.

(defn append-to! [r ks v]
  (let [cv (reduce (fn[h v] (v h)) @r ks)]
    (swap! r assoc-in ks (conj cv v))
    ""))
(defn emit-source [form options]
  (let [state (atom {:native-headers []
                     :native-declarations []
                     :objects []
                     :symbol-table #{}
                     :lambdas []
                     :native-defines []})
        ast (compile form options)
        body (emit-ast options ast state)]
    (when (:ast options)
      (pprint/pprint ast))
    (assoc @state :body body)))

Object Types

(defmethod emit :symbol [_ form state] (str form))

(defmethod emit :string [_ form state]
  (str "obj<string>(\"" (escape-string form) "\",(number_t)" (count form) ")"))

(defmethod emit :boolean [_ form state]
  (if (true? form)
    (str "cached::true_t")
    (str "cached::false_t")))

(defmethod emit :nil [_ form state] "nil()")

(defmethod emit :keyword [_ form _]
  (str "obj<keyword>(" (reduce (fn[h v] (+ h (int v))) 0 (str form)) ")"))

(defmethod emit :char [_ form state] (str "obj<number>((number_t)" (int form) ")"))

(defmethod emit :number [_ form state] (str "obj<number>((real_t)" (double form) ")"))

Special Forms

(defmethod emit 'def [options [_ name & form] state]
  (append-to! state [:symbol-table] name)
  (str "(" name " = " (apply str (emit-ast options form state)) ")"))

(defmethod emit 'if [options [_ cond t f] state]
  (let [cond (emit options cond state)
        t (emit options t state)
        f (if (nil? f) "nil()" (emit options f state))]
    (apply str "(" cond " ? " t " : " f ")")))

(defn defobject [name f options]
  (let [def (read-file (first f) options)]
    (render-template
     "$if(embed_type)$
        namespace runtime {
          namespace type {
             const size_t $type$ = $type_val$;}}
        $endif$
      $body$"
     :embed_type  (.contains def (str "runtime::type::" name))
     :type        (str name)
     :type_val    (gensym "")
     :body        def)))

(defmethod emit 'defobject [options [_ name & spec] state]
  (append-to! state [:objects] (defobject name spec options)))

(defmethod emit 'native_header [_ [_ & declarations] state]
  (append-to! state [:native-headers] declarations))

(defmethod emit 'native_declare [_ [_ declaration] state]
  (append-to! state [:native-declarations] declaration))

(defmethod emit 'native_define [_ [_ define] state]
  (append-to! state [:native-defines] define))

Lambdas

(defn norm-lambda-env [env]
  (->> env
       (flatten)
       (filter #(and (not (= '& %))
                     (not (= '_ %))
                     (not (= :as %))))))

(defn new-lambda-heap [l]
  (let [n (second l)
        e (norm-lambda-env (drop 2 l))]
    (if (empty? e)
      (str "obj<" n ">()")
      (str "obj<" n ">(" (apply str (interpose \, e)) ")"))))

(defn new-lambda-stack [l]
  (let [n (second l)
        e (norm-lambda-env (drop 2 l))]
    (if (empty? e)
      (str n "()")
      (str n "(" (apply str (interpose \, e)) ")"))))

(defn invoke-lambda [n args]
  (if (empty? args)
    (str "run(" n ")")
    (str "run(" n ","  (apply str (interpose \, args))")")))

Initialize function arguments. Clojure style sequential destructuring is supported.

(declare destructure-arguments)

(defn destructure-nth-rest [parent pos]
  (reduce (fn[h v] (str v "(" h ")")) parent (repeat pos "runtime::rest")))

(defn destructure-nth [parent pos]
  (str "runtime::first(" (destructure-nth-rest parent pos) ")"))

(defn destructure-get [name parent key]
  (str "const var " name " = "
       parent ".cast<d_list>()->val_at(" (emit nil key nil) ");"))

(defn new-lambda-arg [name parent pos]
  (str "const var " name " = " (destructure-nth parent pos)))

(defn new-lambda-var-arg [name parent pos]
  (str "const var " name " = " (destructure-nth-rest parent pos)))

(defn destructure-associative [name parent pos]
  (let [tmp-name (gensym)]
    [(new-lambda-arg tmp-name parent pos)
     (map (fn [[s k]] (destructure-get s tmp-name k)) name)]))

(defn destructure-sequential [args parent]
  (reduce
   (fn [h [pos name]]
     (let [name (cond (symbol? name) (new-lambda-arg name parent pos)
                      (map?    name) (destructure-associative name parent pos)
                      (coll?   name) (destructure-arguments name (destructure-nth parent pos)))]
       (conj h name))) [] args))

(defn destructure-var-args [name parent pos]
  (cond (nil?     name)  []
        (symbol?  name)  (new-lambda-var-arg name parent pos)
        (coll?    name)  (let [tmp-name (gensym)]
                           [(new-lambda-var-arg tmp-name parent pos)
                            (destructure-arguments name tmp-name)])))

(defn destructure-as-arg [name parent]
  (if (symbol?     name)
    (new-lambda-var-arg name parent 0)
    []))

(defn destructure-arguments
  ([args]
   (->> (destructure-arguments args "_args_") flatten))
  ([args parent]
   (let [t-args         args
         args           (take-while #(and (not= % '&) (not= % :as)) t-args)
         var-args       (->> t-args (drop-while #(not= % '&)) second)
         as-arg         (->> t-args (drop-while #(not= % :as)) second)
         args-indexed   (->>  args
                              (map-indexed (fn [p v] [p v]))
                              (filter #(not= (second %) '_)))
         as-arg         (destructure-as-arg as-arg parent)
         var-args       (destructure-var-args var-args parent (count args))
         args           (destructure-sequential args-indexed parent)]
     [args var-args as-arg])))
(defmethod emit :invoke-lambda [options [fn & args] state]
  (invoke-lambda (emit options fn state) (emit-ast options args state)))

(defmethod emit 'fir_new_lambda [_ f state]
  (new-lambda-heap f))

(defmethod emit 'fir_new_lambda_stack [_ f state]
  (new-lambda-stack f))

(defn emit-lambda [options name env args body state]
  (let [native-declarations (filter #(is-form? 'native_declare %) body)
        body (filter #(not (is-form? 'native_declare %)) body)
        body (cond  (empty? body)
                    ["nil()"]
                    (and (= 1 (count body))
                         (seq? (first body))
                         (= 'fn_multi_arity (first (first body))))
                    [(emit options (first body) state) "nil()"]
                    (and (= 1 (count body))
                         (string? (first body)))
                    (let [body (first body)]
                      (if (.contains body "__result")
                        ["var __result" body "__result"]
                        [body "nil()"]))
                    :default (emit-ast options body state))
        env  (norm-lambda-env env)
        vars (destructure-arguments args)]
    (doseq [dec native-declarations] 
      (emit options dec state))
    {:name name :env env :args args :vars vars :body body}))

(defmethod emit 'fir_lambda [options [_ name env args & body] state]
  (append-to! state [:lambdas] (emit-lambda options name env args body state)))

(defmethod emit 'fir_lambda_stack [options [_ name env args & body] state]
  (append-to! state [:lambdas] (-> (emit-lambda options name env args body state)
                                   (assoc :stack true))))
(defmethod emit 'fn_multi_arity [_ [_ switch default] state]
  (let [default (if default
                  (new-lambda-stack default))
        switch  (map (fn [[s f]] {:fn (new-lambda-stack f) :case s}) switch)]
    (render-template
     "switch(runtime::count(_args_)) {

      $fns: {fn|
         case $fn.case$ :
           return $fn.fn$.invoke(_args_);
      };separator=\"\n\"$

      $if(default)$
         default:
           return $default$.invoke(_args_);
      $endif$
      }"
     :fns     switch
     :default default)))
(defn lambda-definitions [fns]
  (render-template
   "$fns: {fn|
      $if(!fn.stack)$
       class $fn.name$ final : public lambda_i{
      $else$
       class $fn.name$  \\{
      $endif$
        $fn.env:{const var $it$;} ;separator=\"\n\"$
      public:
        $if(fn.env)$
          explicit $fn.name$ ($fn.env:{var const & $it$} ;separator=\",\"$) :
            $fn.env:{$it$($it$)} ;separator=\",\"$ { }
        $endif$

        var invoke (var const & _args_) const $if(!fn.stack)$ final $endif$ ;
      };};separator=\"\n\n\"$"
   :fns fns))

(defn lambda-implementations [fns]
  (render-template
   "$fns: {fn|
      inline var $fn.name$::invoke (var const & _args_) const {
        (void)(_args_);
        $fn.vars:{$it$;} ;separator=\"\n\"$

        $trunc(fn.body):{$it$;} ;separator=\"\n\"$
        return $last(fn.body):{$it$;} ;separator=\"\n\"$
      }
     };separator=\"\n\n\"$"
   :fns fns))

Program

(defn program-template [source]
  (let [{:keys [body lambdas symbol-table native-headers objects
                native-declarations native-defines]} source
        native-headers (->> native-headers flatten (into #{}))]
    (render-template
     "
        $native_defines:{$it$} ;separator=\"\n\"$
        $native_headers:{#include \"$it$\"} ;separator=\"\n\"$

        $ferret_h$

        // Objects
        namespace ferret{
         $objects:{$it$} ;separator=\"\n\"$
        }

        // Symbols
        namespace ferret{
         $symbols:{var $it$;} ;separator=\"\n\"$
        }

        $native_declarations:{$it$} ;separator=\"\n\"$

        // Runtime Implementations
        $ferret_cpp$

        // Lambda Prototypes
        namespace ferret{
          $lambda_classes:{$it$} ;separator=\"\n\"$
        }

        // Command Line Arguments
        #if defined(FERRET_STD_LIB) &&                    \\
            !defined(FERRET_DISABLE_CLI_ARGS) &&   \\
            !defined(FERRET_DISABLE_STD_MAIN)
          ferret::var _star_command_line_args_star_;
        #endif

        // Lambda Implementations
        namespace ferret{
          $lambda_bodies:{$it$} ;separator=\"\n\"$
        }

        // Program Run
        namespace ferret{
         namespace program{
          void run(){
           $body:{$it$;} ;separator=\"\n\"$ 
          }
         }
        }

        $ferret_main$"
     :native_defines       native-defines
     :ferret_h             (read-file "ferret/runtime.h")
     :native_headers       native-headers
     :objects              objects
     :symbols              symbol-table
     :native_declarations  native-declarations
     :ferret_cpp           (read-file "ferret/runtime.cpp")
     :lambda_classes       (lambda-definitions lambdas)
     :lambda_bodies        (lambda-implementations lambdas)
     :body                 (filter #(not (empty? %)) body)
     :ferret_main          (read-file "ferret/main.cpp"))))

Main

Options

Default compile options,

(defn compile-options [& [options]]
  (merge {:compiler "g++"
          :compiler-options ["-std=c++11"]
          :source-extension default-cpp-extension
          :base-name "solution"}
         options))

(defn cpp-file-name [options]
  (str (:output-path options) (:base-name options) "." (:source-extension options)))

Read the cpp file parse build options embedded in it. configure-ferret! macro can embed build options into C++ files. These can be used later when build the binary.

(defn compile-options-parse-source [file]
  (try
    (let [program (slurp file)
          options (->> program
                       (re-seq #"(?s)build-conf-begin.*?//(.*?)// build-conf-end")
                       (map second)
                       (map #(.replaceAll % "//" ""))
                       (map #(.replaceAll % "\n" " "))
                       (map read-string))
          keys (->> options
                    (map #(keys %))
                    flatten
                    (into #{})
                    (into []))
          combine (fn [key]
                    (->> options
                         (reduce (fn[h v]
                                   (if (nil? (key v))
                                     h
                                     (apply merge (flatten [h (key v)])))) #{})
                         (into [])))]
      (compile-options
       (reduce (fn[h v]
                 (assoc h v (combine v))) {} keys)))
    (catch Exception e
      (compile-options {}))))

Takes the compiler CLI arguments and a file name, returns a map of build options.

(defn build-specs [input args]
  (fn []
    (let [output (if (->> args :options :output)
                   (->> args :options :output)
                   input)
          output-path (file-path output)
          output-extension (if (->> args :options :output)
                             (file-extension output)
                             default-cpp-extension)
          base-name (file-base-name output)
          input-path (file-path input)
          default-compiled-file (make-file output-path base-name output-extension)
          default-options (compile-options-parse-source default-compiled-file)]

      (-> default-options
          (assoc :input-file input)
          (assoc :base-name base-name)
          (assoc :path input-path)
          (assoc :output-path output-path)
          (assoc :source-extension output-extension)
          (assoc :ast (->> args :options :ast))
          (assoc :compile-program (->> args :options :compile))
          (assoc :release (->> args :options :release))
          (assoc :format-code (not (->> args :options :disable-formatting)))
          (assoc :global-functions (->> args :options :global-functions))
          (assoc :extra-source-files
                 (cond (not (empty? (:arguments args)))
                       (:arguments args)
                       (not (empty? (:extra-source-files default-options)))
                       (:extra-source-files default-options)
                       :default []))))))

Compile to C++

Compile the form to C++,

(defn compile->cpp [form options]
  (let [file-name (cpp-file-name options)
        source    (emit-source form options)
        program   (program-template source)]
    (write-to-file file-name program)
    (info "compiled" "=>" file-name)
    true))

Compile to Binary

Pick compiler to use. If set, use the value of CXX environment variable, if not set use the default compiler gcc,

(defn cxx-compiler [options]
  (let [compiler    (if (System/getenv "CXX")
                      (System/getenv "CXX")
                      (:compiler options))
        env-options (if (System/getenv "CXXFLAGS")
                      (seq (.split (System/getenv "CXXFLAGS") " ")))
        options     (->> (:compiler-options options) (map str))]
    [compiler (concat options env-options)]))

Compiler build command,

(defn cxx-command [options]
  (if (:command options)
    (flatten ["/usr/bin/env" "sh" "-c" (:command options)])
    (let [[cxx cxx-options] (cxx-compiler options)
          source-files  (map #(let [extension (file-extension %)]
                                [(cond (= extension "c") ["-x" "c"]
                                       (= extension "c++") ["-x" "c++"]
                                       :default "")
                                 %])
                             (:extra-source-files options))]
      (flatten [cxx cxx-options source-files ["-x" "c++"] (cpp-file-name options)]))))

Run the compiler on the generated source and create the binary,

(defn compile->binary [options]
  (let [command (cxx-command options)]
    (info "building" "=>" (apply str (interpose " " command)))
    (let [build-dir (:output-path options)
          ret (try
                (with-sh-dir build-dir
                  (apply sh command))
                (catch Exception e
                  (warn (str "error executing C++ compiler."))
                  (warn (str "" (.getMessage e)))
                  (System/exit 1)))]
      (if (not= 0 (:exit ret))
        (do (warn "build error")
            (warn (:err ret))
            (System/exit 1)))
      true)))

Build Solution

Compile and build program,

(defn clang-format [options]
  (let [file (cpp-file-name options)
        source (try (with-sh-dir "./"
                      (sh "clang-format" "-style" "{Standard: Cpp11}" file))
                    (catch Exception e nil))]
    (if source
      (do (info "formatting code")
          (write-to-file file (:out source)))
      (trace "install clang-format for formatted output (optional)"))))

(defn build-solution [spec-fn]
  (let [{:keys [input-file compile-program format-code path]} (spec-fn)]
    (info "dir =>" path)
    (info "file =>" input-file)

    (compile->cpp (read-clojure-file input-file) (spec-fn))

    (when format-code
      (clang-format (spec-fn)))

    (when compile-program
      (compile->binary (spec-fn)))))

Compiler Main

Compiler options,

(def program-options [["-i" "--input FILE" "Input File" :default "./core.clj"]
                      ["-o" "--output FILE" "Output File"]
                      ["-c" "--compile" "Compile to Binary"]
                      ["-w" "--watch-input" "Automatically Recompile Input File on Change."]
                      [nil "--release" "Compile in Release Mode. Strip Debug Information."]
                      [nil "--disable-formatting" "Disables Solution Formatting Using clang-format."]
                      [nil "--global-functions" "Disables replace-fn-call-sites Optimization."]
                      [nil "--ast" "Print Intermediate AST."]
                      ["-h" "--help" "Print Help"]])

Compiler main,

(defn -main [& args]
  (let [args (parse-opts args program-options)
        {:keys [help input watch-input]} (:options args)]

    (when help
      (try
        (let [version (read-file "build.info")]
          (print "ferret-lisp build:" version))
        (catch Exception e
          (print "ferret-lisp")))
      (println )
      (println )
      (println (:summary args))
      (System/exit 0))

    (when (not (file-exists input))
      (warn "no input file")
      (System/exit 1))

    (let [specs (build-specs input args)]
      (if (not watch-input)
        (build-solution specs)
        (do (watcher/watcher [input]
                             (watcher/rate 1000)
                             (watcher/on-change
                              (fn [_] (build-solution specs))))
            @(promise)))
      (shutdown-agents))))

Logging

(def log-formatter (proxy [java.util.logging.Formatter] []
                     (format
                       [^java.util.logging.LogRecord record]
                       (let [level (-> record .getLevel .toString clojure.string/lower-case)
                             level (if (or (= :unix (os-name))
                                           (= :mac (os-name))
                                           (= :solaris (os-name)))
                                     (if (= level "warning")
                                       (color/red level)
                                       (color/green level))
                                     level)
                             now (.getTime (java.util.Calendar/getInstance))
                             frmtr (java.text.SimpleDateFormat. "HH:mm:ss")]
                         (str (.format frmtr now) " " level " " (.getMessage record) "\n")))))

(def log-handler (proxy [java.util.logging.Handler] []
                   (publish [^java.util.logging.LogRecord record]
                     (when (and (.isLoggable ^java.util.logging.Handler this record)
                                (instance? java.io.PrintWriter *out*))
                       (.print ^java.io.PrintWriter *out* 
                               (.format ^java.util.logging.Formatter log-formatter record))))
                   (flush [] (.flush ^java.io.PrintWriter *out*))
                   (close [] 
                     ;;(.close *out*)
                     )))

(.addHandler (java.util.logging.Logger/getLogger "") log-handler)

(let [^java.util.logging.LogManager$RootLogger logger (java.util.logging.Logger/getLogger "")]
  (doseq [^java.util.logging.Handler handler (.getHandlers logger)]
    (. handler setFormatter log-formatter)))

(defn set-log-level! [& [level]]
  (let [^java.util.logging.LogManager$RootLogger logger
        (java.util.logging.Logger/getLogger "")
        level (cond (nil? level) java.util.logging.Level/ALL
                    (= level :trace) java.util.logging.Level/FINEST
                    (= level :debug) java.util.logging.Level/FINE
                    (= level :info) java.util.logging.Level/INFO
                    (= level :warn) java.util.logging.Level/WARNING)]

    (.setLevel logger level)
    (doseq [^java.util.logging.Handler handler (.getHandlers logger)]
      (. handler setLevel level))))

(set-log-level! :info)

Native Core

Runtime needed on the C++ side to support Clojure Core. Object system, garbage collection,memory pooling and host specific initialization code. (ie. printing on different embedded systems.)

Object System

All Ferret objects derive from a Base class.

Built in objects,

Built in interfaces,

Base

All our types are derived from the base Object type. Which is a typedef of obj::base<FERRET_RC_POLICY,FERRET_ALLOC_POLICY>. See Reference Counting for available reference counting policies and Memory Allocation for available allocation policies.

class var;
class seekable_i;

namespace object{
  template <typename rc>
  class base : public rc{
  public:
    base() { }
    virtual ~base() { };

    virtual size_t type() const = 0;

#if !defined(FERRET_DISABLE_STD_OUT)
    virtual void stream_console() const = 0;
#endif

    virtual bool equals(var const & o) const = 0;

    virtual seekable_i* cast_seekable_i() { return nullptr; }

    void* operator new(size_t, void* ptr){ return ptr; }
    void  operator delete(void * ptr){ FERRET_ALLOC_POLICY::free(ptr); }
  };
}

typedef object::base<FERRET_RC_POLICY> object_t;

A var holds a pointer to an objectt, everything is passed around as vars it is responsible for incrementing/decrementing the reference count, when it reaches zero it will automatically free the objectt.

class var{
public:
  explicit var(object_t* o = nullptr) : obj(o) { inc_ref(); }

  var(const var& o) : obj(o.obj) { inc_ref(); }
  var(var&& o) : obj(o.obj) { o.obj = nullptr; }

  ~var() { dec_ref(); }

  var& operator=(var&& other){
    if (this != &other){
      dec_ref();
      obj = other.obj;
      other.obj = nullptr;
    }
    return *this;
  }

  var& operator= (const var& other){
    if (obj != other.obj){
      dec_ref();
      obj = other.obj;
      inc_ref();
    }
    return *this;
  }

  bool equals (var const & rhs) const;

  bool operator==(const var& other) const { return equals(other); }

  bool operator!=(const var& other) const { return !equals(other); }

  operator bool() const;

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const {
    if (obj != nullptr )
      obj->stream_console();
    else
      runtime::print("nil");
  }
#endif

  inline object_t* get() const { return obj; }

  template<typename T>
  inline T* cast() const { return static_cast<T*>(obj); }

  inline bool is_type(size_t type) const { 
    return (static_cast<object_t*>(obj)->type() == type);
  }

  inline bool is_nil() const { return (obj == nullptr); }

private:
  inline void inc_ref(){
#if !defined(FERRET_DISABLE_RC)
    // Only change if non-null
    if (obj) obj->inc_ref();
#endif
  }

  inline void dec_ref(){
#if !defined(FERRET_DISABLE_RC)
    // Only change if non-null
    if (obj){
      // Subtract and test if this was the last pointer.
      if (obj->dec_ref()){
        delete obj;
        obj = nullptr;
      }
    }
#endif
  }

  object_t* obj;
};

template<>
inline seekable_i* var::cast<seekable_i>() const { return obj->cast_seekable_i(); }

All object allocations are done using obj function. It will return a new var containing a pointer to an Object. nil is represented as a var pointing to nullptr.

var two = obj<number>(2);
var some_nil = nil();
template<typename FT, typename... Args>
inline var obj(Args... args) {
  void * storage = FERRET_ALLOC_POLICY::allocate<FT>();
  return var(new(storage) FT(args...));
}

inline var nil(){
  return var();
}

Objects

Boolean

A boolean object,

(defobject boolean "ferret/obj/boolean_o.h")
class boolean final : public object_t {
  const bool value;
public:

  size_t type() const final { return runtime::type::boolean; }

  bool equals(var const & o) const final {
    return (value == o.cast<boolean>()->container());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    if (value)
      runtime::print("true");
    else
      runtime::print("false");
  }
#endif

  explicit boolean(bool b) : value(b) {} 

  bool container() const {
    return value;
  }
};

namespace cached{
  const var true_t = obj<ferret::boolean>(true);
  const var false_t = obj<ferret::boolean>(false);
}

var::operator bool() const {
  if (obj == nullptr)
    return false;
  else if (obj->type() == runtime::type::boolean)
    return static_cast<boolean*>(obj)->container();
  else
    return true;
}

bool var::equals (var const & other) const {
  if ( ( is_nil() && !other.is_nil()) ||
       (!is_nil() &&  other.is_nil()))
    return false;

  if (get() == other.get())
    return true;

  if (runtime::is_seqable(*this) && runtime::is_seqable(other))
    return get()->equals(other);
  else if (obj->type() != other.cast<object_t>()->type())
    return false;
  else
    return get()->equals(other);
}
Pointer

A pointer object keeps a reference to a C++ pointer.

var num = obj<pointer>(new int(42));
int *ptr = pointer::to_pointer<int>(ptr);
(defobject pointer "ferret/obj/pointer_o.h")
class pointer final : public object_t {
  void * _payload;
public:


  size_t type() const final { return runtime::type::pointer; }

  bool equals(var const & o) const final {
    return (_payload == o.cast<pointer>()->payload());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print("pointer<");
    runtime::print(_payload);
    runtime::print(">");
  }
#endif

  explicit pointer(void* p) : _payload(p) {} 

  void* payload() const {
    return _payload;
  }
  template<typename T> static T* to_pointer(var const & v){
    return ((T *) v.cast<pointer>()->payload());
  }
  template<typename T> static T& to_reference(var const & v){
    return (*(pointer::to_pointer<T>(v)));
  }
};

A value object keeps a native object. Useful when working with modern C++ libraries that use smart pointers for memory management.

(native-declare "class data{ 
                   int x;
                 public: 

                   explicit data(int _x) : x(_x) {} 

                   int  content() { return x; }
                   void inc() { x++; }
                 };")

(defn make-data [x]
  "__result = obj<value<data>>(number::to<int>(x))")

(defn get-data [x]
  "__result = obj<number>((number_t) value<data>::to_value(x).content());")

(defn inc-data [x]
  "data & d = value<data>::to_reference(x);
   d.inc();")
(defobject value "ferret/obj/value_o.h")
template <typename T>
class value final : public object_t {
  T _value;
 public:

  size_t type() const final { return runtime::type::value; }

  bool equals(var const & o) const final {
    return (this == o.get());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print("value<");
    const void* addr = this;
    runtime::print(addr);
    runtime::print(">");
  }
#endif

  template <typename... Args>
  explicit value(Args&&... args) : _value(static_cast<Args&&>(args)...) { } 

  T to_value() const {
    return _value;
  }

  static T to_value(var const & v){
    return v.cast<value<T>>()->to_value();
  }

  T & to_reference() {
    return _value;
  }

  static T & to_reference(var const & v) {
    return v.cast<value<T>>()->to_reference();
  }  
};
Number

In the interest of simplicity Ferret supports only one type of number: floating point numbers. By default these are double precision floating point numbers. However Ferret programs can easily be recompiled to support any real number type the system supported.

Default number configuration,

namespace ferret{
#if !defined(FERRET_NUMBER_TYPE)
   #define FERRET_NUMBER_TYPE int
#endif

#if !defined(FERRET_REAL_TYPE)
   #define FERRET_REAL_TYPE   double
#endif

#if !defined(FERRET_REAL_EPSILON)
   #define FERRET_REAL_EPSILON   0.00001
#endif

  typedef FERRET_NUMBER_TYPE           number_t;                   // Whole number Container.
  typedef FERRET_REAL_TYPE             real_t;                     // Real number Container.
  const   real_t                       real_epsilon(FERRET_REAL_EPSILON);
#if !defined(FERRET_DISABLE_STD_OUT)
  const   size_t                       number_precision = 4;       // number Format String (fprinf)
#endif

  constexpr auto operator "" _pi(long double x) -> double {
    return 3.14159265358979323846 * (double)x;
  }

  constexpr auto operator "" _pi(unsigned long long int  x) -> double {
    return 1.0_pi * (double)x;
  }

  constexpr auto operator "" _deg(long double x) -> double {
    return (1.0_pi * (double)x) / 180;
  }

  constexpr auto operator "" _deg(unsigned long long int  x) -> double {
    return 1.0_deg * (double)x;
  }
}

Helper functions,

namespace runtime{
  #undef min
  #undef abs

  template<typename T>
  constexpr T min(T a, T b){
    return ((a) < (b) ? (a) : (b));
  }

  template<typename T>
  constexpr T abs(T a){
    return ((a) < (T)0 ? -(a) : (a));
  }
}

number Object,

(defobject number "ferret/obj/number_o.h")
class number final : public object_t {
  const real_t _word;
public:


  size_t type() const final { return runtime::type::number; }

  bool equals(var const & o) const final {
    if (runtime::abs(_word - o.cast<number>()->word()) < real_epsilon)
      return true;
    else
      return false;
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print(_word);
  }
#endif

  template<typename T> explicit number(T x) : _word((real_t)x) {} 

  real_t word() const {
    return _word;
  }

  template<typename T> T as() const {
    T::unimplemented_function;
  }

  var add(var const & v) const {
    return obj<number>(_word + v.cast<number>()->word());
  }
  var sub(var const & v) const {
    return obj<number>(_word - v.cast<number>()->word());
  }
  var mul(var const & v) const {
    return obj<number>(_word * v.cast<number>()->word());
  }
  var div(var const & v) const {
    return obj<number>(_word / v.cast<number>()->word());
  }
  var is_smaller(var const & v) const {
    return obj<boolean>(_word < v.cast<number>()->word());
  }
  var is_smaller_equal(var const & v) const {
    return obj<boolean>(_word <= v.cast<number>()->word());
  }
  var is_bigger(var const & v) const {
    return obj<boolean>(_word > v.cast<number>()->word());
  }
  var is_bigger_equal(var const & v) const {
    return obj<boolean>(_word >= v.cast<number>()->word());
  }

  template<typename T> static T to(var const & v){
    return (T)v.cast<number>()->word();
  }
};

A fixed point number, like a floating point number, is an approximate representation of a rational number. Unlike floating point numbers exponent in a fixed point numbers is constant, this allows fixed point numbers to be represented internally as integers and the operations on fixed point numbers can be performed using integer arithmetic. This can often improve the speed of arithmetic operation on embedded systems without a built in FPU.

Fixed point numbers can be enabled by overriding the FERRET_REAL_TYPE definition. Following defines fixed point numbers as 32 bit integers with 8 bits used as fractional part.

(configure-runtime! FERRET_REAL_TYPE "ferret::fixed_real<32,8>")

or you can automatically calculate required fraction bits using a literal. Following defines a 32 bit fixed_real with 0.01 fractional accuracy using 6 bits for fraction.

(configure-runtime! FERRET_REAL_TYPE "ferret::fixed_real<32,0.01_QN>")
#if !defined(__clang__)
constexpr auto operator "" _QN(long double x) -> int {
  return (int)::floor(::log(1.0/(double)x)/::log(2));
}
#endif

template<int bits> struct fixed_real_container;
template<> struct fixed_real_container<8>  { typedef int8_t  base_type;
                                             typedef int16_t next_type; };
template<> struct fixed_real_container<16> { typedef int16_t base_type;
                                             typedef int32_t next_type; };
template<> struct fixed_real_container<32> { typedef int32_t base_type;
                                             typedef int64_t next_type; };
template<> struct fixed_real_container<64> { typedef int64_t base_type;
                                             typedef int64_t next_type; };

template<int bits, int exp>
class fixed_real{
  typedef fixed_real fixed;
  typedef typename fixed_real_container<bits>::base_type base;
  typedef typename fixed_real_container<bits>::next_type next;

  base m;
  static const int N      = (exp - 1);
  static const int factor = 1 << N;

  template<typename T>
  inline T to_rational() const { return T(m) / factor; }

  template<typename T>
  inline base from_rational(T d) const { return (base)(d * factor); }

  template<typename T>
  inline base from_whole(T i) const { return ((base)i << N); }

  template<typename T>
  inline T to_whole() const { return (T)(m >> N); }

public:

  //from types
  explicit fixed_real( )           : m(0) { }
  template<typename T>
  explicit fixed_real(T v)         : m(from_whole<T>(v)) {}
  explicit fixed_real(double d)    : m(from_rational<double>(d)) { }

  template<typename T>
  fixed& operator=(T v)        { m = from_whole<T>(v); return *this; }
  fixed& operator=(double v)   { m = from_rational<double>(v); return *this; }

  //to types
  template<typename T>
  operator T()           const { return to_whole<T>();    }
  operator double()      const { return to_rational<double>(); }

  // operations
  fixed& operator+= (const fixed& x) { m += x.m; return *this; }
  fixed& operator-= (const fixed& x) { m -= x.m; return *this; }
  fixed& operator*= (const fixed& x) { m = (base)(((next)m * (next)x.m) >> N); return *this; }
  fixed& operator/= (const fixed& x) { m = (base)(((next)m << N) / x.m); return *this; }
  fixed& operator*= (int x)          { m *= x; return *this; }
  fixed& operator/= (int x)          { m /= x; return *this; }
  fixed  operator-  ( )              { return fixed(-m); }

  // friend functions
  friend fixed operator+ (fixed x, const fixed& y) { return x += y; }
  friend fixed operator- (fixed x, const fixed& y) { return x -= y; }
  friend fixed operator* (fixed x, const fixed& y) { return x *= y; }
  friend fixed operator/ (fixed x, const fixed& y) { return x /= y; }

  // comparison operators
  friend bool operator== (const fixed& x, const fixed& y) { return x.m == y.m; }
  friend bool operator!= (const fixed& x, const fixed& y) { return x.m != y.m; }
  friend bool operator>  (const fixed& x, const fixed& y) { return x.m > y.m; }
  friend bool operator<  (const fixed& x, const fixed& y) { return x.m < y.m; }
  friend bool operator>= (const fixed& x, const fixed& y) { return x.m >= y.m; }
  friend bool operator<= (const fixed& x, const fixed& y) { return x.m <= y.m; }

#if defined(FERRET_STD_LIB)
  friend std::ostream& operator<< (std::ostream& stream, const fixed& x) {
    stream << (double)x;
    return stream;
  }
#endif
};
Sequence

Linked list container implementing the seekable interface.

(defobject empty_sequence "ferret/obj/empty_sequence_o.h")
(defobject sequence "ferret/obj/sequence_o.h")
class empty_sequence final : public object_t {
public:

  size_t type() const final { return runtime::type::empty_sequence; }

  bool equals(var const & ) const final {
    return true;
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print("()");
  }
#endif
};

namespace cached{
  const var empty_sequence = obj<ferret::empty_sequence>();
}
class sequence final : public object_t, public seekable_i {
  const var next;
  const var data;
public:

  size_t type() const final { return runtime::type::sequence; }

  bool equals(var const & o) const final {
    if(first() != runtime::first(o))
      return false;

    for(auto const& it : runtime::range_pair(rest(),runtime::rest(o)))
      if (it.first != it.second)
        return false;

    return true;
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print("(");
    data.stream_console();
    for(auto const& i : runtime::range(next)){
      runtime::print(" ");
      i.stream_console();
    }
    runtime::print(")");
  }
#endif

  explicit sequence(var const & d = nil(), var const & n = nil()) : next(n), data(d) {} 

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(var const & x) final {
    return obj<sequence>(x, var(this));
  }
  var first() const final {
    return data;
  }
  var rest() const final {
    return next;
  }
  template <typename T>
  static T to(var const & ){
    T::unimplemented_function;
  }
  template <typename T>
  static var from(T){
    T::unimplemented_function; return nil();
  }

};
namespace runtime {
  inline var list() { 
    return cached::empty_sequence;
  }
  inline var list(var const & v) { 
    return obj<sequence>(v,nil());
  }

  template <typename... Args>
  inline var list(var const & first, Args const & ... args) { 
    return obj<sequence>(first, list(args...));
  }
}

#ifdef FERRET_STD_LIB
typedef ::std::vector<var>  std_vector;

template <> std_vector sequence::to(var const & v) { 
  std_vector ret;
  for(auto const& it : runtime::range(v))
    ret.push_back(it);
  return ret;
}

template <> var sequence::from(std_vector v) { 
  var ret;
  for(auto const& it : v)
    ret = runtime::cons(it,ret);
  return ret;
}
#endif
Lazy Sequence

A lazy list container implementing the seekable interface.

(defobject lazy_sequence "ferret/obj/lazy_sequence_o.h")
class lazy_sequence final : public object_t, public seekable_i {
  const var thunk;
  const var head;
public:

  size_t type() const final { return runtime::type::lazy_sequence; }

  var sval() const {
    if (head.is_nil())
      return runtime::first(run(thunk));

    return head;
  }

  bool equals(var const & o) const final {
    if(sval() != runtime::first(o))
      return false;

    for(auto const& it : runtime::range_pair(rest(),runtime::rest(o)))
      if (it.first != it.second)
        return false;

    return true;
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print("(");
    sval().stream_console();
    for(auto const& i : runtime::range(rest())){
      runtime::print(" ");
      i.stream_console();
    }
    runtime::print(")");
  }
#endif

  explicit lazy_sequence(var const & t) : thunk(t) {} 
  explicit lazy_sequence(var const & h, var const & t) : thunk(t), head(h) {} 

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(var const & x) final {
    return obj<lazy_sequence>(x,thunk);
  }
  var first() const final {
    return sval();
  }
  var rest() const final {
    if (head.is_nil())
      return runtime::rest(run(thunk));

    return run(thunk);
  }
};
(defn new-lazy-seq [f]
  "__result = obj<lazy_sequence>(f);")

(defmacro lazy-seq [& body]
  `(~'new-lazy-seq (~'fn [] ~@body)))
D-List

D-List, or Detached List, analogous to an A-List or a P-List are more suited to embedded systems. For quite small values of n it is more efficient in terms of time and space than more sophisticated strategies such as hash tables.

A D-list is a cons of a list of keys and a list of values, i.e.:

((key1 key2 ...) val1 val2 ...)
(defobject d-list "ferret/obj/d_list_o.h")

(defn new-d-list-aux []
  "__result = obj<d_list>();")

(defmacro new-d-list [& args]
  `(~'-> (~'new-d-list-aux)
         ~@(map (fn [v]
                  (let [[k v] v]
                    (list 'assoc k v)))
                (partition 2 args))))

(defn assoc [m k v]
  "__result = m.cast<d_list>()->assoc(k,v);")

(defn dissoc [m k]
  "__result = m.cast<d_list>()->dissoc(k);")

(defn get [m & args]
  "__result = m.cast<d_list>()->val_at(args);")

(defn vals [m]
  "__result = m.cast<d_list>()->vals();")

(defn keys [m]
  "__result = m.cast<d_list>()->keys();")
class d_list final : public lambda_i, public seekable_i {

  var data;

  number_t val_index(var const & k) const {
    var keys = runtime::first(data);

    for(auto i : runtime::range_indexed(keys))
      if ( i.value == k )
        return i.index;

    return -1;
  }

public:

  size_t type() const final { return runtime::type::d_list; }

  bool equals(var const & o) const final {
    return (this == o.get());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    data.stream_console();
  }
#endif

  explicit d_list() : data(runtime::list(runtime::list())) { }
  explicit d_list(var const & l) : data(l) { }

  var assoc(var const & k, var const & v) const {
    var keys = runtime::first(data);
    var values = runtime::rest(data);

    values = runtime::cons(v,values);
    keys   = runtime::cons(k,keys);

    return obj<d_list>(runtime::cons(keys,values));
  }

  var dissoc(var const & k) const {
    number_t idx = val_index(k);

    if ( idx == -1 )
      return obj<d_list>(data);

    var keys = runtime::first(data);
    var values = runtime::rest(data);

    var new_keys;
    for(auto i : runtime::range_indexed(keys))
      if ( i.index != idx)
        new_keys = runtime::cons(i.value, new_keys);

    var new_values;
    for(auto i : runtime::range_indexed(values))
      if ( i.index != idx)
        new_values = runtime::cons(i.value, new_values);

    return obj<d_list>(runtime::cons(new_keys,new_values));
  }

  var val_at(var const & args) const {
    var key = runtime::first(args);
    var not_found = runtime::first(runtime::rest(args));

    var values = runtime::rest(data);
    number_t idx = val_index(key);

    if ( idx == -1 ){
     if ( !not_found.is_nil() ){
      return not_found;
     }else{
      return nil();  
     }
    }

    for(number_t i = 0; i < idx; i++)
      values = runtime::rest(values);

    return runtime::first(values);
  }

  var invoke(var const & args) const final {
    return val_at(args);
  }

  var vals () const { return runtime::rest(data);}
  var keys () const { return runtime::first(data);}

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(var const & v) final {
    return runtime::list(v,data);
  }

  var first() const final {
    var keys = runtime::first(data);
    var values = runtime::rest(data);
    return runtime::list(runtime::first(keys),runtime::first(values));
  }

  var rest() const final {
    var keys = runtime::first(data);
    var values = runtime::rest(data);

    if(runtime::rest(keys) == nil())
      return runtime::list();

    return obj<d_list>(runtime::cons(runtime::rest(keys),runtime::rest(values)));
  }
};
Keyword

Each keyword in the program is converted to an keyword object. A keyword holds a simple hash of the keyword as an integer.

(defobject keyword "ferret/obj/keyword_o.h")
class keyword final : public lambda_i {
  const number_t _word;

  number_t from_str(const char * str){
    number_t word = 0;
    for (number_t i = 0; str[i] != '\0'; i++){
      word = word + (number_t)str[i];
    }

    return word;
  }

public:

  size_t type() const final { return runtime::type::keyword; }

  bool equals(var const & o) const final {
    return (_word == o.cast<keyword>()->word());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print(_word);
  }
#endif

  explicit keyword(number_t w) : _word(w) {} 
  explicit keyword(const char * str): _word(from_str(str)) { }

  number_t word() const {
    return _word;
  }

  var invoke(var const & args) const {
    var map = runtime::first(args);
    var map_args = runtime::cons(var((object_t*)this), runtime::rest(args));

    if (map.is_type(runtime::type::d_list)){
      return map.cast<d_list>()->val_at(map_args);
    }

    return nil();
  }
};
String

Strings are represented as a linked list of numbers each representing a character.

(defobject string "ferret/obj/string_o.h")

Defines a function that returns a given string. Can be used to return strings from functions. Due to the way FFI interface is designed strings can not be returned from functions because they are interpreted as FFI calls.

(defmacro new-string [& ss]
  (let [s (apply str ss)]
    `((~'fn [] ~(str "__result = obj<string>(\"" s "\");")))))
class string final : public object_t, public seekable_i {
  var data;

  void from_char_pointer(const char * str, int length){
    for (int i = --length; i >= 0; i--)
      data = runtime::cons(obj<number>((number_t)str[i]),data);
  }

public:

  size_t type() const final { return runtime::type::string; }

  bool equals(var const & other) const final {
    return (container() == other.cast<string>()->container());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    for(auto const& it : runtime::range(data))
      runtime::print(number::to<char>(it));
  }
#endif

  explicit string() : data(nullptr) {} 

  explicit string(var const & s) : data(s) {}

  explicit string(const char * str) {
    int length = 0;
    for (length = 0; str[length] != '\0'; ++length);
    from_char_pointer(str,length);
  }

  explicit string(const char * str,number_t length) { from_char_pointer(str,length); }

  var container() const {
    return data;
  }

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(var const & x) final {
    return obj<string>(runtime::cons(x,data));
  }

  var first() const final {
    return runtime::first(data);
  }

  var rest() const final {
    if (!runtime::rest(data).is_nil())
      return obj<string>(runtime::rest(data));

    return cached::empty_sequence;
  }

  template <typename T>
  static T to(var const & ){
    T::unimplemented_function;
  }

};

#ifdef FERRET_STD_LIB
template<>
inline var obj<string>(std::string s) {
  void * storage = FERRET_ALLOC_POLICY::allocate<string>();
  return var(new(storage) string(s.c_str(), (number_t)s.size()));
}

template <> ::std::string string::to(var const & v) { 
  ::std::stringstream ss;
  for(auto const& it : runtime::range(v.cast<string>()->container()))
    ss << number::to<char>(it);
  return ss.str();
}
#endif
Atom

Mimics Clojure's atom. It is thread safe when used on system where FERRET_STD_LIB is defined.

(defobject atomic "ferret/obj/atomic_o.h")
class atomic final : public deref_i {
  var data;
  mutex lock;
  public:


  size_t type() const final { return runtime::type::atomic; }

  bool equals(var const & o) const final {
    return (this == o.cast<atomic>());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print("atom <");
    data.stream_console();
    runtime::print(">");
  }
#endif

  explicit atomic(var const & d) : data(d) {} 

  var swap(var const & f,var const & args){
    lock_guard guard(lock);
    data = f.cast<lambda_i>()->invoke(runtime::cons(data, args));
    return data;
  }
  var deref() {
    lock_guard guard(lock);
    return data;
  }
};

Operations on atoms

(defn atom [x]
  "__result = obj<atomic>(x)")

(defn swap! [a f & args]
  "__result = a.cast<atomic>()->swap(f,args);")

(defn reset! [a newval]
  (swap! a (fn [old curr] curr) newval))
Future

Takes a body of expressions and yields a future object that will invoke the body in another thread, and will cache the result and return it on all subsequent calls to deref/@. If the computation has not yet finished, calls to deref/@ will block.

(defobject async "ferret/obj/async_o.h")

(defmacro future [& body]
  `(~'_future_ (~'fn [] ~@body)))

(defn _future_ [f] "__result = obj<async>(f);")

(defn future-done? [f] "__result = obj<boolean>(f.cast<async>()->is_ready());")

Divert depricated thread macro which runs the given lambda in a thread to future,

(defn thread [f]
  "__result = obj<async>(f);")
#ifdef FERRET_STD_LIB
class async final : public deref_i {
  var value;
  mutex lock;
  var fn;
  bool cached;
  std::future<var> task;

  class rc_guard{
    object_t *obj;
  public:
    explicit rc_guard(const rc_guard &) = delete;
    explicit rc_guard(object_t *o) : obj(o) { };
    ~rc_guard() { obj->dec_ref(); }
  };

  var exec() {
    rc_guard g(this);
    return run(fn);
  }

  public:

  explicit async(var const & f) :
    value(nil()), fn(f), cached(false),
    task(std::async(std::launch::async, [this](){ return exec(); })){ inc_ref(); }

  size_t type() const final { return runtime::type::async; }

  bool equals(var const & o) const final {
    return (this == o.cast<async>());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print("future <");
    fn.stream_console();
    runtime::print(">");
  }
#endif

  bool is_ready(){
    lock_guard guard(lock);
    if (cached)
      return true;
    return task.wait_for(std::chrono::seconds(0)) == std::future_status::ready;
  }

  void get(){
    if (!cached){
      value = task.get();
      cached = true;
    }
  }

  var deref() {
    lock_guard guard(lock);
    get();
    return value;
  }
};
#endif
Delay

Mimics Clojure's delay. It is thread safe when used on system where FERRET_STD_LIB is defined.

Takes a body of expressions and yields a Delay object that will invoke the body only the first time it is forced (with force or deref/@), and will cache the result and return it on all subsequent force calls.

(defobject delayed "ferret/obj/delayed_o.h")

(defn _delay_ [f]
  "__result = obj<delayed>(f)")

(defmacro delay [& body]
  `(~'_delay_ (~'fn [] ~@body)))

(defn delay? [d]
  "__result = obj<boolean>(d.is_type(runtime::type::delayed));")

(defn force [d] @d)
class delayed final : public deref_i {
  var val;
  mutex lock;
  var fn;

  public:

  size_t type() const final { return runtime::type::delayed; }

  bool equals(var const & o) const final {
    return (this == o.cast<delayed>());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    runtime::print("delay");
  }
#endif

  explicit delayed(var const & f) : fn(f) {} 

  var deref() {
    lock_guard guard(lock);
    if (!fn.is_nil()){
      val = fn.cast<lambda_i>()->invoke(nil());
      fn = nil();
    }
    return val;
  }
};

Interfaces

Just like Clojure, Ferret is written in terms of abstractions. Currently there are abstractions for sequences, collections and callability.

Seekable

All sequence functions (first, second, rest etc.) use this interface to iterate seekable containers.

(defobject seekable_i "ferret/obj/seekable_i.h")
class seekable_i {
public:

  virtual var cons(var const & x) = 0;
  virtual var first() const = 0;
  virtual var rest() const = 0;
};

C++ API for the interface,

namespace runtime {
  var list(var const & v);
  var list(var const & v);
  template <typename... Args>
  var list(var const & first, Args const & ... args);

  var first(var const & coll);
  var rest(var const & coll);
  var cons(var const & x, var const & seq);
  var nth(var const & seq, number_t index);
  var nthrest(var const & seq, number_t index);
  size_t count(var const & seq);
  bool is_seqable(var const & seq);
}

Range-based for loop support for seekable containers. See Accessing C,C++ Libraries for example usage.

namespace runtime {
  struct range{
    var p;

    explicit range(var const & v) : p(v) { }
    inline range begin() const { return range(p); }
    inline range end()   const { return range(cached::empty_sequence); }

    inline bool operator!=(const range& other){
      return !p.is_nil() && (p != other.p);
    }

    inline const range& operator++(){
      p = runtime::rest(p);
      return *this;
    }

    inline var operator*(){
      return runtime::first(p);
    }
  };
}
namespace runtime {
  struct range_indexed_pair{
    number_t index;
    var value;

    explicit range_indexed_pair(number_t i = 0, var const & v = nil()) : index(i) , value(v) { }
  };

  struct range_indexed{
    var p;
    number_t index;

    explicit range_indexed(var const & v) : p(v) , index(0) { }
    inline range_indexed begin() const { return range_indexed(p); }
    inline range_indexed end()   const { return range_indexed(cached::empty_sequence); }

    inline bool operator!=(const range_indexed& other){
      return !p.is_nil() && (p != other.p);
    }

    inline const range_indexed& operator++(){
      p = runtime::rest(p);
      index++;
      return *this;
    }

    inline range_indexed_pair operator*(){
      return range_indexed_pair(index, runtime::first(p));
    }
  };
}
namespace runtime {
  struct range_pair_pair{
    var first;
    var second;

    explicit range_pair_pair(var const & a = nil(), var const & b = nil()) : first(a) , second(b) { }
  };

  struct range_pair{
    var first;
    var second;

    explicit range_pair(var const & a = nil(), var const & b = nil()) : first(a) , second(b) { }

    inline range_pair begin() const { return range_pair(first, second); }
    inline range_pair end()   const { return range_pair(cached::empty_sequence,cached::empty_sequence); }

    inline bool operator!=(const range_pair& other){
      return (first != other.first) && (second != other.second);
    }

    inline const range_pair& operator++(){
      first = runtime::rest(first);
      second = runtime::rest(second);
      return *this;
    }

    inline range_pair_pair operator*(){
      return range_pair_pair(runtime::first(first), runtime::first(second));
    }
  };
}

Implementations for the C++ Seekable API,

namespace runtime{
  var first(var const & coll){
    if (coll.is_nil() || coll.is_type(runtime::type::empty_sequence))
      return nil();
    else
      return coll.cast<seekable_i>()->first();
  }

  var rest(var const & coll){
    if (coll.is_nil())
      return runtime::list();
    if (coll.is_type(runtime::type::empty_sequence))
      return nil();
    return coll.cast<seekable_i>()->rest();
  }

  var cons(var const & x, var const & coll){
    if (coll.is_nil() || coll == runtime::list())
      return runtime::list(x);

    return coll.cast<seekable_i>()->cons(x);
  }

  var nth(var const & seq, number_t index){
    for(auto const& i : range_indexed(seq))
      if (index == i.index)
        return i.value;

    return nil();
  }

  var nthrest(var const & seq, number_t index){
    var ret = seq;
    for(number_t i = 0; i < index; i++)
      ret = runtime::rest(ret);

    if (ret.is_nil())
      return runtime::list(); 

    return ret;
  }

  size_t count(var const & seq){
    size_t acc = 0;
    for(auto const& v : runtime::range(seq)){
      (void)v;
      acc++;
    }
    return acc;
  }

  bool is_seqable(var const & seq){
    if(seq.cast<seekable_i>())
      return true;
    else
      return false;
  }
}
Lambda

Every lambda object implements the lambdai interface. All lambdas are executed via invoke method that takes a sequence of vars as argument or nil() if there are non, this allows us to execute them in a uniform fashion.

(defobject lambda_i "ferret/obj/lambda_i.h")
class lambda_i : public object_t {
 public:
  virtual var invoke(var const & args) const = 0;

  size_t type() const { return runtime::type::lambda_i; }

  bool equals(var const & o) const {
    return (this == o.get());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const {
    runtime::print("lambda");
  }
#endif
};

Function invocation,

template<typename T, typename... Args>
inline var run(T const & fn, Args const & ... args);

template<typename T>
inline var run(T const & fn);

template<>
inline var run(var const &);
template<typename T, typename... Args>
inline var run(T const & fn, Args const & ... args) {
  return fn.invoke(runtime::list(args...));
}

template<typename T>
inline var run(T const & fn) {
  return fn.invoke(nil());
}

template<>
inline var run(var const & fn) {
  return fn.cast<lambda_i>()->invoke(nil());
}

template<typename... Args>
inline var run(var const & fn, Args const & ... args) {
  return fn.cast<lambda_i>()->invoke(runtime::list(args...));
}
Deref
(defobject deref_i "ferret/obj/deref_i.h")
class deref_i : public object_t {
 public:

  virtual var deref() = 0;
};

Operations on deref_i

(defn deref [a]
  "__result = a.cast<deref_i>()->deref();")

Memory Management

Ferret is designed to be used on embedded systems which means,

  • Latency is more important then through put.
  • Can't have unpredictable GC pauses when running.

So the default memory management is done using reference counting. Unlike other lisp implementations, Ferret supports various memory management schemes,

  • malloc/free - Allocations are handled by the system implementation. (Default memory management.)
  • Memory Pooling - On memory constraint systems such as microcontrollers Ferret can use a memory pool to avoid heap fragmentation and calling malloc/free. Effectively running with no heap, allocating all memory at compile time on the stack.
  • Third party allocators (i.e tcmalloc)
  • Third party garbage collectors (i.e The Boehm-Demers-Weiser conservative garbage collector.)

To enable memory pooling,

(configure-runtime! FERRET_MEMORY_POOL_SIZE 256)

This will create a pool object as a global variable that holds an array of 256 / sizeof(sizet).

Pool sizes can also be defined using user-defined suffixes.

(configure-runtime! FERRET_MEMORY_POOL_SIZE "4_MB")   ;; Allocate 4 mega bytes of memory.
(configure-runtime! FERRET_MEMORY_POOL_SIZE "512_KB") ;; Allocate 512 kilo bytes of memory.

By default page size is sizeof(size_t). This can be changed using,

(configure-runtime! FERRET_MEMORY_POOL_PAGE_TYPE char)

Memory pooling is intended for embedded systems where calling malloc/free is not desired.

Steps for using tcmalloc on Mac OS X, install dependencies,

brew install google-perftools

Then from your program you can link to it using,

(configure-ferret! :compiler-options ["-std=c++11"
                                      "-L/usr/local/Cellar/gperftools/2.4/lib/"
                                      "-ltcmalloc"])

Steps for using Boehm garbage collector on Linux, install dependencies,

apt-get install libgc-dev

Enable and configure GC

(configure-runtime! FERRET_MEMORY_BOEHM_GC TRUE)
(configure-ferret! :command "g++ -std=c++11 core.cpp -lgc")

Memory Allocation

Ferret supports various memory allocation schemes,

  • malloc/free - Allocations are handled by the system implementation. (Default memory management.)
  • Memory Pooling - On memory constraint systems such as microcontrollers Ferret can use a memory pool to avoid heap fragmentation and calling malloc/free. Effectively running with no heap, allocating all memory at compile time on the stack.
  • Third party allocators (i.e tcmalloc)
  • Third party garbage collectors (i.e The Boehm-Demers-Weiser conservative garbage collector.)
Pool Allocator

When FERRET_MEMORY_POOL_SIZE is defined Ferret programs will use a memory pool called mem::allocator::program_memory instead of mallac,/free/ for memory allocation, depending on the pool size Ferret will allocate N bytes of memory on stack and all memory allocation happens in this memory pool useful when working with very limited amount of memory, such as micro controllers where you want complete control over the memory and you need deterministic timing requirements.

This allocator uses a bit-map to keep track of the used and unused memory locations for its book-keeping purposes. This allocator will make use of 1 single bit to keep track of whether it has been allocated or not. A bit 0 indicates free, while 1 indicates allocated. This has been done so that you can easily check a collection of bits for a free block. This kind of Bitmapped strategy works best for single object allocations ,we do not need to choose any size for the block which will be represented by a single bit. This will be the size of the parameter around which the allocator has been parameterized. Thus, close to optimal performance will result.

#ifdef FERRET_MEMORY_POOL_SIZE

 #define FERRET_ALLOC_POLICY mem::allocator::pool

 #if !defined(FERRET_MEMORY_POOL_PAGE_TYPE)
  #define FERRET_MEMORY_POOL_PAGE_TYPE size_t
  #define FERRET_MEMORY_POOL_PAGE_COUNT                                   \
    (FERRET_MEMORY_POOL_SIZE / sizeof(FERRET_MEMORY_POOL_PAGE_TYPE))
 #else
  #define FERRET_MEMORY_POOL_PAGE_COUNT FERRET_MEMORY_POOL_SIZE
 #endif

namespace mem{
  namespace allocator{

    memory_pool<FERRET_MEMORY_POOL_PAGE_TYPE, FERRET_MEMORY_POOL_PAGE_COUNT> program_memory;

    class pool{
    public:

      static void init(){ }

      template<typename FT>
      static inline void*  allocate(){ return program_memory.allocate(sizeof(FT)); }

      static inline void   free(void * ptr){ program_memory.free(ptr); }
    };
  }
}
#endif

When allocate is called the pool will scan the memory pool using the used bit array to find a block of memory big enough to satisfy the request. If found, it will the mark the region as used and return a pointer from pool array to the user which points to the memory block.

When a free request is received, we resolve the pointer in to the memory pool read the book keeping information on how much memory is allocated to this pointer and set these pages to unused.

Memory pool has several advantages, it will avoid fragmentation, function related to each other will always keep their data close to each other in the array which improves data locality.

#ifdef FERRET_MEMORY_POOL_SIZE
namespace mem{
  namespace allocator{
    template<size_t pool_size>
    class bit_array {
    private:
      uint8_t bits[pool_size / 8 + 1];

      inline size_t index (size_t i) { return i / 8; }
      inline size_t offset(size_t i) { return i % 8; }
    public:
      bit_array() : bits{ false } { }

      inline void set   (size_t b){         bits[index(b)] = (uint8_t)(bits[index(b)] |  (1 << (offset(b))));}
      inline void reset (size_t b){         bits[index(b)] = (uint8_t)(bits[index(b)] & ~(1 << (offset(b))));}
      inline bool test  (size_t b){ return (bits[index(b)] & (1 << (offset(b))));}
    };

    template<typename page_size, size_t pool_size>
    class memory_pool{
    public:
      mutex lock;
      bit_array<pool_size> used;
      page_size pool[pool_size];
      size_t offset;
      size_t page_not_found;

      memory_pool() : pool{0}, offset(0), page_not_found(pool_size + 1) { }

      inline size_t chunk_length(size_t size){
        size_t d = (size / sizeof(page_size));
        size_t f = (size % sizeof(page_size));

        if (f == 0)
          return d;
        else
          return (d + 1);
      }

      inline bool chunk_usable(size_t begin, size_t end){
        for(size_t i=begin; i < end; i++)
          if (used.test(i))
            return false;
        return true;
      }

      inline size_t next_page(size_t begin){
        for(size_t i=begin; i < pool_size; i++)
          if (!used.test(i))
            return i;
        return pool_size;
      }

      inline size_t scan_pool(size_t pages_needed, size_t offset = 0){
        for(;;){
          size_t begin = next_page(offset);
          size_t end   = begin + pages_needed;

          if (end > pool_size)
            return page_not_found;

          if (chunk_usable(begin, end))
            return begin;

          offset = end;
        }
      }

      void *allocate(size_t req_size){
        lock_guard guard(lock);

        size_t length = chunk_length(++req_size);
        size_t page   = scan_pool(length, offset);

        if (page == page_not_found){
          page = scan_pool(length);
          if (page == page_not_found)
            return nullptr;
        }

        pool[page] = length;
        offset = page + length;
        for(size_t i = page; i < offset; i++)
          used.set(i);

        return &pool[++page];
      }

      void free(void *p){
        lock_guard guard(lock);

        ptrdiff_t begin = (static_cast<page_size *>(p) - pool) - 1;
        ptrdiff_t end = begin + (ptrdiff_t)pool[begin];

        for (ptrdiff_t i = begin; i < end; i++)
          used.reset((size_t)i);
      }
    };
  }
}
#endif
LibGC

When FERRET_MEMORY_BOEHM_GC is defined Ferret programs will use Boehm-Demers-Weiser's GC is a garbage collecting storage allocator. The collector automatically recycles memory when it determines that it can no longer be used.

Code must be linked against the GC library. On most UNIX platforms, depending on how the collector is built, this will be gc.a or libgc.{a,so}.

#ifdef FERRET_MEMORY_BOEHM_GC

#define FERRET_ALLOC_POLICY mem::allocator::gc
#define FERRET_DISABLE_RC true

#include <gc.h>

namespace mem{
  namespace allocator{

    class gc{
    public:

      static void init(){ GC_INIT(); }

      template<typename FT>
      static inline void* allocate(){
#ifdef FERRET_DISABLE_MULTI_THREADING
        return GC_MALLOC(sizeof(FT));
#else
        return GC_MALLOC_ATOMIC(sizeof(FT));
#endif
      }

      static inline void  free(void * ptr){ }
    };
  }
}
#endif
System Allocator

Objects are allocated from system implementation. (Default memory allocator used.)

#if !defined(FERRET_ALLOC_POLICY)

#define FERRET_ALLOC_POLICY mem::allocator::system

namespace mem{
  namespace allocator{

    class system{
    public:

      static void init(){ }

      template<typename FT>
      static inline void* allocate(){ return ::malloc(sizeof(FT)); }

      static inline void  free(void * ptr){ ::free(ptr); } 
    };
  }
}
#endif

Reference Counting

Garbage collection is handled by reference counting. Reference count is kept within the obj::base using one of the following reference counting policies.

  • atomicrc - Atomic reference counting. (using std::atomic)
  • rc - Non Atomic reference counting. (using size_t)
  • norc - No reference counting.
#if !defined(FERRET_RC_POLICY)
namespace mem {
  namespace gc {
#if defined(FERRET_DISABLE_RC)

#define FERRET_RC_POLICY mem::gc::no_rc

    class no_rc{
    public:

      inline void inc_ref() { }
      inline bool dec_ref() { return false; }
    };

#else

    template<typename T>
    class rc{
    public:

      inline void inc_ref() { ref_count++; }
      inline bool dec_ref() { return (--ref_count == 0); }

    private:
      T ref_count{0};
    };    

    #if defined(FERRET_DISABLE_MULTI_THREADING) || !defined(FERRET_STD_LIB)
      #define FERRET_RC_POLICY mem::gc::rc<int>
    #endif

    #if defined(FERRET_STD_LIB) && !defined(FERRET_DISABLE_MULTI_THREADING)
      #define FERRET_RC_POLICY mem::gc::rc<::std::atomic<int>>
    #endif
#endif
  }
}
#endif

Concurrency

Low level concurrency abstractions.

Mutex

Locking abstractions for various platforms. They are disabled when running single threaded or on an embedded platform. (FERRET_STD_LIB not defined.)

namespace ferret {
#if defined(FERRET_STD_LIB) && !defined(FERRET_DISABLE_MULTI_THREADING)
  class mutex {
    ::std::mutex m;
  public:
    void lock()   { m.lock(); } 
    void unlock() { m.unlock(); }
  };
#else
  class mutex {
  public:
    void lock()   {} 
    void unlock() {} 
  };
#endif
}

namespace ferret {
  class lock_guard{
    mutex & _ref;
  public:
    explicit lock_guard(const lock_guard &) = delete;
    explicit lock_guard(mutex & mutex) : _ref(mutex) { _ref.lock(); };
    ~lock_guard() { _ref.unlock(); }
  };
}

Configuration

Ferret defaults to running in safe mode, which means

  • Multi threading is disabled.
  • Console output is disabled.

Safe mode only requires a C++11 compiler, no third party library is required including the C++ standard library. Following options can be configured using #define directives, or using native-define or configure-runtime! from program code. Unless these options are overridden in source file, they are auto configured during compilation on supported platforms. (i.e Multi threading will be enabled on Linux or Mac OS X.) On unsupported platforms Ferret defaults to running in safe mode.

(configure-runtime! FERRET_DISABLE_STD_OUT true)
|------------------------------------+--------------+----------------------------------------------------------|
| Define                             | Defult Value | Description                                              |
|------------------------------------+--------------+----------------------------------------------------------|
| FERRET_SAFE_MODE                   | false        | Force Safe Mode.                                         |
| FERRET_DISABLE_CLI_ARGS            | false        | Disable command line arguments.                          |
| FERRET_DISABLE_STD_OUT             | false        | Disables output stream. (Reduces code size.)             |
| FERRET_DISABLE_MULTI_THREADING     | false        | Disable atomic reference counting.                       |
| FERRET_DISABLE_STD_MAIN            | false        | Disables auto execution of program::run()                |
| FERRET_DISABLE_RC                  | Not Defined  | Disable Reference Counting. (When using third party GCs) |
| FERRET_PROGRAM_MAIN                | Not Defined  | A function to execute after program::run()               |
| FERRET_UART_RATE                   | 9600         | Set default UART rate.                                   |
| FERRET_HARDWARE_ARDUINO_UART_PORT  | Serial       | Set default UART port.                                   |
| FERRET_NUMBER_TYPE                 | int          | Default number_t type.                                   |
| FERRET_REAL_TYPE                   | double       | Default real_t type.                                     |
| FERRET_REAL_EPSILON                | 0.00001      | Least significant digit representable.                   |
|------------------------------------+--------------+----------------------------------------------------------|

Initialization

Detect Hardware

Check for supported hardware or platform. If running on a known hardware or platform break out of Safe Mode and set a flag indicating platform.

# define FERRET_CONFIG_SAFE_MODE TRUE

#if !defined(FERRET_SAFE_MODE)
  #if defined(__APPLE__) ||                       \
    defined(_WIN32) ||                            \
    defined(__linux__) ||                         \
    defined(__unix__) ||                          \
    defined(_POSIX_VERSION)

    # undef  FERRET_CONFIG_SAFE_MODE
    # define FERRET_STD_LIB TRUE
  #endif

  #if defined(ARDUINO)

    # define FERRET_HARDWARE_ARDUINO TRUE

    #if !defined(FERRET_HARDWARE_ARDUINO_UART_PORT)
      # define FERRET_HARDWARE_ARDUINO_UART_PORT Serial
    #endif
  #endif

  #if defined(FERRET_HARDWARE_ARDUINO)
    # undef  FERRET_CONFIG_SAFE_MODE
    # define FERRET_DISABLE_MULTI_THREADING TRUE
    # define FERRET_DISABLE_STD_MAIN TRUE


    #if defined(__AVR__)
      # undef  FERRET_MEMORY_POOL_PAGE_TYPE
      # define FERRET_MEMORY_POOL_PAGE_TYPE uint8_t
    #endif

  #endif
#endif

#if defined(FERRET_CONFIG_SAFE_MODE)
  # define FERRET_DISABLE_MULTI_THREADING TRUE
  # define FERRET_DISABLE_STD_OUT TRUE
#endif

Import libraries

#ifdef FERRET_STD_LIB
 #include <iostream>
 #include <iomanip>
 #include <sstream>
 #include <cstdio>
 #include <cstdlib>
 #include <cstddef>
 #include <cmath>
 #include <vector>
 #include <algorithm>
 #include <chrono>
 #include <atomic>
 #include <mutex>
 #include <thread>
 #include <future>
#endif

#ifdef FERRET_HARDWARE_ARDUINO
 #include <Arduino.h>
 #include <stdio.h>
 #include <stdlib.h>
 #include <stdint.h>
#endif

#ifdef FERRET_CONFIG_SAFE_MODE
 #include <stdio.h>
 #include <stdlib.h>
 #include <stdint.h>
 #include <math.h>
#endif

Initialize Hardware

Default UART rate (if supported),

#if !defined(FERRET_UART_RATE)
  # define FERRET_UART_RATE 9600
#endif

Setup dummy IO,

#if defined(FERRET_DISABLE_STD_OUT)
   namespace runtime{
     void init(){ }

     template <typename T>
     void print(T){ }
   }
#endif

Setup IO for general purpose OS,

#if defined(FERRET_STD_LIB) && !defined(FERRET_DISABLE_STD_OUT)
  namespace runtime{
    void init(){}

    template <typename T>
    void print(const T t){ std::cout << t; }

    template <>
    void print(const real_t n){
      std::cout << std::fixed << std::setprecision(number_precision) << n;
    }
  }
#endif

Setup IO for Arduino boards,

#if defined(FERRET_HARDWARE_ARDUINO) && !defined(FERRET_DISABLE_STD_OUT) 
  namespace runtime{
    void init(){ FERRET_HARDWARE_ARDUINO_UART_PORT.begin(FERRET_UART_RATE); }

    template <typename T>
    void print(const T t){ FERRET_HARDWARE_ARDUINO_UART_PORT.print(t); }

    template <>
    void print(const real_t d){ FERRET_HARDWARE_ARDUINO_UART_PORT.print(double(d)); }

    template <>
    void print(void *p){
      FERRET_HARDWARE_ARDUINO_UART_PORT.print((size_t)p,HEX);
    }

    template <> void print(const void * const p){
      FERRET_HARDWARE_ARDUINO_UART_PORT.print((size_t)p, HEX);
    }
   }
#endif

Program Run

Unless FERRET_DISABLE_STD_MAIN is defined a main function is defined which is the designated start of the program. program::run() function contains all compiled code. Executing this function has equivalent semantics to loading the Clojure source file into a virgin Clojure interpreter and then terminating its execution. If FERRET_PROGRAM_MAIN is defined, it will be called right after program::run().

#if !defined(FERRET_DISABLE_STD_MAIN)
 #if defined(FERRET_DISABLE_CLI_ARGS) || !defined(FERRET_STD_LIB)
  int main()
 #else
  int main(int argc, char* argv[])
 #endif
  {     
    using namespace ferret;

    FERRET_ALLOC_POLICY::init();

   #if defined(FERRET_STD_LIB) && !defined(FERRET_DISABLE_CLI_ARGS)
    for (int i = argc - 1; i > -1 ; i--)
      _star_command_line_args_star_ =  runtime::cons(obj<string>(argv[i]),_star_command_line_args_star_);
   #endif

    program::run();

   #if defined(FERRET_PROGRAM_MAIN)
    run(FERRET_PROGRAM_MAIN);
   #endif

    return 0;
  }
#endif

When a supported Arduino board is detected. Instead of using a standard main function, Ferret uses Arduino compatible boot procedure.

#if defined(FERRET_HARDWARE_ARDUINO)
  void setup(){
    using namespace ferret;

      runtime::init();

    #if defined(FERRET_PROGRAM_MAIN)
      program::run();
    #endif
  }
  void loop(){
    using namespace ferret;
    #if !defined(FERRET_PROGRAM_MAIN)
      program::run();
    #endif          

    #if defined(FERRET_PROGRAM_MAIN)
      run(FERRET_PROGRAM_MAIN);
    #endif
  }
#endif

Accessing C,C++ Libraries

Ferret's FFI is modeled after Gambit scheme. Whereas Gambit scheme lets you embed C into Scheme, Ferret lets you embed C or C++ into Clojure.

Native headers can be imported using,

(native-header "thirt_party_header.h")

Top level statements can be declared using,

(native-declare "int i = 0;")

Ferret objects can be created using the obj function. If a function only contains a string such as,

(defn inc-int [] "__result =  obj<number>(i++);")

It is assumed to be a native function string, it is taken as C++ code. You can then use it like any other ferret function.

(while (< (inc-int) 10)
  (print 1))

Another option is to use the cxx macro,

(def dac-0 (cxx "__result =  obj<number>(DAC0);"))

Ferret objects can be converted to/from their native counter parts, i.e a Ferret sequence can be converted to std::vector to be sorted by std::sort using a Ferret function,

(defn my-sort [f seq]
  "std_vector vec = sequence::to<std_vector>(seq);
   std::sort(vec.begin(), vec.end(), [f](var a, var b) { return run(f,a,b); });
   __result = sequence::from<std_vector>(vec);")
(my-sort > (list 1 3 2)) ;; (1.0000 2.0000 3.0000)
(my-sort < (list 1 3 2)) ;; (3.0000 2.0000 1.0000)
(defn my-find [item seq]
  "std_vector vec = sequence::to<std_vector>(seq);
   std_vector::iterator it = find (vec.begin(), vec.end(), item);

   if(it != vec.end())
     __result = cached::true_t;")
(my-find (list 1 2) (list (list 1 2)
                          (list 2 3)
                          (list 4 5)))

;; true

(my-find (list 5 5) (list (list 1 2)
                          (list 2 3)
                          (list 4 5)))

;; false

In addition to defn form there is also a defnative form which allows you to define different function bodies for different #define directives,

(defnative get-char []
  (on "defined FERRET_STD_LIB"
      "__result = obj<number>(getchar());"))

This function when compiled on a system that defines GNU_GCC will return the result of getchar as a number , on ANY other system it will return nil. You can have multiple on blocks per defnative,

(defnative sleep [t]
  (on "defined FERRET_STD_LIB"
      "auto duration = ::std::chrono::milliseconds(number::to<number_t>(t));
       ::std::this_thread::sleep_for(duration);")
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::delay(number::to<number_t>(t));"))

This way a single function can be defined for multiple systems. Reverse is also possible, since all built in data structures are immutable you can freely call Ferret code from C++,

var alist = runtime::list(obj<number>(1),obj<number>(2),obj<number>(3));

int sum = 0;
for(auto const& it : runtime::range(alist)){
  sum += number::to<int>(it);
 }

::std::cout << sum << ::std::endl;

//or

var res = _plus_().invoke(alist);
res.stream_console();
::std::cout << ::std::endl;

Clojure Core

Once our object system is in place we can define rest of the runtime (functions/macros) using our Clojure subset,

(defn first [x]
  "__result = runtime::first(x);")

(defn second [x]
  "__result = runtime::first(runtime::rest(x));")

(defn nil? [x] "__result = obj<boolean>(x.is_nil())")

We can embed C++ code into our functions, which is how most of the primitive functions are defined such as the first function above, once primitives are in place rest can be defined in pure Clojure,

(defn println [& more]
  (when more
    (apply print more))
  (newline))

As for macros, normal Clojure rules apply since they are expended using Clojure, the only exception is that stuff should not expand to fully qualified Clojure symbols, so the symbol fn should not expand to clojure.core/fn,

(defmacro defn [name & body]
  `(~'def ~name (~'fn ~@body)))

Functions

Multi arity functions are handled by the fn macro. There are two ways to define a function. For single arity functions it accepts the following form,

(fn [a] a)

For multi arity functions it expects the following form,

(fn
  ([a] 1)
  ([a b] 2)
  ([a b & c] 3)
  ([a b [c d] & e] 4))

A multi arity function is a function that counts the number of its arguments and then dispatches on the number of arguments to each implementation.

(defmacro fn [& body]
  (if (vector? (first body))
    (fn->unique-args body)
    ;; handle multi arity function
    (let [fns   (map #(fn->unique-args %) body)
          arity (->> (map first body)
                     (map (fn* [args] (filter #(not (= % '&)) args)))
                     (map #(count %)))
          fns   (->> (interleave arity fns)
                     (partition 2)
                     (sort-by first))
          fns   (if (->> fns last second second      ;; last arity arguments
                         (take-last 2) first (= '&)) ;; check &
                  (let [switch        (drop-last 1 fns)
                        [[_ default]] (take-last 1 fns)]
                    `(~'fn-multi-arity ~switch ~default))
                  `(~'fn-multi-arity ~fns))]
      `(~'fn* () ~fns))))

A simple macro for calling inline C++,

(defmacro cxx [& body]
  (let [body (apply str body)]
    `((~'fn [] ~body))))

I/O

print

(defnative print [& more]
  (on "!defined(FERRET_DISABLE_STD_OUT)"
      "if (more.is_nil())
         return nil();
       var f = runtime::first(more);
       f.stream_console();
       var r = runtime::rest(more);
       for(auto const& it : runtime::range(r)){
        runtime::print(\" \");
        it.stream_console();
       }"))

newline

(defnative newline []
  (on "!defined(FERRET_DISABLE_STD_OUT)"
      "runtime::print(\"\\n\");"))

println

get-char

sh

(defnative sh [cmd]
  (on "defined FERRET_STD_LIB"
      ("memory")
      "::std::shared_ptr<FILE> pipe(popen(string::to<std::string>(cmd).c_str(), \"r\"), pclose);
       if (!pipe) 
          __result = nil();
       char buffer[128];
       ::std::string result = \"\";
       while (!feof(pipe.get()))
        if (fgets(buffer, 128, pipe.get()) != NULL)
         result += buffer;
       __result = obj<string>(result);"))

system-exit

(defn system-exit [code]
  "::std::exit(number::to<number_t>(code));")

system-abort

(defn system-abort [code]
  "::std::abort();")

xor-stream-encoder/decoder

(defn xor-stream-encoder [write]
  (fn [seq]
    (let [length (count seq)
          checksum (reduce bit-xor length seq)]
      (write 0X06)
      (write 0X85)
      (write length)
      (doseq [s seq] 
        (write s))
      (write checksum))))
(defn xor-stream-header-ready [read in-waiting]
  (and (>= (in-waiting) 3) (= (read) 0X06) (= (read) 0X85)))

(defn xor-stream-payload-ready [payload-size in-waiting]
  (>= (in-waiting) (inc (deref payload-size))))

(defn xor-stream-decoder-goto [] true)

(defn xor-stream-decoder [read in-waiting handler]
  (let [payload-size (atom nil)]
    (state-machine 
     (states
      (sync-header)
      (reset-payload    (reset! payload-size (read)))
      (wait-payload)
      (handle-payload   (let [payload (atom (list))]
                          (dotimes [_ (deref payload-size)]
                            (swap! payload conj (read)))
                          (when (= (read) (reduce bit-xor (deref payload-size) (deref payload)))
                            (swap! payload reverse)
                            (handler (deref payload))))))
     (transitions
      (sync-header     #(xor-stream-header-ready read in-waiting)           reset-payload)
      (reset-payload   xor-stream-decoder-goto                              wait-payload)
      (wait-payload    #(xor-stream-payload-ready payload-size in-waiting)  handle-payload)
      (handle-payload  xor-stream-decoder-goto                              sync-header)))))

Looping

doseq

(defmacro doseq [binding & body]
  `(~'_doseq_ ~(second binding)
              (~'fn [~(first binding)] ~@body)))

(defn _doseq_ [seq f] "for(auto const& it : runtime::range(seq)) run(f,it);")

dotimes

(defmacro dotimes [binding & body]
  `(~'_dotimes_ ~(second binding)
                (~'fn [~(first binding)] ~@body)))

(defn _dotimes_ [t f] "for(number_t i = 0; i < number::to<number_t>(t); i++) run(f,obj<number>(i));")

Conditionals

when

(defmacro when [test & body]
  `(~'if ~test (~'do ~@body)))

cond

(defmacro cond [& clauses]
  (when clauses
    `(~'if ~(first clauses)
      ~(if (next clauses)
         (second clauses)
         (throw (IllegalArgumentException.
                 "cond requires an even number of forms")))
      (~'cond ~@(next (next clauses))))))

while

(defn _while_ [pred fn]
  "while(run(pred))
     run(fn);")

(defmacro while [test & body]
  `(~'_while_ (~'fn [] ~test) (~'fn [] ~@body)))

forever

(defmacro forever [& body]
  `(~'while true ~@body))

if-let

(defmacro if-let
  ([bindings then]
   `(~'if-let ~bindings ~then nil))
  ([bindings then else & oldform]
   (let [form (bindings 0) tst (bindings 1)]
     `(~'let* [temp# ~tst]
              (~'if temp#
                (~'let* [~form temp#]
                        ~then)
                ~else)))))

when-let

When test is true, evaluates body with binding-form bound to the value of test.

(defmacro when-let
  [bindings & body]
  (let [form (bindings 0) tst (bindings 1)]
    `(~'let* [temp# ~tst]
             (~'when temp#
               (~'let* [~form temp#]
                       ~@body)))))

Logical Operators

=

(defn = [& args]
  "var curr = runtime::first(args);
   for(auto const& it : runtime::range(runtime::rest(args))){
    if (curr != it)
      return cached::false_t;
    curr = it;
   }
   __result = cached::true_t;")

not=

(defmacro not= [& test]
  `(~'not (~'= ~@test)))

<

(defn <
  ([] true)
  ([x] true)
  ([a b]
   "__result = a.cast<number>()->is_smaller(b);")
  ([a b & more]
   (if (< a b)
     (apply < (cons b more))
     false)))

>

(defn >
  ([] true)
  ([x] true)
  ([a b]
   "__result = a.cast<number>()->is_bigger(b);")
  ([a b & more]
   (if (> a b)
     (apply > (cons b more))
     false)))

>=

(defn >=
  ([] true)
  ([x] true)
  ([a b]
   "__result = a.cast<number>()->is_bigger_equal(b);")
  ([a b & more]
   (if (>= a b)
     (apply >= (cons b more))
     false)))

<=

(defn <=
  ([] true)
  ([x] true)
  ([a b]
   "__result = a.cast<number>()->is_smaller_equal(b);")
  ([a b & more]
   (if (<= a b)
     (apply <= (cons b more))
     false)))

and

(defmacro and
  ([] true)
  ([x] x)
  ([x & next]
   `(~'if ~x (~'and ~@next) false)))

or

(defmacro or
  ([] nil)
  ([x] x)
  ([x & next]
   `(~'if ~x ~x (~'or ~@next))))

not

(defn not [x]
  "if (x)
     return cached::false_t;
   __result = cached::true_t;")

true?

(defn true? [x]
  "if (x)
     return cached::true_t;
   __result = cached::false_t;")

false?

(defn false? [x]
  "if (!x)
     return cached::true_t;
   __result = cached::false_t;")

Sequence

map

(defn map [f col]
  (if (not (empty? col))
    (cons (f (first col))
          (lazy-seq (map f (rest col))))))

range

(defn range
  ([high]
   (range 0 high))
  ([low high]
   (if (< low high)
     (cons low (lazy-seq
                (range (inc low) high))))))

take

(defn take [n coll]
  (if (not (empty? coll))
    (if (> n 0)
      (cons (first coll)
            (lazy-seq (take (- n 1) (rest coll)))))))

take-while

(defn take-while [pred s]
  (if (and (not (empty? s))
           (pred (first s)))
    (cons (first s) (lazy-seq (take-while pred (rest s))))))

drop

(defn drop [n coll]
  (if (and (pos? n)
           (not (empty? coll)))
    (drop (dec n) (rest coll))
    coll))

concat

(defn concat
  ([]
   (list))
  ([x]
   (if (not (empty? x))
     (cons (first x) (lazy-seq (concat (rest x))))))
  ([x y]
   (if (not (empty? x))
     (cons (first x) (lazy-seq (concat (rest x) y)))
     (concat y))))

reduce

(defn reduce
  ([f [sf & sr]]
   "var acc = run(f, runtime::first(sr), sf);
    var r = runtime::rest(sr);
    for (auto const& i : runtime::range(r))
     acc = run(f, acc, i);
    __result = acc;")
  ([f acc coll]
   "__result = acc;
    for (auto const& i : runtime::range(coll))
     __result = run(f, __result, i);"))

list

(defn list [& xs] "if (xs.is_nil())
                     __result = runtime::list();
                   else
                     __result = xs;")

list?

(defn list? [x] "__result = obj<boolean>(x.is_type(runtime::type::sequence));")

empty?

(defn empty? [x]
  (if (nil? x)
    true
    (= (list ) x)))

rest

(defn rest [x] "var r = runtime::rest(x);
                if (r.is_nil())
                  return runtime::list();
                else 
                  __result = r;")

nth

(defn nth [coll index] "__result = runtime::nth(coll,number::to<number_t>(index));")

nthrest

Returns the nth rest of coll, coll when n is 0.

(defn nthrest [coll n]
  "__result = runtime::nthrest(coll,number::to<number_t>(n));")

cons

(defn cons [x seq] "__result = runtime::cons(x, seq);")

apply

(defn apply [f args] "__result = f.cast<lambda_i>()->invoke(args);")

conj

(defn conj [coll & xs]
  (reduce (fn[h v] (cons v h)) (if (nil? coll) (list) coll) xs))

reverse

(defn reverse [s]
  (reduce (fn[h v] (cons v h)) (list) s))

filter

(defn filter [pred coll]
  (if (not (empty? coll))
    (let [[f & r] coll]
      (if (pred f)
        (cons f (filter pred r))
        (filter pred r)))
    coll))

repeatedly

(defn repeatedly
  ([f] (cons (f) (lazy-seq (repeatedly f))))
  ([n f] (take n (repeatedly f))))

partition

(defn partition
  ([n coll]
   (partition n n coll))
  ([n step coll]
   (lazy-seq
    (if (not (empty? coll))
      (let [p (take n coll)]
        (when (= n (count p))
          (cons p (partition n step (nthrest coll step))))))))
  ([n step pad coll]
   (lazy-seq
    (if (not (empty? coll))
      (let [p (take n coll)]
        (if (= n (count p))
          (cons p (partition n step pad (nthrest coll step)))
          (list (take n (concat p pad)))))))))

Math

zero?

(defn zero? [x]
  (= x 0))

pos?

(defn pos? [x]
  (> x 0))

neg?

(defn neg? [x]
  (< x 0))

+

(defn +
  ([] 0)
  ([x] x)
  ([h v]
   "__result = h.cast<number>()->add(v);")
  ([x y & more]
   (reduce + (+ x y) more)))

-

(defn -
  ([x]
   (* -1 x))
  ([h v]
   "__result = h.cast<number>()->sub(v);")
  ([x y & more]
   (reduce - (- x y) more)))

*

(defn *
  ([] 1)
  ([x] x)
  ([h v]
   "__result = h.cast<number>()->mul(v);")
  ([x y & more]
   (reduce * (* x y) more)))

/

(defn /
  ([x]
   (apply / (list 1 x)))
  ([h v]
   "__result = h.cast<number>()->div(v);")
  ([x y & more]
   (reduce / (/ x y) more)))

inc

(defn inc [x]
  (+ x 1))

dec

(defn dec [x]
  (- x 1))

count

(defn count [s]
  (if (or (nil? s)
          (empty? s))
    0
    (reduce inc 0 s)))

min / max

(defn min
  ([x] x)
  ([x & r]
   (reduce (fn[h v]
             (if (< h v)
               h v))
           x r)))

(defn max
  ([x] x)
  ([x & r]
   (reduce (fn[h v]
             (if (> h v)
               h v))
           x r)))

rem

(defn rem [num div]
  "__result = obj<number>((number::to<number_t>(num) % number::to<number_t>(div)));")

mod

(defn mod [num div] 
  (let [m (rem num div)] 
    (if (or (zero? m) (= (pos? num) (pos? div)))
      m 
      (+ m div))))

floor

(defn floor [x] "__result = obj<number>(number::to<number_t>(x));")

scale

(defn scale [x in-min in-max out-min out-max]
  (+ (/ (* (- x in-min) (- out-max out-min)) (- in-max in-min)) out-min))

clamp

(defn clamp [x min max]
  (cond
    (> x max) max
    (< x min) min
    true x))

bit-and

(defn bit-and [x y] "__result = obj<number>((number::to<number_t>(x) & number::to<number_t>(y)));")

bit-not

(defn bit-not [x] "__result = obj<number>(~number::to<number_t>(x));")

bit-or

(defn bit-or [x y] "__result = obj<number>((number::to<number_t>(x) | number::to<number_t>(y) ));")

bit-xor

(defn bit-xor [x y] "__result = obj<number>((number::to<number_t>(x) ^ number::to<number_t>(y) ));")

bit-shift-left

(defn bit-shift-left [x n] "__result = obj<number>((number::to<number_t>(x) << number::to<number_t>(n) ));")

bit-shift-right

(defn bit-shift-right [x n] "__result = obj<number>((number::to<number_t>(x) >> number::to<number_t>(n) ));")

number-split

Split a number into bytes.

(defn number-split [n]
  "number_t val = number::to<number_t>(n);
   unsigned char *p = (unsigned char*)&val;
   __result = runtime::list();
   for(size_t i = 0; i < sizeof(number_t); i++)
     __result = runtime::cons(obj<number>((number_t)p[i]),__result);")

number-combine

Combine a list of bytes to a number.

(defn number-combine [s]
  "number_t res = 0;
   for(size_t i = 0; i < sizeof(number_t); i++){
    size_t idx = (sizeof(number_t) - i - 1);
    var obj = runtime::nth(s,(number_t)idx);
    number_t val = number::to<number_t>(obj);
    res |= val << (i * 8);
   }
   __result = obj<number>(res);")

sqrt

Square root.

(defn sqrt [s]
  "__result = obj<number>((real_t)::sqrt(number::to<real_t>(s)));")

pow

Returns base raised to the power exponent:

(defn pow [b e]
  "__result = obj<number>((real_t)::pow(number::to<real_t>(b), number::to<real_t>(e)));")

cos

Returns the cosine of an angle of x radians.

(defn cos [s]
  "__result = obj<number>((real_t)::cos(number::to<real_t>(s)));")

sin

Returns the sine of an angle of x radians.

(defn sin [s]
  "__result = obj<number>((real_t)::sin(number::to<real_t>(s)));")

asin

Returns the principal value of the arc sine of x, expressed in radians.

(defn asin [x]
  "__result = obj<number>((real_t)::asin(number::to<real_t>(x)));")

atan2

Returns the principal value of the arc tangent of y/x, expressed in radians.

(defn atan2 [x y]
  "__result = obj<number>((real_t)::atan2(number::to<real_t>(x),number::to<real_t>(y)));")

log / log10

Returns the natural logarithm of x.

(defn log [x]
  "__result = obj<number>((real_t)::log(number::to<real_t>(x)));")

Returns the natural logarithm of x.

(defn log10 [x]
  "__result = obj<number>((real_t)::log10(number::to<real_t>(x)));")

to-degrees

Converts an angle measured in radians to an approximately equivalent angle measured in degrees.

(defn to-degrees [x]
  "__result = obj<number>((real_t) (number::to<real_t>(x) * 180.0 / 1_pi) );")

to-radians

Converts an angle measured in degrees to an approximately equivalent angle measured in radians.

(defn to-radians [x]
  "__result = obj<number>((real_t) (number::to<real_t>(x) * 1_pi / 180.0) );")

Timing

millis

Return current time in milliseconds,

(defnative millis []
  (on "defined FERRET_STD_LIB"
      "auto now = ::std::chrono::system_clock::now();
       auto epoch = now.time_since_epoch();
       auto time = ::std::chrono::duration_cast<::std::chrono::milliseconds>(epoch).count();
       __result = obj<number>(time);")
  (on "defined FERRET_HARDWARE_ARDUINO"
      "__result = obj<number>(::millis());"))

micros

Return current time in microseconds,

(defnative micros []
  (on "defined FERRET_STD_LIB"
      "auto now = ::std::chrono::high_resolution_clock::now();
       auto epoch = now.time_since_epoch();
       auto time = ::std::chrono::duration_cast<::std::chrono::microseconds>(epoch).count();
       __result = obj<number>(time);")
  (on "defined FERRET_HARDWARE_ARDUINO"
      "__result = obj<number>(::micros());"))

sleep

Sleep current thread for t milliseconds,

sleep-micros

Sleep current thread for t microseconds,

(defnative sleep-micros [t]
  (on "defined FERRET_STD_LIB"
      "auto duration = ::std::chrono::microseconds(number::to<number_t>(t));
       ::std::this_thread::sleep_for(duration);")
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::delayMicroseconds(number::to<real_t>(t));"))

elapsed-micros

Port of Teensy elapsedMicros API,

(defobject elapsed_micros "ferret/obj/elapsed_micros_o.h")

(defn new-elapsed-micros []
  "__result = obj<elapsed_micros>();")

(defn elapsed-micros? [t r]
  "__result = obj<boolean>(t.cast<elapsed_micros>()->is_elapsed(number::to<real_t>(r)));")

(defn elapsed-micros-now [t]
  "__result = obj<number>(t.cast<elapsed_micros>()->elapsed());")

(defn elapsed-micros-reset [t]
  "t.cast<elapsed_micros>()->reset()")
#if !defined(FERRET_SAFE_MODE)
class elapsed_micros : public object_t {

  unsigned long us;

#if defined(FERRET_HARDWARE_ARDUINO)
  inline unsigned long now() const{
    return ::micros();
  }
#elif defined(FERRET_STD_LIB)
  inline unsigned long now() const{
    auto now = ::std::chrono::high_resolution_clock::now();
    auto epoch = now.time_since_epoch();
    return (unsigned long)::std::chrono::duration_cast<::std::chrono::microseconds>(epoch).count();
  }
#endif

  inline unsigned long _elapsed() const { return (now() - us); }  

 public:

  elapsed_micros(void) { us = now(); }
  void reset() { us = now(); }

  size_t type() const { return runtime::type::elapsed_micros; }

  bool equals(var const & o) const {
    return (this == o.cast<elapsed_micros>());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const {
    runtime::print("elapsed_micros<");
    runtime::print(_elapsed());
    runtime::print(">");
  }
#endif

  inline var elapsed() const { return obj<number>(_elapsed()); }
  inline bool is_elapsed(real_t t) const { return (_elapsed() >= (unsigned long)t); }
};
#endif

time-fn

Takes a function f and returns the number of milliseconds it takes to run,

(defn time-fn [f]
  (let [start (millis)]
    (f)
    (- (millis) start)))

benchmark

Runs the function f n times and return the average time it takes function f to run in milliseconds,

(defn benchmark [f n]
  (let [values (map (fn [_] (time-fn f)) (range n))]
    (floor (/ (apply + values) n))))

fn-throttler

Returns a new function that limits the throughput of the given function. When called faster than =rate= it can either block or return =nil= immediately.

(defn ping []
  (println "Ping!"))

(def throttled-ping (fn-throttler ping 1 :second :blocking))

;; Ping console every second
(forever
 (throttled-ping))
(defn fn-throttler-aux-blocking [timer f rate]
  (fn [& args]
    (let [wait (- rate (elapsed-micros-now timer))]
      (elapsed-micros-reset timer)
      (sleep-micros wait)
      (apply f args))))

(defn fn-throttler-aux-non-blocking [timer f rate]
  (fn [& args]
    (when (elapsed-micros? timer rate)
      (elapsed-micros-reset timer)
      (apply f args))))

(defmacro fn-throttler [f rate unit policy]
  (let [unit->ms {:microsecond 1 :millisecond 1000
                  :second 1000000 :minute 60000000
                  :hour 3600000000 :day 86400000000
                  :month 2678400000000}
        rate (/ (unit->ms unit) rate)]
    (if (= policy :blocking)
      `(~'fn-throttler-aux-blocking     (~'new-elapsed-micros) ~f ~rate)
      `(~'fn-throttler-aux-non-blocking (~'new-elapsed-micros) ~f ~rate))))

Misc

rand

Returns a random floating point number between 0 (inclusive) and n (default 1) (exclusive).

(defnative rand-aux []
  (on "defined FERRET_STD_LIB"
      ("random")
      "::std::random_device ferret_random_device;
       ::std::mt19937_64 ferret_random_generator(ferret_random_device());
       ::std::uniform_real_distribution<ferret::real_t> ferret_random_distribution(0.0,1.0);"
      "__result = obj<number>(ferret_random_distribution(ferret_random_generator));"))

(defn rand
  ([]
   (rand-aux))
  ([x]
   (* x (rand-aux))))

rand-int

Returns a random integer between 0 (inclusive) and n (exclusive).

(defn rand-int
  [x]
  (floor (rand x)))

identity

(defn identity [x] x)

->

Threads the expr through the forms. Inserts x as the second item in the first form, making a list of it if it is not a list already. If there are more forms, inserts the first form as the second item in second form, etc.

(defmacro -> [x & forms]
  (loop [x x, forms forms]
    (if forms
      (let [form (first forms)
            threaded (if (seq? form)
                       `(~(first form) ~x ~@(next form))
                       (list form x))]
        (recur threaded (next forms)))
      x)))

->>

Threads the expr through the forms. Inserts x as the last item in the first form, making a list of it if it is not a list already. If there are more forms, inserts the first form as the last item in second form, etc.

(defmacro ->> [x & forms]
  (loop [x x, forms forms]
    (if forms
      (let [form (first forms)
            threaded (if (seq? form)
                       `(~(first form) ~@(next form)  ~x)
                       (list form x))]
        (recur threaded (next forms)))
      x)))

doto

Evaluates x then calls all of the methods and functions with the value of x supplied at the front of the given arguments. The forms are evaluated in order. Returns x.

(defmacro doto
  [x & forms]
  (let [gx (gensym)]
    `(let [~gx ~x]
       ~@(map (fn [f]
                (if (seq? f)
                  `(~(first f) ~gx ~@(next f))
                  `(~f ~gx)))
              forms)
       ~gx)))

Control

State Machines

This macro allows users to define state machines using the following DSL,

(def two-state-machine
  (state-machine 
   (states
    (off :off)
    (on  :on))
   (transitions
    (off (fn [] true) on)
    (on  (fn [] true) off))))

(dotimes [i 10]
  (let [state (two-state-machine)]
    (if (= state :off)
      (println "Off")
      (println "On"))))

Each transition takes a list of fn state pairs first function that returns true, returns the next state.

(defmacro state-machine [[_ & states] [_ & transitions]]
  (let [states (reduce (fn [h v]
                         (let [[name & body] v]
                           (conj h name `(~'fn [] ~@body))))
                       [] states)
        transitions (->> transitions
                         (map (fn [v]
                                (let [[state & conds] v
                                      conds (->> (partition 2 conds)
                                                 (reduce (fn [h v]
                                                           (let [[check state] v]
                                                             (conj h `(~check) state))) []))]
                                  `((~'= ~'state ~state) (~'cond ~@conds true ~state)))))
                         (reduce (fn [h v]
                                   (let [[check transition] v]
                                     (conj h check transition)))
                                 ['cond]))]
    `(let [~@states
           machine-state# (~'atom ~(first states))]
       (~'fn []
        (~'let [ret# ((~'deref machine-state#))]
         (~'swap! machine-state# (~'fn [~'state] (~@transitions)))
         ret#)))))

PID Control

From Wikipedia:

A PID controller calculates an 'error' value as the difference between a measured [Input] and a desired setpoint. The controller attempts to minimize the error by adjusting [an Output].

From PIDLibrary,

So, you tell the PID what to measure (the "Input",) Where you want that measurement to be (the "Setpoint",) and the variable to adjust that can make that happen (the "Output".) The PID then adjusts the output trying to make the input equal the setpoint.

(def controller (pid-controller :kp 0.5
                                :ki 0
                                :kd 0
                                :set-point 5 ;; or symbol to a fn
                                ;;in min - in max - out min - out max
                                :bounds [0 10 0 10]
                                :continuous false))

(println "Control" (controller 0))

Ported from,

/*
 * *********************************************************
 * Copyright (c) 2009 - 2015, DHBW Mannheim - Tigers Mannheim
 * Project: TIGERS - Sumatra
 * Date: Jun 10, 2015
 * Author(s): Nicolai Ommer <nicolai.ommer@gmail.com>
 * *********************************************************
 */

/**
 * @author Nicolai Ommer <nicolai.ommer@gmail.com>
 */
(defobject pid_controller "ferret/obj/pid_controller_o.h")
template <typename T>
class pid_controller : public object_t {
  T p;
  T i;
  T d;
  T maximum_output;
  T minimum_output;
  T maximum_input;
  T minimum_input;
  bool continuous;
  T prev_error;
  T total_error;
  T setpoint;
  T error;
  T result;
  T input;
public:

  pid_controller(var const & kp, var const & ki, var const & kd,
                 var const & inMin, var const & inMax, var const & outMin, var const & outMax,
                 var const & cont){
    p = number::to<T>(kp);
    i = number::to<T>(ki);
    d = number::to<T>(kd);
    maximum_output = number::to<T>(outMax);
    minimum_output = number::to<T>(outMin);
    maximum_input = number::to<T>(inMax);
    minimum_input = number::to<T>(inMin);
    continuous = cont.cast<boolean>()->container();
    prev_error = 0;
    total_error = 0;
    setpoint = 0;
    error = 0;
    result = 0;
    input = 0;
  }

  size_t type() const { return runtime::type::pid_controller; }

  bool equals(var const & o) const {
    return (this == o.cast<pid_controller>());
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const {
    runtime::print("pid_controller");
  }
#endif


  var update(var const & in){
    input = number::to<T>(in);

    // Calculate the error signal
    error = setpoint - input;

    // If continuous is set to true allow wrap around
    if (continuous) {
      if (runtime::abs(error) > ((maximum_input - minimum_input) / (real_t)2)) {
        if (error > (real_t)0) {
          error = (error - maximum_input) + minimum_input;
        } else {
          error = (error + maximum_input) - minimum_input;
        }
      }
    }

    /*
     * Integrate the errors as long as the upcoming integrator does
     * not exceed the minimum and maximum output thresholds
     */
    if ((((total_error + error) * i) < maximum_output) &&
        (((total_error + error) * i) > minimum_output)) {
      total_error += error;
    }

    // Perform the primary PID calculation
    result = ((p * error) + (i * total_error) + (d * (error - prev_error)));

    // Set the current error to the previous error for the next cycle
    prev_error = error;

    // Make sure the final result is within bounds
    if (result > maximum_output) {
      result = maximum_output;
    } else if (result < minimum_output) {
      result = minimum_output;
    }

    return obj<number>(result);
  }
  void set_setpoint(var const & p){
    T sp = number::to<T>(p);
    if (maximum_input > minimum_input) {
      if (sp > maximum_input) {
        setpoint = maximum_input;
      } else if (sp < minimum_input) {
        setpoint = minimum_input;
      } else {
        setpoint = sp;
      }
    } else {
      setpoint = sp;
    }
  }
  void reset(){
    prev_error = 0;
    total_error = 0;
    result = 0;
  }
};
(defn pid-controller-create [kp ki kd in-min in-max out-min out-max continuous]
  "__result = obj<pid_controller<real_t>>(kp, ki, kd, 
                                         in_min, in_max, out_min, out_max, 
                                         continuous);")

(defn pid-controller-set-point [controller sp]
  "controller.cast<pid_controller<real_t>>()->set_setpoint(sp);")

(defn pid-controller-update [controller input]
  "__result = controller.cast<pid_controller<real_t>>()->update(input)")

(defmacro pid-controller [& options]
  (let [defaults {:kp 0 :ki 0 :kd 0 :set-point 0 :bounds [-1 1 -1 1] :continuous false}
        options (merge defaults (apply hash-map options))
        {:keys [container kp ki kd set-point bounds continuous]} options
        [in-min in-max out-min out-max] bounds]

    (if (or (< in-max in-min)
            (< out-max out-min))
      (do (println "pid-controller invalid bounds")
          (System/exit 1)))

    (if (symbol? set-point)
      `(~'let [pid# (~'pid-controller-create
                     ~kp ~ki ~kd ~in-min ~in-max ~out-min ~out-max ~continuous)]
        (~'pid-controller-set-point pid# (~set-point))
        (~'fn [input#]
         (~'pid-controller-set-point pid# (~set-point))
         (~'pid-controller-update pid# input#)))
      `(~'let [pid# (~'pid-controller-create
                     ~kp ~ki ~kd ~in-min ~in-max ~out-min ~out-max ~continuous)]
        (~'pid-controller-set-point pid# ~set-point)
        (~'fn [input#]
         (~'pid-controller-update pid# input#))))))

Moving Average Filter

A First order IIR filter (exponentially decaying moving average filter) to approximate a K sample first order IIR filter to approximate a K sample moving average. This filter approximates a moving average of the last K samples by setting the value of alpha to 1/K.

(defn moving-average-filter [alpha average data]
  (+ (* alpha data)
     (* (- 1.0 alpha) average)))

GPIO

pin-mode

Configures the specified pin to behave either as an input or an output.

(defmacro pin-mode [pin mode]
  (let [pin (if (number? pin)
              pin
              (str "number::to<number_t>(" (symbol-conversion pin) ")"))
        mode (-> mode name .toUpperCase)]
    `(~'cxx ~(str "::pinMode(" pin ", " mode ");"))))

digital-write

Write a HIGH or a LOW value to a digital pin.

(defnative digital-write [pin val]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::digitalWrite(number::to<number_t>(pin), number::to<number_t>(val));"))

digital-read

Reads the value from a specified digital pin, either HIGH or LOW.

(defnative digital-read [pin]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "__result = obj<number>(::digitalRead(number::to<number_t>(pin)));"))

analog-write

Writes an analog value (PWM wave) to a pin.

(defnative analog-write [pin val]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::analogWrite(number::to<number_t>(pin),number::to<number_t>(val));"))

analog-read

Reads the value from the specified analog pin.

(defnative analog-read [pin]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "__result = obj<number>((number_t)::analogRead(number::to<number_t>(pin)));"))

analog-write-resolution

Sets the resolution of the analog-write

(defnative analog-write-resolution [bit]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::analogWriteResolution(number::to<number_t>(bit));"))

analog-read-resolution

Sets the size (in bits) of the value returned by analog-read.

(defnative analog-read-resolution [bit]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::analogReadResolution(number::to<number_t>(bit));"))

tone/noTone

Generates a square wave of the specified frequency (and 50% duty cycle) on a pin.

(defnative tone [pin freq]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::tone(number::to<number_t>(pin), number::to<number_t>(freq));"))
(defnative no-tone [pin]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::noTone(number::to<number_t>(pin));"))

attach-interrupt

Registers an interrupt function for the given pin and mode. See attachInterrupt() for more information.

(def input-pin  3)
(def debug-pin 13)

(pin-mode debug-pin :output)

(defn control-light []
  (->> (digital-read  input-pin)
       (digital-write debug-pin)))

(attach-interrupt control-light input-pin :change)

(forever
 (sleep 100))
(defmacro attach-interrupt [callback pin mode]
  (let [pin (if (number? pin)
              pin
              (str "number::to<number_t>(" (symbol-conversion pin) ")"))
        mode (-> mode name .toUpperCase)
        cb-sym (gensym)]
    `(~'do
      (~'def ~cb-sym ~callback)
      (~'cxx
       ~(str "::pinMode(" pin " , INPUT_PULLUP);\n"
             "auto int_pin = digitalPinToInterrupt(" pin ");\n"
             "::attachInterrupt(int_pin, [](){ run(" cb-sym ");}, " mode ");")))))

no-interrupt

Executes critical section with interrupts disabled.

(defmacro no-interrupt [& body]
  `(~'no-interrupt-aux  (~'fn [] ~@body)))

(defn no-interrupt-aux [f]
  "noInterrupts();
   __result = run(f);
   interrupts();")

detach-interrupt

Turns off the given interrupt.

(detach-interrupt input-pin)
(defmacro detach-interrupt [pin]
  (let [pin (if (number? pin)
              pin
              (str "number::to<number_t>(" (symbol-conversion pin) ")"))]
    `(~'cxx
      ~(str "::detachInterrupt(digitalPinToInterrupt(" pin "));"))))

SPI

Serial Peripheral Interface (SPI) is a synchronous serial data protocol used by microcontrollers for communicating with one or more peripheral devices over short distances. It can also be used for communication between two microcontrollers. This is a wrapper around Arduino SPI library see documentation for more details.

Initialization
(defnative spi-begin []
  (on "defined FERRET_HARDWARE_ARDUINO"
      ("SPI.h")
      "SPI.begin();"))

(defn spi-end []
  "SPI.end();")
Settings
(defmacro spi-settings [max-speed data-order data-mode]
  (let [speed      (* max-speed 1000000)
        data-order (if (= data-order :msb-first)
                     "MSBFIRST"
                     "LSBFIRST")
        data-mode  (condp = data-mode
                     :mode-0 "SPI_MODE0"
                     :mode-1 "SPI_MODE1"
                     :mode-2 "SPI_MODE2"
                     :mode-3 "SPI_MODE3")]
    `(~'cxx
      ~(str "__result = obj<value<SPISettings>>(" speed "," data-order "," data-mode ");"))))
Transaction
(defn with-spi-aux [conf f]
  "SPI.beginTransaction(value<SPISettings>::to_reference(conf));
   __result = run(f);
   SPI.endTransaction();")

(defmacro with-spi [conf & body]
  `(~'with-spi-aux ~conf (~'fn [] ~@body)))

(defn spi-write [val]
  "__result = obj<number>(SPI.transfer(number::to<int>(val)));")

Testing

assert

Evaluates expr and aborts if it does not evaluate to logical true.

(defn assert-aux [f msg]
  (when (not (f))
    (println "Assertion Failed =>" msg)
    (system-abort)))

(defn assert-aux-callback [f callback]
  (when (not (f)) (callback)))

(defmacro assert
  ([exp]
   `(~'assert-aux (~'fn [] ~exp) ~(-> exp pr-str (clojure.string/escape {\\ "\\\\"}))))
  ([exp callback]
   `(~'assert-aux-callback (~'fn [] ~exp) (~'fn [] ~callback))))

deftest

Support for Clojure style unit testing. See Unit Testing for more information.

(defn is-aux-expect [ex-fb form-fn form-str]
  (let [expect (ex-fb)
        got  (form-fn)]
    (when (not=  expect got)
      (println "fail in" form-str "\n expected" expect "\n      got" got))))

(defn is-aux [f msg]
  (when (not (f))
    (println "fail" msg)))

(defmacro is [form]
  (let [check-op (first form)
        form-str (-> form pr-str (clojure.string/escape {\\ "\\\\"}))]

    (cond (= check-op '=)
          (let [[_ expected form] form]
            `(~'is-aux-expect (~'fn [] ~expected) (~'fn [] ~form) ~form-str))

          :default `(~'is-aux (~'fn [] ~form) ~form-str))))

(defmacro deftest [name & exprs]
  (defonce fir-unit-tests (atom []))
  (swap! fir-unit-tests conj name)
  `(def ~name (~'fn [] ~@exprs)))

(defmacro run-all-tests []
  (if (bound? #'fir-unit-tests)
    `(~'do ~@(map #(list %) @fir-unit-tests))
    `(~'do )))

Native

defnative

Allows a function to be defined for multiple platforms see Accessing C,C++ Libraries for examples.

(defmacro defnative [name args & form]
  (let [includes (->> (filter #(seq? (nth % 2)) form)
                      (map #(cons (nth % 1) (apply list (nth % 2))))
                      (map (fn [form]
                             (let [[guard & headers] form]
                               (str "\n#if " guard " \n"
                                    (apply str (map #(str "#include \"" % "\"\n") headers))
                                    "#endif\n"))))
                      (map #(list 'native-declare %)))
        body (->> (map #(vector (second %) (last %)) form)
                  (map #(str "\n#if " (first %) " \n"
                             (second %)
                             "\n#endif\n"))
                  (apply str))
        pre-ample (->> (map #(vector (second %) (drop-last (drop 3 %))) form)
                       (remove #(empty? (second %)))
                       (map #(str "\n#if " (first %) " \n"
                                  (apply str (map (fn [line] (str line "\n")) (second %)))
                                  "\n#endif\n"))
                       (map #(list 'native-declare %)))]
    `(~'def ~name (~'fn ~args ~@includes ~@pre-ample  ~body))))

pr-object-sizes

(defn pr-object-sizes []
  (println "Object Sizes")
  (println "\tvar:\t\t\t" (cxx "__result = obj<number>(sizeof(var));"))
  (println "\tobject:\t\t\t" (cxx "__result = obj<number>(sizeof(object_t));"))
  (println "\tpointer:\t\t" (cxx "__result = obj<number>(sizeof(pointer));"))
  (println "\tnumber:\t\t\t" (cxx "__result = obj<number>(sizeof(number));"))
  (println "\tkeyword:\t\t" (cxx "__result = obj<number>(sizeof(keyword));"))
  (println "\tempty_sequence:\t\t" (cxx "__result = obj<number>(sizeof(empty_sequence));"))
  (println "\tsequence:\t\t" (cxx "__result = obj<number>(sizeof(sequence));"))
  (println "\tlazy_sequence:\t\t" (cxx "__result = obj<number>(sizeof(lazy_sequence));"))
  (println "\tstring:\t\t\t" (cxx "__result = obj<number>(sizeof(string));"))
  (println "\tboolean:\t\t" (cxx "__result = obj<number>(sizeof(boolean));"))
  (println "\tlambda_i:\t\t" (cxx "__result = obj<number>(sizeof(lambda_i));"))
  (println "\tatom:\t\t\t" (cxx "__result = obj<number>(sizeof(atomic));"))
  (println "\telapsed_micros:\t\t" (cxx "__result = obj<number>(sizeof(elapsed_micros));"))
  (println "\tpid_controller<real_t>:\t"
           (cxx "__result = obj<number>(sizeof(pid_controller<real_t>));")))

memory-pool-free-space

(defnative memory-pool-free-space []
  (on "defined FERRET_MEMORY_POOL_SIZE"
      "size_t acc = 0;
       for(size_t i = 0; i < FERRET_MEMORY_POOL_PAGE_COUNT; i++)
         if(mem::allocator::program_memory.used.get(i) == false)
           acc++;
       __result = obj<number>((acc*sizeof(FERRET_MEMORY_POOL_PAGE_TYPE)));"))

lock-memory

Wraps mlockall - locks the address space of process.

(defnative lock-memory []
  (on "defined FERRET_STD_LIB"
      ("sys/mman.h")
      "mlockall(MCL_CURRENT | MCL_FUTURE);"))

Compiler

configure-runtime!

Configure Ferret Runtime options. See table in Configuration section.

(defmacro configure-runtime! [& body]
  `(~'native-define ~(->> (partition 2 body)
                          (map #(str "#define " (first %) " " (second %) "\n"))
                          (list))))

configure-ferret!

Embed compilations options.

(defmacro configure-ferret! [& body]
  `(~'native-define ~(str "// build-conf-begin\n"
                          "//" (str (apply hash-map body)) "\n"
                          "// build-conf-end\n")))

Testing

Unit Testing

The reliability and robustness of Ferret is achieved in part by thorough and careful testing. Ferret lisp has built-in support for unit testing using an api that mimics clojure.test api.

The core of the library is the "is" macro, which lets you make assertions of any arbitrary expression, which will print a message if the assertion fails.

(is (= 42 (meaning-of-life)))

These assertions can be grouped using a deftest form which defines a test function with no arguments. Tests can be defined separately from the rest of the code, even in a different module.

(defn meaning-of-life [] 42)

(deftest life-test
  (is (= 42 (meaning-of-life))))

(run-all-tests)

This creates functions named life-test, which can be called like any other function. Therefore, tests can be grouped and composed, in a style similar to the test framework in Peter Seibel's "Practical Common Lisp" Finally all tests in the current program can be run using the run-all-tests.

Continuous Integration

Each new commit is tested against a set of assertions. Tests are run by the CI system for the following compilers,

  • GCC 5
  • Clang 3.4

Most tests are done using the built in unit testing api, but certain tests, those that target the workings of the compiler are easier to do using clojure.test framework by compiling forms using Ferret then comparing the their runtime output to their expected output. All generated code is statically checked using cppcheck and tested against memory leaks.

Build options,

  • -std=c++11
  • -pedantic
  • -Werror
  • -Wall
  • -Wextra
  • -Wconversion
  • -Wpointer-arith
  • -Wmissing-braces
  • -Woverloaded-virtual
  • -Wuninitialized
  • -Winit-self
  • -fno-rtti
  • -fsanitize=leak
  • -fsanitize=undefined

Static code analysis (cppcheck) options,

  • –std=c++11
  • –template=gcc
  • –enable=all
  • –error-exitcode=1

Compiler

(deftest compiler-core
  (let [program (compile '((defn one-plus-one []
                             (+ 1 1))

                           (while true
                             (+ 1 1))) {})]
    ;;while shoud use one-plus-one in its body
    ;;check lambda-already-defined?
    (is (= 2 (count (select-form program (fn [f] (= 'one_plus_one f))))))
    ;;test shake-concat
    (is (= '((defn c [] 1)
             (defn b [] (c))
             (defn a [] (b))
             (a))
           (shake-concat '((defn no-call-a [])
                           (defnative no-call-b [] (on "" ""))
                           (defn c [] 1)
                           (defn b [] (c))
                           (defn a [] (b)))
                         '((a)))))
    (is (= '((defn y [])
             (let [a 1]
               (defn b []))
             (println (b) (y)))
           (shake-concat '((defn x [] )
                           (defn y [] )
                           (let [a 1]
                             (defn b [] )
                             (defn c [] a)))
                         '((println (b) (y))))))
    (is (= '((defn p-create []) (defn p-update []))
           (take 2 (shake-concat '((defn p-create [])
                                   (defn p-update [])
                                   (defmacro pc [& options]
                                     `(~'let [controller# (~'p-create)]
                                       (~'fn [input#] (~'p-update)))))
                                 '((pc))))))
    (is (= '(defn new-lazy-seq [f] )
           (first (shake-concat '((defn new-lazy-seq [f] )
                                  (defmacro lazy-seq [& body]
                                    `(~'new-lazy-seq (~'fn [] ~@body)))
                                  (defn range
                                    ([high]
                                     (range 0 high))
                                    ([low high]
                                     (if (< low high)
                                       (cons low (lazy-seq
                                                  (range (inc low) high)))))))
                                '((range 10))))))))

Core

Special Forms

(def make-adder
  (fn [n]
    (fn [x] (+ x n))))

(def adder
  (make-adder 1))

(def fibo
  (fn [n]
    (if (< n 2)
      1
      (+ (fibo (- n 1))
         (fibo (- n 2))))))

(native-declare "ferret::number_t i = 0;")

(defn inc-int []
  "__result =  obj<number>(i++);")

(def nested-multi-call (do (fn
                             ([]    0)
                             ([x]   1)
                             ([x y] 2))))

(deftest special-forms-test
  (is (= 1                @(atom 1)))
  (is (= 3                (#(+ 1 2))))
  (is (= 11               ((fn [n] (+ n 1)) 10)))
  (is (= 3               (((fn [n] (fn [n] n)) 3) 3)))
  (let [args (list "1" "2")]
    (is (= args (rest *command-line-args*))))

  (let [a 1]
    (is (= 1 a)))

  (let [a 1
        a 3]
    (is (= 3 a)))

  (let [a 1
        b 2]
    (is (= 3 (+ a b))))

  (let [a 1
        b 2
        c 3]
    (is (= 6 (+ a b c))))

  (let [a 1
        b 2]
    (let []
      (is (= 3 (+ a b)))))

  (is (= 0 (nested-multi-call)))
  (is (= 1 (nested-multi-call 1)))
  (is (= 2 (nested-multi-call 1 2)))

  (is (= 10 (adder 9)))
  (is (= 89 (fibo 10)))
  (is (= 0 (inc-int)))
  (is (= 1 (inc-int))))

Destructuring

(defn destructure-test-1 [[a b c]]
  (list a b c))

(defn destructure-test-2 [[a [b] c]]
  b)

(defn destructure-test-3 [[a [_ b] c]]
  b)

(defn destructure-test-4 [& a]
  a)

(defn destructure-test-5 []
  (let [[a b c] (list 1 2 3)]
    (list a b c)))

(defn destructure-test-6 []
  (let [[_ _ a] (list 1 2 3)]
    a))

(defn destructure-test-7 [a b & [c d]]
  (list c d))

(deftest destructuring-test
  (is (= 3                   (count (destructure-test-1 (list 1 2 3)))))
  (is (= 2                   (destructure-test-2 (list 1 (list 2) 3))))
  (is (= 3                   (destructure-test-3 (list 1 (list 2 3) 3))))
  (is (= (list (list 1 2 3)) (destructure-test-4 (list 1 2 3))))

  (let [a (list 1 2 3 4)
        [b c & r] a]

    (is (= 1          b))
    (is (= 2          c))
    (is (= (list 3 4) r)))

  (let [a 1 b 2
        [c & r] (list 4 5)]

    (is (= 1 a))
    (is (= 2 b))
    (is (= 4 c))
    (is (= (list 5) r)))

  (let [[a & r] (list 1 2 3)
        rr (rest r)]
    (is (= (list 3) rr)))

  (is (= (list 1 2 3) (destructure-test-5)))
  (is (= 3            (destructure-test-6)))
  (is (= (list 3 4)   (destructure-test-7 1 2 3 4)))

  (let [[a & b :as all-list]   (list 1 2 3)
        [c     :as other-list] all-list]
    (is (= 1            a))
    (is (= (list 2 3)   b))
    (is (= (list 1 2 3) all-list))
    (is (= 1            c))
    (is (= (list 1 2 3) other-list)))

  (let [[_ _ a] (list 1 2 3)
        [_ b] (list 4 5 6)]
    (is (= 3 a))
    (is (= 5 b)))

  (let [a (list 1 2 3)
        [b c d e f g] a]
    (is (= 1   b))
    (is (= 2   c))
    (is (= 3   d))
    (is (= nil e))
    (is (= nil f))
    (is (= nil g))))

Conditionals

(deftest conditionals-test
  (is (= 2   (if 1 2)))
  (is (= 1   (if (zero? 0) 1 -1)))
  (is (= -1  (if (zero? 1) 1 -1)))
  (is (= 2   (when true 2)))
  (is (= 2   (if nil 1 2)))
  (is (= nil (if-let [a nil] a)))
  (is (= 5   (if-let [a 5] a)))
  (is (= 2   (if-let [[_ a] (list 1 2)] a)))
  (is (= nil (when-let [a nil] a)))
  (is (= 5   (when-let [a 5] a)))
  (is (= 2   (when-let [[_ a] (list 1 2)] a)))

  (is (= 1     (when (< 2 3) 1)))
  (is (= true  (let [a 1] (and (> a 0) (< a 10)))))
  (is (= false (let [a 11] (and (> a 0) (< a 10)))))
  (is (= true  (and true  (identity true))))
  (is (= false (and true  (identity false))))
  (is (= true  (or  true  (identity false))))
  (is (= false (or  false (identity false)))))

Logical Operators

(defn pos-neg-or-zero [n]
  (cond
    (< n 0) -1
    (> n 0)  1
    :else    0))

(deftest logical-operators-test
  (is (= true  (< 2)))
  (is (= true  (< 2 3 4 5)))
  (is (= true  (> 2)))
  (is (= false (> 2 3 4 5)))
  (is (= true  (> 6 5 4 3)))
  (is (= true  (>= 2)))
  (is (= true  (>= 5 4 3 2 2 2)))
  (is (= false (>= 5 1 3 2 2 2)))
  (is (= true  (<= 2)))
  (is (= true  (<= 2 2 3 4 5)))
  (is (= false (<= 2 2 1 3 4)))
  (is (= true  (= 2)))
  (is (= false (= 2 3)))
  (is (= true  (= 2 2 2 2)))
  (is (= true  (= 2 2.0 2)))
  (is (= false (= 2 2 2 2 3 5)))
  (is (= true  (= (list 1 2) (list 1 2))))
  (is (= false (= (list 1 2) (list 1 3))))
  (is (= true  (= true true)))
  (is (= false (not (= true true))))
  (is (= false (not 1)))

  (let [a (fn [x] (+ 1 x))
        b (fn [x] (inc x))]
    (is (= true  (= a a)))
    (is (= false (= a b)))
    (is (= true  (= nil ((fn [] )))))
    (is (= true  (= nil ((fn [x y] ) 1 2)))))

  (is (= -1  (pos-neg-or-zero -5)))
  (is (=  1  (pos-neg-or-zero  5)))
  (is (=  0  (pos-neg-or-zero  0)))

  (is (= true  (true? true)))
  (is (= false (true? false)))
  (is (= false (false? true)))
  (is (= true  (false? false)))
  (is (= false (= nil 1)))
  (is (= false (= 1 nil)))
  (is (= true  (= nil nil)))

  (is (= true  (pos? 1)))
  (is (= true  (pos? 0.2)))
  (is (= false (pos? 0)))
  (is (= false (neg? 1)))
  (is (= true  (neg? -1)))
  (is (= true  (zero? 0)))
  (is (= false (zero? 10)))
  (is (= true  (zero? (- 1 1))))
  (is (= true  (zero? (- 1.2 1.2))))
  (is (= true  (zero? (+ 1.2 -1.2)))))

Math

(deftest math-test
  (is (= 0.6 (+ 0.3 0.3)))
  (is (= 0   (+ )))
  (is (= 1   (+ 1)))
  (is (= 10  (+ 1 2 3 4)))
  (is (= 10  (+ 1 2.0 3 4)))
  (is (= -1  (- 1)))
  (is (= 0   (- 4 2 2)))
  (is (= 0   (- 4 2 2.0)))
  (is (= 1   (* )))
  (is (= 8   (* 2 2 2)))
  (is (= 8   (* 2.0 2 2)))
  (is (= 1   (/ 1)))
  (is (= 0.5 (/ 2)))
  (is (= 1   (/ 4 2 2)))
  (is (= 1   (/ 4 2 2.0)))

  (is (= 1         (floor 1.1)))
  (is (= 1         (floor 1.5)))
  (is (= 1         (floor 1.9)))
  (is (= 0         (mod 2 2)))
  (is (= 0         (mod 4 2)))
  (is (= 1         (mod 5 2)))
  (is (= 1         (mod 8 7)))
  (is (= 1         (min 1)))
  (is (= 1         (min 2 1)))
  (is (= 1         (min 3 5 7 1)))
  (is (= 1         (max 1)))
  (is (= 2         (max 2 1)))
  (is (= 7         (max 3 5 7 1)))

  (is (= 100 (scale 10 0 10 0 100)))
  (is (= 50  (scale 5 0 10 0 100)))
  (is (= 0   (scale 0 0 10 0 100)))
  (is (= 5   (clamp 10 0 5)))
  (is (= 10  (clamp 10 0 20)))
  (is (= 0   (clamp 10 -10 0)))
  (is (= -10 (clamp -100 -10 0)))

  (is (= 0     (number-combine (number-split 0))))
  (is (= 512   (number-combine (number-split 512))))
  (is (= 1024  (number-combine (number-split 1024))))
  (is (= 2048  (number-combine (number-split 2048))))
  (is (= 32000 (number-combine (number-split 32000))))

  (is (= true (not (nil? (rand)))))
  (is (= true (not (nil? (rand 15)))))

  (is (= -5 (bit-not  4)))
  (is (= -1 (bit-not  0)))
  (is (= 7  (bit-or   4 3)))
  (is (= 1  (bit-or   0 1)))
  (is (= 0  (bit-and  4 3)))
  (is (= 0  (bit-and  0 1)))
  (is (= 0  (bit-xor  4 4)))
  (is (= 1  (bit-xor  1 0)))
  (is (= 8  (bit-shift-left 4 1)))
  (is (= 16 (bit-shift-left 4 2)))
  (is (= 2  (bit-shift-right 4 1)))
  (is (= 1  (bit-shift-right 4 2)))

  (is (= 32         (sqrt 1024)))
  (is (= 2          (sqrt 4)))
  (is (= 8          (pow 2 3)))
  (is (= 16         (pow 2 4)))
  (is (= 1          (cos 0)))
  (is (= -0.99999   (cos 3.145)))
  (is (= 0          (sin 0)))
  (is (= -0.00340   (sin 3.145)))
  (is (= 0.98279    (atan2 45 30)))
  (is (= 180.19522  (to-degrees 3.145)))
  (is (= 3.14159    (to-radians 180)))

  (is (= 2.30258    (log 10)))
  (is (= 2          (log10 100)))

  (let [a 1
        b 2]
    (+ 1 a)
    (+ b a)
    (is (= 1 a))
    (is (= 2 b))
    (* 2 a)
    (* b a)
    (is (= 1 a))
    (is (= 2 b))
    (/ 2 a)
    (/ b a)
    (is (= 1 a))
    (is (= 2 b))
    (- 2 a)
    (- b a)
    (is (= 1 a))
    (is (= 2 b))))

Control

(deftest pid-controller-test
  (let [controller (pid-controller :kp 1
                                   :ki 0
                                   :kd 0
                                   :set-point 5
                                   :bounds [0 10 0 10]
                                   :continuous false)]

    (is (= 5 (controller 0)))
    (is (= 5 (controller 0))))

  (let [controller (pid-controller :kp 1
                                   :ki 1
                                   :kd 0
                                   :set-point 5
                                   :bounds [0 10 0 20]
                                   :continuous false)]

    (is (= 10 (controller 0)))
    (is (= 15 (controller 0)))
    (is (= 20 (controller 0)))
    (is (= 20 (controller 0))))

  (let [controller (pid-controller :kp 1
                                   :ki 0
                                   :kd 1
                                   :set-point 5
                                   :bounds [0 10 0 20]
                                   :continuous false)]

    (is (= 10 (controller 0)))
    (is (= 5 (controller 0))))

  (let [sp-fn (fn [] 5)
        controller (pid-controller :kp 1
                                   :ki 0
                                   :kd 1
                                   :set-point sp-fn
                                   :bounds [0 10 0 20]
                                   :continuous false)]

    (is (= 10 (controller 0)))
    (is (= 5 (controller 0)))))

(deftest state-machine-test
  (let [state (atom 0)
        machine (state-machine
                 (states
                  (off (swap! state inc) :off)
                  (on  (swap! state inc) :on))
                 (transitions
                  (off (fn [] true) on)
                  (on  (fn [] true) off)))]

    (is (= :off (machine)))
    (is (= :on  (machine)))

    (dotimes [_ 8]
      (machine))

    (is (= 10 (deref state))))

  (let [state (atom 0)
        machine (state-machine
                 (states
                  (a (swap! state inc))
                  (b (swap! state inc))
                  (c (swap! state inc))
                  (no-op (swap! state inc)))
                 (transitions
                  (a
                   (fn [] false) no-op
                   (fn [] true)  b)
                  (b
                   (fn [] true)  c)
                  (c
                   (fn [] false) no-op
                   (fn [] false) no-op
                   (fn [] true)  a
                   (fn [] false) no-op)))]
    (dotimes [_ 10]
      (machine))
    (is (= 10 (deref state))))

  (let [state (atom nil)
        machine (state-machine
                 (states
                  (a (swap! state conj 1))
                  (b (swap! state conj 2))
                  (c (swap! state conj 3))
                  (no-op ))
                 (transitions
                  (a
                   (fn [] true) b
                   (fn [] true) c
                   (fn [] true) no-op)
                  (b (fn [] true) no-op)
                  (c (fn [] true) no-op)
                  (no-op (fn [] true) no-op)))]
    (dotimes [_ 50]
      (machine))
    (is (= (list 2 1) (deref state))))

  (let [value (atom 0)
        machine (state-machine 
                 (states
                  (increment (swap! value inc))
                  (no-op ))
                 (transitions
                  (increment
                   (fn [] true) increment
                   (fn [] true) no-op)
                  (no-op
                   (fn [] true) no-op)))]
    (machine)
    (machine)
    (is (= 2 (deref value)))))

Timing

(deftest timing-test
  (let [now (millis)]
    (sleep 150)
    (is (>= (- (millis) now) 100)))
  (is (>= (time-fn (fn [] (sleep 150) (+ 1 1))) 100))
  (is (>= (benchmark (fn [] (sleep 20) (+ 1 1)) 10) 10)))

(defn ping [] true)

(deftest fn-throttler-test
  (let [throttled-ping (fn-throttler ping 1 :second :blocking)
        begin (millis)]
    (throttled-ping)
    (throttled-ping)
    (throttled-ping)
    (is (> (- (millis) begin) 2000))
    (is (throttled-ping)))


  (let [throttled-ping (fn-throttler ping 1 :second :non-blocking)
        begin (millis)]
    (throttled-ping)
    (throttled-ping)
    (throttled-ping)
    (is (nil? (throttled-ping)))
    (is (< (- (millis) begin) 1000))))

XOR Stream

(def xor-stream-state (atom nil))

(defn xor-sample-read-stream [buf]
  (let [buffer (atom buf)]
    (list
     (fn []
       (let [f (first (deref buffer))]
         (swap! buffer rest)
         f))
     (fn []
       (count (deref buffer)))
     (fn [vals]
       (reset! xor-stream-state vals)))))

(defn xor-sample-write-stream []
  (let [buffer (atom (list))]
    (list
     (fn [v]
       (swap! buffer conj v))
     (fn []
       (reverse (deref buffer))))))

(deftest xor-stream-test
  (let [[writer get-buffer] (xor-sample-write-stream)
        encoder (xor-stream-encoder writer)
        data (list (list 1 2 3 4)
                   (list 5 6 7 8))]
    (doseq [d data] 
      (encoder d))

    (let [[read in-waiting handler] (xor-sample-read-stream (get-buffer))
          decoder (xor-stream-decoder read in-waiting handler)]
      (dotimes [i 4]
        (decoder))
      (is (= (list 1 2 3 4) @xor-stream-state))
      (dotimes [i 4]
        (decoder))
      (is (= (list 5 6 7 8) @xor-stream-state)))))

Misc

(deftest doto-test
  (let [st (atom )
        add (fn [s v]
              (swap! s conj v))]
    (doto st
      (add 1)
      (add 2)
      (add 3))
    (is (= (list 3 2 1) @st))))

FFI

(deftest ffi-test
  (is (= true  ((fn [a b] "__result = obj<boolean>((a == b))") (list 1 2) (list 1 2))))
  (is (= false ((fn [a b] "__result = obj<boolean>((a != b))") (list 1 2) (list 1 2))))
  (is (= true  ((fn [a b] "__result = obj<boolean>((a != b))") (list 1 2) 1)))
  (is (= false ((fn [a b] "__result = obj<boolean>((a == b))") 1          (list 1 2))))



  (is (=  nil   (my-find (list 5 5) (list (list 1 2)
                                          (list 2 3)
                                          (list 4 5)))))
  (is (=  true  (my-find (list 1 2) (list (list 1 2)
                                          (list 2 3)
                                          (list 4 5)))))
  (is (=  true  (my-find (list 4 5) (list (list 1 2)
                                          (list 2 3)
                                          (list 4 5)))))

  (is (= (list 1 2 3) (my-sort > (list 1 3 2))))
  (is (= (list 3 2 1) (my-sort < (list 1 3 2)))))

Module System

Run import tests.

(require '[modules.module-a :as mod-a]
         '[modules.module-b :as mod-b])

(deftest module-test-load-as
  (is (= 10  (mod-a/helper-a)))
  (is (= 1   (mod-a/helper-b)))
  (is (= 10  ((mod-a/ten-fn))))
  (is (= 11  ((mod-b/eleven-fn))))
  (is (= 1   (mod-a/helper-c)))
  (is (= 42  (mod-b/macro-call)))
  (is (= :b  (:a (mod-a/some-d-list))))
  (is (= 42  (mod-b/native-single-argument 42))))

(require 'modules.module-a
         'modules.module-b)

(require '[modules.module-c :as mod-c]
         'modules.module-d)

(deftest module-test-load
  (is (= 10  (modules.module-a/helper-a)))
  (is (= 1   (modules.module-a/helper-b)))
  (is (= 10  ((modules.module-a/ten-fn))))
  (is (= 11  ((modules.module-b/eleven-fn))))
  (is (= 1   (modules.module-a/helper-c)))
  (is (= 42  (modules.module-b/macro-call)))
  (is (= 25  (cxx " __result = obj<number>(dummy_native_fn());")))
  (is (= 2   (cxx "__result = obj<number>((number_t)std::sqrt(4));"))))

(run-all-tests)
Dummy Modules

Create some dummy programs under test,

(require '[modules.module-a :as mod-a])
(require '[modules.module-a :as mod-a])
(require '[modules.module-b :as mod-b])

(native-declare "const int XYZ_SIZE = 123;")
(native-declare "int xyz_arr[XYZ_SIZE];")

Create some dummy libs under test/modules,

(configure-runtime! FERRET_PROGRAM_MAIN "ferret::program_no_exec()")

(defn helper-a [] 10)

(defmacro ten-fn [] `(~'fn [] 10))

(defmacro helper-b []
  (reduce (fn [a b] (+ a b)) (list 1 2 3))
  1)

(defn helper-c []
  (helper-b))

(defn update-aux []
  )

(def update-data
  (fn-throttler update-aux 1000 :second :blocking))

(defn some-d-list [] {:a :b :c :d})
(require '[modules.module-c :as mod-c])

(defn helper-b []
  (mod-c/helper-c))

(defn eleven-fn []
  (mod-c/eleven-fn))

(defnative native-single-argument [x]
  (on "defined FERRET_STD_LIB"
      ("utility") ;; dummy include
      "__result = obj<number>(number::to<int>(x));"))

(defnative macro-aux []
  (on "defined FERRET_STD_LIB"
      "__result = obj<number>((number_t)42);"))

(defmacro macro-call []
  `(~'do (~'macro-aux)))
(native-header "cmath")

(defn helper-c []
  (print "Module C"))

(defmacro eleven-fn []
  `(~'fn [] 11))
(native-declare "int dummy_native_fn(){ return 25; }")
(defn foo [] 1)

Testing

(deftest testing-unit-test
  (is (= "" (exec-form '((assert (= 2 1) (print "fail"))) {:release true})))
  (compare-output "" (run-all-tests))
  (compare-output
   (str "fail in (= 2 3) \n"
        " expected 2.0000 \n"
        "      got 3.0000\n"
        "fail (not (some-true))\n"
        "fail in (= 5 (apply + (list 1 2 3))) \n"
        " expected 5.0000 \n"
        "      got 6.0000\n"
        "fail in (= 3 (some-fn)) \n"
        " expected 3.0000 \n" 
        "      got 2.0000\n")

   (defn some-true [] true)

   (deftest some-test
     (is (= 2 3))
     (is (= 2 2))
     (is (not (some-true)))
     (is (some-true)))

   (defn some-fn [] 2)

   (deftest some-other-test
     (is (= 5 (apply + (list 1 2 3))))
     (is (= 6 (apply + (list 1 2 3))))
     (is (= 3 (some-fn)))
     (is (= 2 (some-fn))))

   (run-all-tests)))

Data Structures

Number

(deftest number-test
  (is (= 0.5       1/2))
  (is (= 0.33333   1/3))
  (is (= 3501      0xDAD))
  (is (= 2748      0xABC)))


(deftest fixed-real-test
  (is (= 25          (cxx "char n = 25;
                           auto x = ferret::fixed_real<32,8>(n);
                           n = (char)x;
                           __result = obj<number>((number_t)n)")))

  (is (= 25          (cxx "long n = 25;
                           auto x = ferret::fixed_real<64,8>(n);
                           char v = (char)x;
                           __result = obj<number>((number_t)v)")))

  (is (= 2500        (cxx "unsigned long n = 2500;
                           auto x = ferret::fixed_real<64,8>(n);
                           unsigned long v = (unsigned long)x;
                           __result = obj<number>((number_t)v)")))

  (is (= 1024        (cxx "int n = 1024;
                           auto x = ferret::fixed_real<32,8>(n);
                           n = (int)x;
                           __result = obj<number>((number_t)n)")))

  (is (= 10.25       (cxx "auto x = ferret::fixed_real<32,8>();
                           (void)x;
                           auto y = ferret::fixed_real<32,8>();
                           (void)y;
                           x = 10; y = 0.250;
                           __result = obj<number>((real_t)(x + y))")))

  (is (= true       (cxx "long n = std::numeric_limits<int>::max() + 1024L;
                           auto x = ferret::fixed_real<64,8>(n);
                           n = (long)x;
                           __result = obj<boolean>((n == ((long)std::numeric_limits<int>::max() + 1024L)))")))

  (is (= 6.25       (cxx "auto x = ferret::fixed_real<32,8>(0);
                          for(int i = 0; i < 100; i++)
                            x += ferret::fixed_real<32,8>(0.0625);
                          __result = obj<number>((double)x)")))

  (is (= 35.25       (cxx "auto x = ferret::fixed_real<32,8>(22.75);
                           auto y = ferret::fixed_real<32,8>(12.5);
                           __result = obj<number>((double)(x + y))")))

  (is (= (- 0.25)    (cxx "auto x = ferret::fixed_real<32,8>(22.75);
                           auto y = ferret::fixed_real<32,8>(22.5);
                           __result = obj<number>((double)(y - x))")))

  (is (= (- 0.0625)  (cxx "auto x = ferret::fixed_real<32,8>(-0.25);
                           auto y = ferret::fixed_real<32,8>(4);
                           __result = obj<number>((double)(x / y))")))

  (is (= 9.9375      (cxx "auto x = ferret::fixed_real<32,8>(-0.0625);
                           auto y = ferret::fixed_real<32,8>(-10);
                           __result = obj<number>((double)(x - y))")))

  (is (= (- 29.8125) (cxx "auto x = ferret::fixed_real<32,8>(9.9375);
                           auto y = ferret::fixed_real<32,8>(-3);
                           __result = obj<number>((double)(x * y))")))

  (is (= (- 30)      (cxx "auto x = ferret::fixed_real<32,8>(-29.8125);
                           auto y = ferret::fixed_real<32,8>(0.1875);
                           __result = obj<number>((double)(x - y))"))))

Sequence

(deftest sequence-test
  (is (= true  (= (list ) (list ))))
  (is (= 0     (count (list ))))
  (is (nil?    (first (rest (rest (list))))))
  (is (= false (= (list )       (list 1 2 3))))
  (is (= false (= (list )       (list nil))))
  (is (= false (= (list 1 2 3)  (list 1 2))))
  (is (= false (= (list 1 2)    (list 1 2 3))))
  (is (= true  (= (list 1 2 3)  (list 1 2 3))))
  (is (= false (= (list 1 2 3)  (list 1 2 4))))
  (is (= false (= (list 1 1 3)  (list 1 2 3))))

  (is (= (list )            (rest (list ))))
  (is (= (list 1)           (cons 1 nil)))
  (is (= (list nil)         (cons nil nil)))
  (is (= 1                  (first (list 1 2 3 4))))
  (is (= 2                  (second (list 1 2 3 4))))
  (is (= (list 2 3 4)       (rest (list 1 2 3 4))))
  (is (= (list 3 4)         (rest (rest (list 1 2 3 4)))))
  (is (= (list 3 3 4)       (cons 3 (rest (rest (list 1 2 3 4))))))
  (is (= 3                  (first (cons 3 (rest (rest (list 1 2 3 4)))))))
  (is (= 4                  (count (list 1 2 3 4))))
  (is (= (list 4 3 2 1 1 2) (conj (list 1 2) 1 2 3 4)))
  (is (= (list 4 3 2 1)     (conj nil 1 2 3 4)))
  (is (= 21                 (reduce + (list 1 2 3 4 5 6))))
  (is (= 21                 (apply + (list 1 2 3 4 5 6))))

  (is (= 1   (nth (list 1 2 3) 0)))
  (is (= 2   (nth (list 1 2 3) 1)))
  (is (= 3   (nth (list 1 2 3) 2)))
  (is (= nil (nth (list 1 2 3) 10)))
  (is (= nil (nth (list 1 2 3) -10)))

  (is (= (list 0 1 2 3 4 5 6 7 8 9)  (nthrest (range 10) 0)))
  (is (= (list )                     (nthrest (range 10) 20)))
  (is (= (list 5 6 7 8 9)            (nthrest (range 10) 5)))

  (is (= (list 1 2 3 4) (drop 0 (list 1 2 3 4))))
  (is (= (list 2 3 4)   (drop 1 (list 1 2 3 4))))
  (is (= (list 3 4)     (drop 2 (list 1 2 3 4))))
  (is (= (list )        (drop 4 (list 1 2 3 4))))
  (is (= (list )        (drop 5 (list 1 2 3 4))))

  (is (= (list 6 5 4 3 2 1) (reverse (list 1 2 3 4 5 6))))
  (is (= (list 6 5 4 3 2)   (reduce (fn [h v] (conj h (inc v))) (list) (list 1 2 3 4 5))))
  (is (= (list 4 3 2 1 0)   (reduce (fn [h v] (conj h (dec v))) (list) (list 1 2 3 4 5))))


  (is (= 1 (first (repeatedly 3 (fn [] 1)))))
  (is (= 3 (count (repeatedly 3 (fn [] 1)))))
  (is (= 2 (->> (repeatedly 3 (fn [] 1)) (map inc) first)))
  (is (= 2 (->> (repeatedly (fn [] 1)) (take 3) (map inc) reverse first)))

  (is (= 2 (count (filter true? (list true false true false)))))
  (is (= 2 (count (filter false? (list true false true false)))))
  (is (= 3 (count (filter false? (list true false true false false)))))
  (is (= 2 (count (filter (fn [x] (not (false? x))) (list true false true false false)))))

  (let [sum (cxx "var alist = runtime::list(obj<number>(1),obj<number>(2),obj<number>(3));
                  number_t sum = 0;
                  for(auto const& it : runtime::range(alist)){
                    sum += number::to<number_t>(it);
                  }
                  __result = obj<number>(sum);")]
    (is (= 6 sum))))

Lazy Sequence

(defn lazy-countdown [n]
  (if (>= n 0)
    (cons n (lazy-seq (lazy-countdown (- n 1))))))

(defn ints-from [n]
  (cons n (lazy-seq (ints-from (inc n)))))

(defn fib-seq
  ([]
   (fib-seq 0 1))
  ([a b]
   (lazy-seq
    (cons b (fib-seq b (+ a b))))))

(deftest lazy-seq-test
  (is (= false (= (range 10) (range 15))))
  (is (= false (= (range 15) (range 10))))
  (is (= true  (= (range 10) (range 10))))
  (is (= 10    (first (ints-from 10))))
  (is (= 11    (first (rest (ints-from 10)))))
  (is (= 12    (first (rest (rest (ints-from 10))))))
  (is (= 10    (first (lazy-countdown 10))))
  (is (= 9     (first (rest (lazy-countdown 10)))))
  (is (= 8     (first (rest (rest (lazy-countdown 10))))))
  (is (= 11    (count (lazy-countdown 10))))

  (is (= 2   (first (map inc (list 1 2 3)))))
  (is (= 0   (first (map dec (list 1 2 3)))))
  (is (= 4   (first (map (fn [x] (+ 3 x)) (list 1 2 3)))))
  (is (= 3   (count (map inc (list 1 2 3)))))
  (is (= 10  (apply + (range 5))))
  (is (= 5   (count (range 5))))
  (is (= 2   (first (take 2 (map inc (list 1 2 3))))))
  (is (= 3   (first (rest (take 2 (map inc (list 1 2 3)))))))
  (is (= 3   (count (take 20 (map inc (list 1 2 3))))))
  (is (= 1   (first (concat (list 1 2 3) (list 4 5 6)))))
  (is (= 4   (first (drop 3 (concat (list 1 2 3) (list 4 5 6))))))
  (is (= 21  (reduce + (concat (list 1 2 3) (list 4 5 6)))))

  (is (= (list -2 -1)          (take-while neg? (list -2 -1 0 1 2 3))))
  (is (= (list -2 -1 0 1 2)    (take-while #(< % 3) (list -2 -1 0 1 2 3))))
  (is (= (list -2 -1 0 1 2 3)  (take-while #(<= % 3) (list -2 -1 0 1 2 3))))
  (is (= (list -2 -1 0 1 2 3)  (take-while #(<= % 4) (list -2 -1 0 1 2 3))))

  (is (empty? (concat)))

  (= (list 1 1 2 3 5) (take 5 (fib-seq)))
  (= 12 (apply + (take 5 (fib-seq))))

  (is (= (list (list 0 1 2 3) (list 4 5 6 7))                              (partition 4 (range 10))))
  (is (= (list (list 0 1 2 3) (list 4 5 6 7))                              (partition 4 (range 8))))
  (is (= (list (list 0 1 2 3) (list 6 7 8 9) (list 12 13 14 15))           (partition 4 6 (range 20))))
  (is (= (list (list 0 1 2) (list 6 7 8) (list 12 13 14) (list 18 19 42))  (partition 3 6 (list 42) (range 20))))
  (is (= (list (list 0 1 2 3) (list 6 7 8 9) (list 12 13 14 15) (list 18 19 42 43)) (partition 4 6 (list 42 43 44 45) (range 20)))))

Associative Containers

(deftest d-list-test
  (let [m (new-d-list 0 (list 0 1)
                      1 (list 1 2))
        mr {:a 1 :b 2}
        mn {1 2 3 4}]

    (is (= (list 1 0)                    (keys m)))
    (is (= (list (list 1 2) (list 0 1))  (vals m)))
    (is (= (list 1 2)                    (m 1)))
    (is (= m                             m))
    (is (= (list 0)                      (keys (dissoc m 1))))
    (is (= mr                            mr))
    (is (= (list :b :a)                  (keys mr)))
    (is (= (list 2  1)                   (vals mr)))
    (is (= 1                             (:a mr)))
    (is (= 1                             (get mr :a 10)))
    (is (= 10                            (get mr :c 10)))
    (is (= 1                             (mr :a)))
    (is (= 1                             (mr :a 10)))
    (is (= 10                            (mr :c 10)))
    (is (= 1                             (:a mr)))
    (is (= 1                             (:a mr 10)))
    (is (= 10                            (:c mr 10)))
    (is (= 6                             (->> mn
                                              (map second)
                                              (apply +))))))

Lambda

(deftest lambda-test
  (let [f1 (fn [])
        f2 (fn [])
        m-func (fn
                 ([a] 1)
                 ([a b] 2)
                 ([a b & c] 3)
                 ([a b [c d] & e] 4))]
    (is (= true  (= f1 f1)))
    (is (= false (= f1 f2)))
    (is (= true  (= f1 (do f1))))
    (is (= false (= f2 (do f1))))
    (is (= 1 (m-func 1)))
    (is (= 2 (m-func 1 2)))
    (is (= 3 (m-func 1 2 3)))
    (is (= 4 (m-func 1 2 (list 3 3) 4)))))

Pointer

(deftest pointer-test
  (let [a-ptr (cxx "__result = obj<pointer>(nullptr);")
        b-ptr (cxx "__result = obj<pointer>(new int);")
        gc    (fn [p] "delete pointer::to_pointer<int>(p);")]
    (is (= true  (= a-ptr a-ptr)))
    (is (= false (= a-ptr b-ptr)))
    (is (= true  (= b-ptr b-ptr)))
    (gc b-ptr)))

(deftest value-test
  (let [obj-42 (make-data 42)
        obj-24 (make-data 24)
        val-42 (get-data obj-42)
        val-24 (get-data obj-24)]
    (is (=    obj-42 obj-42))
    (is (not= obj-42 obj-24))
    (is (=    val-42 42))
    (is (=    val-24 24))
    (is (=    25     (do (inc-data obj-24) 
                         (get-data obj-24))))))

Atom

(deftest atom-test
  (let [a (atom nil)
        b (atom nil)]
    (is (= nil          (deref a)))
    (is (= 1            (do (reset! a 1) (deref a))))
    (is (= 2            (do (swap! a inc) (deref a))))
    (is (= (list 1 2 3) (do (reset! a (list 1 2 3)) (deref a))))
    (is (= 6            (do (swap! a (fn [l] (reduce + l))) (deref a))))
    (is (= true         (= a a)))
    (is (= false        (= a b)))
    (is (= false        (= a 3.14)))))

Keyword

(deftest keyword-test
  (is (= true  (= :test  :test)))
  (is (= false (= :test  :other_test)))
  (is (= true  (= :space (cxx "__result = obj<keyword>(\":space\")")))))

String

(deftest string-test
  (let [s1       "Some String"
        s1-added "ASome String"
        s2       "Other String"
        s1-ret   (fn [] "__result = obj<string>(\"Some String\");")
        s1-eq    (fn [s] "__result = obj<boolean>((string::to<std::string>(s) == \"Some String\"))")
        s2       "Ali Topu At"
        s3       (fn [] "std::string s = \"Some String\";
                        __result = obj<string>(s);")]
    (is (= s2 (new-string "Ali Topu At")))
    (is (= false (= s1 s2)))
    (is (= true  (= s1 s1)))
    (is (= true  (= s1 (s3))))
    (is (= false (= s1 3.14)))
    (is (= true  (= s1 (s1-ret))))
    (is (= true  (s1-eq s1)))
    (is (= 99 \c))
    (is (= \S (first s1)))
    (is (= s1-added (cons 65 s1)))
    (is (= s1 (rest (cons 65 s1))))))

Memory Pool

(native-define "#define FERRET_MEMORY_POOL_SIZE 4194304") ;; 4 MB
(native-declare "void* ptr;")

(native-declare "ferret::mem::allocator::memory_pool<size_t,14> tiny_pool;")
(let [next-page (fn [idx]
                  "size_t i = number::to<size_t>(idx);
                        __result = obj<number>((number_t)tiny_pool.next_page(i))")
      malloc (fn [size]
               "size_t s = number::to<size_t>(size);;
                     ptr = tiny_pool.allocate(sizeof(size_t) * s);
                     __result = obj<boolean>((ptr != nullptr));")
      free (fn [] "tiny_pool.free(ptr);")]

  (assert (= 0 (next-page 0)))
  (assert (malloc 2))
  (assert (= 3 (next-page 0)))
  (assert (malloc 4))
  (assert (= 8 (next-page 2)))
  (free)
  (assert (= 3 (next-page 2)))
  (assert (false? (malloc 40)))
  (assert (malloc 6))
  (assert (malloc 1))
  (assert (malloc 1))
  (assert (false? (malloc 10))))

(native-declare "ferret::mem::allocator::memory_pool<size_t,256> even_pool;")
(let [next-page (fn [idx]
                  "size_t i = (size_t)number::to<size_t>(idx);
                        __result = obj<number>((number_t)even_pool.next_page(i))")
      malloc (fn [size]
               "size_t s = number::to<size_t>(size);
                     ptr = even_pool.allocate(sizeof(size_t) * s);
                     __result = obj<boolean>((ptr != nullptr));")
      free (fn [] "even_pool.free(ptr);")]

  (assert (= 0 (next-page 0)))
  (assert (malloc 255))
  (assert (= 256 (next-page 0)))
  (free)
  (assert (= 0 (next-page 0)))
  (assert (false? (malloc 256)))
  (assert (= 0 (next-page 0))))

(native-declare "ferret::mem::allocator::memory_pool<size_t,255> odd_pool;")
(let [next-page (fn [idx]
                  "size_t i = number::to<size_t>(idx);
                       __result = obj<number>((number_t)odd_pool.next_page(i))")
      malloc (fn [size]
               "size_t s = number::to<size_t>(size);
                     ptr = odd_pool.allocate(sizeof(size_t) * s);
                     __result = obj<boolean>((ptr != nullptr));")
      free (fn [] "odd_pool.free(ptr);")]

  (assert (= 0 (next-page 0)))
  (assert (malloc 254))
  (assert (= 255 (next-page 0)))
  (free)
  (assert (= 0 (next-page 0)))
  (assert (false? (malloc 255)))
  (assert (= 0 (next-page 0))))

Concurrency

(deftest future-test
  (is (= 42    @(future (+ 41 1))))
  (is (= 42    @(future (sleep 100) (+ 40 2))))
  (is (= false  (future-done? (future (sleep 100) :false))))
  (is (= true   (let [f (future :true)]
                  (deref f)
                  (future-done? f))))
  (is (= 42    @(thread #(+ 41 1)))))

(deftest delay-test
  (let [d (delay   (+ 1 1))]
    (is (= true    (delay? d)))
    (is (= 2       @d))
    (is (= 2       @d))
    (is (= 42      (force (delay 42))))))

Roadmap

Compiler

Data Structures

Core

Libraries

  • cpr - C++ Requests: Curl for People
  • mongoose mqtt - Mongoose MQTT Client/Server
  • xpcc - C++ microcontroller framework

Issues

The Rearview

Core

Created: 2017-08-21 Mon 18:15

Emacs 24.5.1 (Org mode 8.2.10)

Validate