Ferret Programmer's Manual

Table of Contents

Getting Started

What Is Ferret

Ferret is a free software lisp implementation designed to be used in real time embedded control systems. Ferret lisp compiles down to self contained C++11. Generated code is 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
      • 2.0 / 16 MHz AVR
      • 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),

Supported package managers,

  • Debian/Ubuntu
    • Add repository - echo "deb [trusted=yes] https://ferret-lang.org/debian-repo ferret-lisp main" >> /etc/apt/sources.list
    • Install Ferret - apt-get install ferret-lisp

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
(require '[ferret.arduino :as gpio])

(gpio/pin-mode 13 :output)

(forever
 (gpio/digital-write 13 1)
 (sleep 500)
 (gpio/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)

(require '[ferret.arduino :as gpio])

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

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

(defn make-led-toggler [pin]
  (fn []
    (->> (gpio/digital-read pin)
         (bit-xor 1)
         (gpio/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. It is heavily inspired by Clojure. Functions / Macros that are present in both Ferret and Clojure 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 lisp tutorial. It is a specification of the subset of lisp implemented by Ferret, and the particular workings of the Runtime and standard library.

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 Ferret code and converts it to a Intermediate representation by taking the Ferret form and running it through some transformations. This IR is then run through Code Generation module to create C++ code. Runtime 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. Core is the standard library of Ferret, provides a ton of general-purpose functionality for writing robust, maintainable embedded applications.

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

Sample Makefile for automating compilation and upload on an Arduino,

FERRET  = ferret
INPUT   = core.clj
OUTPUT  = core.ino
ARDUINO = ~/arduino-1.8.5/arduino
BOARD   = arduino:sam:arduino_due_x_dbg
PORT    = /dev/ttyACM0
RM      = rm -f

.PHONY: verify upload clean

default: verify

core: core.clj
        $(FERRET) -o $(OUTPUT)

verify: core
        $(ARDUINO) --board $(BOARD) --verify $(OUTPUT)

upload: core
        $(ARDUINO) --board $(BOARD) --port $(PORT) --upload $(OUTPUT)

clean:
        $(RM) $(OUTPUT)

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.

Yocto

Install Yocto and create a package for your application. A sample recipe for a simple Ferret application is given below.

recipes-example/
└── core
    ├── core-0.1
    │   └── core.clj
    └── core_0.1.bb
;; core.clj
(println "Hello World!")
# core_0.1.bb
SUMMARY = "Simple Ferret application"
SECTION = "examples"
LICENSE = "MIT"
LIC_FILES_CHKSUM = "file://${COMMON_LICENSE_DIR}/MIT;md5=0835ade698e0bcf8506ecda2f7b4f302"

SRC_URI = "file://core.cpp"

S = "${WORKDIR}"

do_compile() {
         ferret -i ./core.clj
         ${CXX} -std=c++11 core.cpp -o core
}

do_install() {
         install -d ${D}${bindir}
         install -m 0755 core ${D}${bindir}
}

Finally add the application to your layer.conf.

IMAGE_INSTALL_append = " core"

Raspberry Pi

Clone required layers,

git clone -b jethro git://git.yoctoproject.org/meta-raspberrypi

Add meta-raspberrypi to BBLAYERS in build/conf/bblayers.conf, and and Select your machine type in build/conf/local.conf. See Supported Machines for MACHINE type. Build the image,

bitbake rpi-basic-image

Write the image,

dd if=tmp/deploy/images/raspberrypi2/rpi-basic-image-raspberrypi2.rpi-sdimg of=/dev/mmcblk0

Building From Sources

The latest sources are available at,

Dependencies,

  • make
  • Java
  • Emacs (24.5)
  • Leiningen

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

make

This will extract the source from this file to src/ directory and build the jar and executable distributions to bin/ directory. Makefile 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. Documentation can be built using,

make docs

Unit tests can be run using,

make test

A release can be made by running,

make docker-release

This will compile ferret run unit tests against all supported compilers/frameworks and generate a release/ folder containing deployment files.

Compiler

Ferret has a similar architecture to other modern compilers,

compiler_arch.png

Figure 1: Ferret Compiler Architecture

First, an input file containing Ferret 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

Ferret (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 Ferret forms in preparation to generate C++ code. Final intermediate representation can be directly compiled to C++. Any Ferret 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)
       (inline-global-fns options)
       (escape-analysis)
       (symbol-conversion)))

Generate 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 [file-name      (str (.replace (str m) "." "/") ".clj")
                       mod            (-> (if (clojure.java.io/resource file-name)
                                            file-name
                                            (str (:path options) file-name))
                                          (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 Core.

(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] (cons '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 exit-failure]])

      (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)
                                       ;;strip ns from symbols
                                       (morph-form symbol? #(-> % name symbol)))))))]
      (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 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]]
                    (when (odd? (count bindings))
                      (warn
                       (str "let requires an even number of forms in binding vector => " bindings))
                      (exit-failure))

                    (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 lisp are not valid C++ identifiers. This transformation converts all symbols that are not legal C++ identifiers into legal ones.

(defn escape-cpp-symbol [s]
  (clojure.string/escape
   (str s)
   {\- \_ \* "_star_" \+ "_plus_" \/ "_slash_"
    \< "_lt_" \> "_gt_" \= "_eq_" \? "_QMARK_"
    \! "_BANG_" \# "_"}))

(defn symbol-conversion [form]
  (let [c (comp #(symbol (escape-cpp-symbol %))
                #(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))))

(inline-global-fns
 '((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 inline-global-fns-pure [form fn-defs fn-table]
  (let [pure-fn-table  (apply hash-map (flatten fn-table))
        def-fn? (fn [f]
                  (and (is-form? 'def f)
                       (pure-fn-table (second f))
                       (is-form? 'fir-new-lambda (->> f (drop 2) first))))
        invoke  #(if-let [imp (pure-fn-table %)]
                   (list 'fir-new-lambda imp)
                   %)

        no-def-fn    (reduce (fn[h v] (remove-form h def-fn?)) form fn-defs)
        inline-fns   (reduce (fn[h [name gensym]]
                               (morph-form h
                                           #(or (is-form? name %)
                                                (is-form? 'def %))
                                           (fn [f] (map invoke f))))
                             no-def-fn fn-table)]
    (reduce (fn[h [name gensym]]
              (morph-form h #(and (symbol? %)
                                  (= % gensym))
                          (fn [_] (identity name))))
            inline-fns fn-table)))

(defn inline-global-fns [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 (inline-global-fns-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 exit-failure []
  (System/exit 1))

(defn exit-success []
  (System/exit 0))

(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)
          (exit-failure))))))

(defn read-clojure-file [f]
  (let [ns (gensym)
        ns-str (str ns)]
    (create-ns ns)
    (binding [*ns* (the-ns ns)]
      (refer 'clojure.core)
      (-> (read-string (str \( (read-file f) \)))
          (morph-form symbol? #(if (= (namespace %) ns-str)
                                 (-> % name symbol)
                                 %))
          ;;replace clojure.core/fn with fn
          ;;replace clojure.core/while with while
          (morph-form (fn [x]
                        (and (is-form? 'quote x)
                             (or (= 'clojure.core/fn    (second x))
                                 (= 'clojure.core/defn  (second x))
                                 (= 'clojure.core/while (second x)))))
                      (fn [[_ s]] `'~(-> s name symbol)))))))

(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 lisp 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_, all user defined functions are defined in file name namespace.)

  • 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
     "#ifndef FERRET_OBJECT_$guard$
      #define FERRET_OBJECT_$guard$
      $if(embed_type)$
        namespace runtime {
          namespace type {
             const size_t $type$ = $type_val$;}}
        $endif$
      $body$
      #endif"
     :guard       (.toUpperCase (str name))
     :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()"]
                    ;; multi arity dispacth
                    (is-form? 'fn_multi_arity (first body))
                    (emit options (first body) state)
                    ;; ffi call
                    (->> (map string? body)
                         (every? true?))
                    (let [buffer (StringBuilder.)]
                      (doseq [b body]
                        (.append buffer b))
                      (let [body (.toString buffer)]
                        (if (.contains body "__result")
                          ["var __result" body "__result"]
                          [body "nil()"])))
                    ;; s-expression
                    :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
                  (str (new-lambda-stack default) ".invoke(_args_)")
                  "nil()")
        switch  (render-template
                 "switch(runtime::count(_args_)) {
                  $fns: {fn|
                    case $fn.case$ :
                       return $fn.fn$.invoke(_args_); };separator=\"\n\"$
                  }"
                 :fns (map (fn [[s f]] {:fn (new-lambda-stack f) :case s}) switch))]
    [switch 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 options]
  (let [{:keys [body lambdas symbol-table native-headers objects
                native-declarations native-defines]} source
        native-headers (->> native-headers flatten (into #{}))
        file-ns        (-> options :base-name escape-cpp-symbol)
        main           (render-template
                        (read-file "ferret/main.cpp")
                        :file       file-ns)]
    (render-template
     "
        $native_defines:{$it$} ;separator=\"\n\"$
        $native_headers:{#include \"$it$\"} ;separator=\"\n\"$

        #ifndef FERRET_RUNTIME_H
        #define FERRET_RUNTIME_H
         $ferret_h$
        #endif

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

        namespace $file$ { 
         using namespace ferret;
         typedef ferret::boolean boolean; 
        }

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

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

        // Runtime Implementations
        #ifndef FERRET_RUNTIME_CPP
        #define FERRET_RUNTIME_CPP
         $ferret_cpp$
        #endif

        // Lambda Prototypes
        namespace $file${
          $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 $file${
          $lambda_bodies:{$it$} ;separator=\"\n\"$
        }

        // Program Run
        namespace $file${
         void main(){
          $body:{$it$;} ;separator=\"\n\"$ 
         }
        }

        $ferret_main$"
     :file                 file-ns
     :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          main)))

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 file-name [options]
  (str (:base-name options) "." (:source-extension options)))

(defn cpp-file-name [options]
  (str (:output-path options) (file-name 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 [args             (fn [k]
                             (->> args :options k))
          output           (if (args :output)
                             (args :output)
                             input)
          output-path      (file-path output)
          output-extension (if (args :output) 
                             (file-extension (args :output))
                             default-cpp-extension)
          base-name        (file-base-name output)
          input-path       (file-path input)
          output-file      (make-file output-path base-name output-extension)
          default-options  (compile-options-parse-source output-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 :ast))
          (assoc :compile-program    (args :compile))
          (assoc :release            (args :release))
          (assoc :format-code        (not (args :disable-formatting)))
          (assoc :global-functions   (args :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 options)]
    (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++"] (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)))
                  (exit-failure)))]
      (if (not= 0 (:exit ret))
        (do (warn "build error")
            (warn (:err ret))
            (exit-failure)))
      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))))))

(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 Output File Formatting Using clang-format"]
   [nil  "--global-functions"   "Disables inline-global-fns 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))
      (exit-success))

    (when (not (file-exists input))
      (warn "no input file")
      (exit-failure))

    (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))
    (exit-success)))

Logging

(.reset (java.util.logging.LogManager/getLogManager))

(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 (doto (java.util.logging.ConsoleHandler.)
                   (.setFormatter log-formatter)))

(def logger (doto (java.util.logging.Logger/getLogger "")
              (.addHandler log-handler)
              (.setLevel   java.util.logging.Level/INFO)))

Runtime

Runtime needed on the C++ side to support 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_ALLOCATOR>. See Reference Counting for available reference counting policies and Memory Allocation for available allocation policies.

class var;
class seekable_i;

template <typename rc>
class object_i : public rc{
public:
  object_i() { }
  virtual ~object_i() { };

  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_ALLOCATOR::free(ptr); }
};

typedef object_i<FERRET_RC_POLICY> object;

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

class var{
public:
  explicit var(object* 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* 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*>(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* 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_ALLOCATOR::allocate<FT>();
  return var(new(storage) FT(args...));
}

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

Objects

Boolean

The boolean type has two values, false and true, which represent the traditional boolean values.

(defobject boolean "ferret/obj/boolean_o.h")
class boolean final : public object {
  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>()->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 {
  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 _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

The number type represents real (double-precision floating-point) numbers. Ferret has no integer type. On systems without hardware support for floating point Ferret programs can be configured to use fixed point numbers. (See Math runtime.)

(defobject number "ferret/obj/number_o.h")
class number final : public object {
  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();
  }
};
Sequence

Sequences are collections. They implement the seekable interface directly. count is O(n). conj puts the item at the front of the list.

(defobject empty_sequence "ferret/obj/empty_sequence_o.h")
(defobject sequence "ferret/obj/sequence_o.h")
class empty_sequence final : public object {
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, 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

Ferret supports lazily evaluated sequences. This means that sequence elements are not available ahead of time and produced as the result of a computation. The computation is performed as needed when lazy sequence is iterated.

(defobject lazy_sequence "ferret/obj/lazy_sequence_o.h")
class lazy_sequence final : public object, 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 {
    if (!head.is_nil())
      return obj<sequence>(x, obj<lazy_sequence>(head,thunk));

    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

Keywords are symbolic identifiers that evaluate to themselves. They provide very fast equality tests. A keyword holds a simple hash of the keyword as number_t.

(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("keyword<");
    runtime::print(_word);
    runtime::print(">");
  }
#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*)this), runtime::rest(args));

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

    return nil();
  }
};
String

Ferret strings are represented as a Sequence of numbers each representing a character in the string. This scheme uses more memory but provides low memory fragmentation and ability to use sequence operations on strings.

(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, 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_ALLOCATOR::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

Atoms provide a way to manage shared, synchronous, independent state. The intended use of atom is to hold one of Ferret’s immutable data structures. You create an atom with atom, and can access its state with deref/@. To change the value of an atom, you can use swap! or reset! . Changes to atoms are always free of race conditions.

(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 *obj;
  public:
    explicit rc_guard(const rc_guard &) = delete;
    explicit rc_guard(object *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

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 {
 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 {
 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.) - All memory is managed by a third party GC disables reference counting.

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(size_t).

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")

Allocators

Pool

When FERRET_MEMORY_POOL_SIZE is defined Ferret programs will use a memory pool called memory::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.

#if defined(FERRET_MEMORY_POOL_SIZE) && !defined(FERRET_ALLOCATOR)

 #define FERRET_ALLOCATOR memory::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 memory{
  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

Pool allocator uses circular first-fit strategy, 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 memory{
  namespace allocator{
    template<typename page_size, size_t pool_size>
    class memory_pool{
    public:
      bitset<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){
        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){
        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_ALLOCATOR memory::allocator::gc
#define FERRET_DISABLE_RC true

#include <gc.h>

namespace memory{
  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

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

#if !defined(FERRET_ALLOCATOR)

#define FERRET_ALLOCATOR memory::allocator::system

namespace memory{
  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
Synchronized

Synchronizes access to other allocators.

namespace memory{
  namespace allocator{
    class synchronized{
      static mutex lock;
    public:

      static void init(){ FERRET_ALLOCATOR::init(); }

      template<typename FT>
      static inline void* allocate(){
        lock_guard guard(lock);
        return FERRET_ALLOCATOR::allocate<FT>();
      }

      static inline void  free(void * ptr){
        lock_guard guard(lock);
        FERRET_ALLOCATOR::free(ptr);
      }
    };
  }
}

Enable synchronized access,

#if  !defined(FERRET_DISABLE_MULTI_THREADING)

  #if defined(FERRET_MEMORY_POOL_SIZE) || defined(FERRET_HARDWARE_ARDUINO)
    mutex memory::allocator::synchronized::lock;
    #undef  FERRET_ALLOCATOR
    #define FERRET_ALLOCATOR memory::allocator::synchronized
  #endif

#endif
Allocator API

User defined allocators are supported. A Ferret allocator is a class with three static functions,

  • init() - Initializes the allocator.
  • allocate<T>() - Allocates Ferret object T.
  • free(void*) - Frees the memory.

Allocators are defined seperately in header files. They can then be used by including the header files.

#include <stdlib.h>

struct allocator_user{
  static bool loaded;

  static void init(){ loaded = true; }

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

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

bool allocator_user::loaded = false;

#define FERRET_ALLOCATOR allocator_user
(native-header "allocator_user.h")

(assert (cxx "__result = obj<boolean>(allocator_user::loaded)"))

Helper functions for user defined allocators.

namespace memory{
  inline size_t align_of(uintptr_t size, size_t align){
    return (size + align - 1) & ~(align - 1);
  }

  template<class T>
  size_t align_of(const void * ptr) {
    return align_of(reinterpret_cast<uintptr_t>(ptr), sizeof(T));
  }

  inline size_t align_req(uintptr_t size, size_t align){
    size_t adjust = align - (size & (align - 1));

    if(adjust == align)
      return 0;
    return adjust;
  }

  template<class T>
  size_t align_req(const void * ptr) {
    return align_req(reinterpret_cast<uintptr_t>(ptr), sizeof(T));
  }
}

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.

  • atomic_rc - Atomic reference counting. (using std::atomic<unsigned int>)
  • rc - Non Atomic reference counting. (using unsigned int)
  • no_rc - No reference counting.
#if !defined(FERRET_RC_POLICY)
namespace memory {
  namespace gc {

#if !defined(FERRET_RC_TYPE)
  #define FERRET_RC_TYPE unsigned int
#endif

#if defined(FERRET_DISABLE_RC)

#define FERRET_RC_POLICY memory::gc::no_rc

    class no_rc{
    public:

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

#else

    template<typename T>
    class rc{
    public:
      rc() : ref_count(0) {}

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

    private:
      T ref_count;
    };    

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

    #if defined(FERRET_STD_LIB) && !defined(FERRET_DISABLE_MULTI_THREADING)
      #define FERRET_RC_POLICY memory::gc::rc<::std::atomic<FERRET_RC_TYPE>>
    #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_DISABLE_MULTI_THREADING)
  class mutex {
  public:
    void lock()   {} 
    void unlock() {} 
  };
#else
  #if defined(FERRET_STD_LIB)
    class mutex {
      ::std::mutex m;
    public:
      void lock()   { m.lock();   } 
      void unlock() { m.unlock(); }
    };
  #endif

  #if defined(FERRET_HARDWARE_ARDUINO)
    class mutex {
    public:
      void lock()   { noInterrupts(); } 
      void unlock() { interrupts();   }
    };
  #endif
#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(); }
  };
}

Math

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 supports.

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
}

Math related string literals,

namespace ferret{
  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;
  }
}

Math 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));
  }
}

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 base from(T d) const { return (base)(d * factor); }

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

  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<T>(v)) {}

  template<typename T>
  fixed& operator=(T v)        { m = from<T>(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 * factor) / 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
};

Euclidean geometry, See Euclidean Vector unit test for usage.

namespace euclidean{
  template <size_t D, typename T>
  struct vector {
    T d[D];

    T& operator [](size_t idx)      { return d[idx]; }
    T operator [](size_t idx) const { return d[idx]; }

    friend vector operator+ (vector u, const vector& v) {
      vector result;
      for (size_t i = 0; i < D; i++)
        result.d[i] = u.d[i] + v.d[i];
      return result;
    }

    friend vector operator- (vector u, const vector& v) {
      vector result;
      for (size_t i = 0; i < D; i++)
        result.d[i] = u.d[i] - v.d[i];
      return result;
    }

    friend vector operator* (vector u, const T& v) {
      vector result;
      for (size_t i = 0; i < D; i++)
        result.d[i] = u.d[i] * v;
      return result;
    }

    friend bool operator== (const vector& x, const vector& y) {
      for (size_t i = 0; i < D; i++)
        if (x.d[i] != y.d[i])
          return false;
      return true;
    }

    T magnitude(){
      T acc = 0;
      for(size_t i = 0; i < D; i++){
        T t = d[i] * d[i];
        acc += t;
      }

      return sqrt(acc);
    }

    vector normalize(){
      T mag = magnitude();
      if (mag == 0)
        return vector{{0}};

      vector r;
      for(size_t i = 0; i < D; i++){
        r[i] = d[i] / mag;
      }

      return r;
    }

    T dist(vector v){ return ((*this) - v).magnitude(); }

#if defined(AUTOMATON_STD_LIB)
    friend std::ostream& operator<< (std::ostream& stream, const vector& x) {
      stream << '[';
      for (size_t i = 0; i < D - 1; i++)
        stream << x.d[i] << ',';
      stream << x.d[D - 1] << ']';
      return stream;
    }
#endif
  };

  typedef euclidean::vector<2, ferret::real_t> vector_2d;
  typedef euclidean::vector<3, ferret::real_t> vector_3d;
}

Containers

C++ containers used by the Ferret runtime. Most embedded systems does not provide standard containers such as std::array so Ferret provides its own containers that are portable across architectures.

Byte

byte is a collection of bits.

enum class byte : unsigned char { };

Array

array is a container that encapsulates fixed size arrays.

template<class Type>
struct array_seq {
  Type* p;
  explicit array_seq(Type* p) : p(p) {}
  bool operator!=(array_seq rhs) {return p != rhs.p;}
  Type& operator*() {return *p;}
  void operator++() {++p;}
};

template<class T, size_t S>
struct array {
  T data[S];

  T& operator [](int idx)      { return data[idx]; }
  T operator [](int idx) const { return data[idx]; }

  array_seq<T> begin() { return array_seq<T>(data);      }
  array_seq<T> end()   { return array_seq<T>(data + S);  }
  size_t       size()  { return S;                       }
};

Bitset

bitset represents a fixed-size sequence of N bits.

template<size_t S>
class bitset {
private:
  byte bits[S / 8 + 1];

  inline size_t index (size_t i) { return i / 8; }
  inline size_t offset(size_t i) { return i % 8; }

public:

  bitset() : bits{ (byte)0x00 } { }

  inline void set   (size_t b){
    bits[index(b)] = (byte)((int)bits[index(b)] |  (1 << (offset(b))));
  }

  inline void reset (size_t b){
    bits[index(b)] = (byte)((int)bits[index(b)] & ~(1 << (offset(b))));
  }

  inline bool test  (size_t b){
    return ((int)bits[index(b)] & (1 << (offset(b))));
  }
};

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::main()               |
| FERRET_DISABLE_RC                  | Not Defined  | Disable reference counting. (When using third party GCs) |
| FERRET_RC_TYPE                     | unsigned int | Type to use to hold the object reference count.          |
| FERRET_PROGRAM_MAIN                | Not Defined  | A function to execute after program::main()              |
| 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_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

Default stream size, represents the number of characters transferred in an I/O operation or the size of an I/O buffer.

#if !defined(FERRET_IO_STREAM_SIZE)
  # define FERRET_IO_STREAM_SIZE 80
#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;
    }

    void read_line(char *buff, std::streamsize len){
      std::cin.getline(buff, len);
    }
  }
#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);
    }

    void read_line(char *buff, size_t len){
      uint8_t idx = 0;
      char c;
      do{
        while (FERRET_HARDWARE_ARDUINO_UART_PORT.available() == 0);
        c = FERRET_HARDWARE_ARDUINO_UART_PORT.read();
        buff[idx++] = c;
      }while (c != '\n');
      buff[--idx] = 0x00;
    }
   }
#endif

Program Run

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

#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_ALLOCATOR::init();
    runtime::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

    $file$::main();

   #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;
    FERRET_ALLOCATOR::init();
    runtime::init();

    #if defined(FERRET_PROGRAM_MAIN)
      $file$::main();
    #endif
  }

  void loop(){
    using namespace ferret;
    #if !defined(FERRET_PROGRAM_MAIN)
      $file$::main();
    #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;

Core

The standard library of Ferret, provides a ton of general-purpose functionality for writing robust, maintainable embedded applications.

(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())")

Ferret provides the ability to embed C++ language source code within a Ferret program. A Ferret function can contain a short program written in C++ language, which is executed whenever this funtion is executed. Which is how most of the primitive functions are implemented such as the first function above, once primitives are in place rest can be defined in pure Ferret lisp,

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

As for macros, normal Clojure rules apply since they are expended using Clojure.

(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

read-line

Reads the next line from default I/O stream.

(defn read-line []
  "char buf[FERRET_IO_STREAM_SIZE] = {0};
   runtime::read_line(buf, FERRET_IO_STREAM_SIZE);
   return obj<string>(buf);")

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();")

byte-stream-encoder/decoder

(defn byte-stream-encoder [write]
  (fn [bytes]
    (let [size (count bytes)
          CS   (reduce bit-xor size bytes)]
      (write 0X06)
      (write 0X85)
      (write size)
      (doseq [b bytes] 
        (write b))
      (write CS))))
(defn byte-stream-header-ready [read in-waiting]
  (and (>= (in-waiting) 3) (= (read) 0X06) (= (read) 0X85)))

(defn byte-stream-payload-ready [size in-waiting]
  (>= (in-waiting) (inc @size)))

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

(defn byte-stream-handle-payload [read s handler]
  "number_t size = number::to<number_t>(s);
   number_t cs_calculated = size;
   var payload_rev;

   for(number_t i = 0 ; i < size; i++){
     var v = run(read);
     cs_calculated ^= number::to<number_t>(v);
     payload_rev = runtime::cons(v,payload_rev);
   }

   number_t cs_read = number::to<number_t>(run(read));

   if (cs_calculated == cs_read){
     var payload;

     for(auto const& i : runtime::range(payload_rev))
       payload = runtime::cons(i,payload);

     run(handler,payload);
   }")

(defn byte-stream-decoder [read in-waiting handler]
  (let [size (atom nil)]
    (state-machine 
     (states
      (sync-header)
      (read-size        (reset! size (read)))
      (wait-payload)
      (handle-payload   (byte-stream-handle-payload read @size handler)))
     (transitions
      (sync-header     #(byte-stream-header-ready read in-waiting)      read-size)
      (read-size       byte-stream-decoder-goto                         wait-payload)
      (wait-payload    #(byte-stream-payload-ready size in-waiting)     handle-payload)
      (handle-payload  byte-stream-decoder-goto                         sync-header)))))

multicast-socket

The multicast datagram socket class is useful for sending and receiving IP multicast packets. A MulticastSocket is a (UDP) datagram socket, with additional capabilities for joining "groups" of other multicast hosts on the internet.

A multicast group is specified by a class D IP address and by a standard UDP port number. Class D IP addresses are in the range 224.0.0.0 to 239.255.255.255, inclusive. The address 224.0.0.0 is reserved and should not be used.

One would join a multicast group by first creating a multicast-socket with the desired IP and port. When one sends a message to a multicast group, all subscribing recipients to that host and port receive the message. When a socket subscribes to a multicast group/port, it receives datagrams sent by other hosts to the group/port, as do all other members of the group and port.

(require '[ferret.net.multicast :as multicast])

(def sender   (multicast/socket "224.5.23.2" 10005))
(def receiver (multicast/socket "224.5.23.2" 10005))

(def data-out (list 1 2 3 4 5))

(assert (multicast/send sender data-out))
(assert (multicast/pending? receiver))

(def data-in (multicast/recv receiver))

(assert (= data-in data-out))
(native-header "fcntl.h"
               "unistd.h"
               "arpa/inet.h"
               "netdb.h"
               "netinet/in.h"
               "sys/poll.h"
               "sys/socket.h"
               "sys/types.h"
               "string.h")

(defobject multicast-socket "ferret/net/multicast_o.h")

(defn socket [ip port]
  "__result = obj<multicast_socket>(ip,port);")

(defn pending? [con]
  "__result = obj<boolean>(con.cast<multicast_socket>()->have_pending_data());")

(defn send [con data]
  "datagram_t buffer;
   number_t idx = 0; 

   for(auto const& b : runtime::range(data))
    buffer[idx++] = (byte)number::to<number_t>(b);

   __result = obj<boolean>(con.cast<multicast_socket>()->send(buffer,idx));")

(defn byte [conn idx]
  "__result = obj<number>(conn.cast<multicast_socket>()->data()[number::to<number_t>(idx)]);")

(defn data-seq
  ([conn size]
   (data-seq conn 0 size))
  ([conn curr size]
   (if (< curr size)
     (cons (byte conn curr)
           (lazy-seq (data-seq conn (inc curr) size))))))

(defn read [conn]
  "__result = obj<number>(conn.cast<multicast_socket>()->recv());")

(defn recv [conn]
  (data-seq conn (read conn)))
namespace multicast_aux {
  class address{
    sockaddr addr;
    socklen_t addr_len;

  public:
    address(){
      memset(&addr, 0, sizeof(addr));
      addr_len = 0;
    }

    address(const char *hostname, unsigned short port){
      set_host(hostname, port);
    }

    address(const address &src){ copy(src); }

    ~address() { reset(); }

    bool set_host(const char *hostname, unsigned short port);
    void set_any(unsigned short port = 0);

    bool operator==(const address &a) const{
      return addr_len == a.addr_len && memcmp(&addr, &a.addr, addr_len) == 0;
    }

    void copy(const address &src){
      memcpy(&addr, &src.addr, src.addr_len);
      addr_len = src.addr_len;
    }

    void reset(){
      memset(&addr, 0, sizeof(addr));
      addr_len = 0;
    }

    void clear(){
      reset();
    }

    in_addr_t get_in_addr() const;

    friend class udp;
  };

  const size_t max_data_gram_size = 65507;

  class udp{
    ferret::array<ferret::byte, max_data_gram_size> buf;
    int fd;

  public:
    unsigned sent_packets;
    size_t sent_bytes;
    unsigned recv_packets;
    size_t recv_bytes;

  public:
    udp() : fd(-1) { close(); }
    ~udp(){ close(); }

    bool open(const char *server_host, unsigned short port, bool blocking);
    bool add_multicast(const address &multiaddr, const address &interface);
    void close();
    bool is_open() const{ return fd >= 0; }

    bool send(const void *data, size_t length, const address &dest);
    ssize_t recv(address &src);

    bool wait(int timeout_ms = -1) const;
    bool have_pending_data() const;

    const ferret::byte* data() const{ return buf.data; }
  };

  bool address::set_host(const char *hostname, unsigned short port){
    addrinfo *res = nullptr;
    getaddrinfo(hostname, nullptr, nullptr, &res);
    if (res == nullptr) {
      return false;
    }

    memset(&addr, 0, sizeof(addr));
    addr_len = res->ai_addrlen;
    memcpy(&addr, res->ai_addr, addr_len);
    freeaddrinfo(res);

    // set port for internet sockets
    sockaddr_in *sockname = reinterpret_cast<sockaddr_in *>(&addr);
    if (sockname->sin_family == AF_INET) {
      sockname->sin_port = htons(port);
    }
    else {
      // TODO: any way to set port in general?
    }

    return true;
  }

  void address::set_any(unsigned short port){
    memset(&addr, 0, sizeof(addr));
    sockaddr_in *s = reinterpret_cast<sockaddr_in *>(&addr);
    s->sin_addr.s_addr = htonl(INADDR_ANY);
    s->sin_port = htons(port);
    addr_len = sizeof(sockaddr_in);
  }

  in_addr_t address::get_in_addr() const{
    const sockaddr_in *s = reinterpret_cast<const sockaddr_in *>(&addr);
    return s->sin_addr.s_addr;
  }

  bool udp::open(const char *server_host, unsigned short port, bool blocking){
    // open the socket
    if (fd >= 0) {
      ::close(fd);
    }
    fd = socket(PF_INET, SOCK_DGRAM, 0);

    // set socket as non-blocking
    int flags = fcntl(fd, F_GETFL, 0);
    if (flags < 0) {
      flags = 0;
    }
    fcntl(fd, F_SETFL, flags | (blocking ? 0 : O_NONBLOCK));

    int reuse = 1;
    if (setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, reinterpret_cast<const char *>(&reuse), sizeof(reuse)) != 0) {
      fprintf(stderr, "ERROR WHEN SETTING SO_REUSEADDR ON udp SOCKET\n");
      fflush(stderr);
    }

    int yes = 1;
    // allow packets to be received on this host
    if (setsockopt(fd, IPPROTO_IP, IP_MULTICAST_LOOP, reinterpret_cast<const char *>(&yes), sizeof(yes)) != 0) {
      fprintf(stderr, "ERROR WHEN SETTING IP_MULTICAST_LOOP ON udp SOCKET\n");
      fflush(stderr);
    }

    // bind socket to port if nonzero
    if (port != 0) {
      sockaddr_in sockname;
      sockname.sin_family = AF_INET;
      sockname.sin_addr.s_addr = htonl(INADDR_ANY);
      sockname.sin_port = htons(port);
      bind(fd, reinterpret_cast<struct sockaddr *>(&sockname), sizeof(sockname));
    }

    // add udp multicast groups
    address multiaddr, interface;
    multiaddr.set_host(server_host, port);
    interface.set_any();

    return add_multicast(multiaddr, interface);
  }

  bool udp::add_multicast(const address &multiaddr, const address &interface){
    struct ip_mreq imreq;
    imreq.imr_multiaddr.s_addr = multiaddr.get_in_addr();
    imreq.imr_interface.s_addr = interface.get_in_addr();

    int ret = setsockopt(fd, IPPROTO_IP, IP_ADD_MEMBERSHIP, &imreq, sizeof(imreq));

    return ret == 0;
  }

  void udp::close(){
    if (fd >= 0) {
      ::close(fd);
    }
    fd = -1;

    sent_packets = 0;
    sent_bytes = 0;
    recv_packets = 0;
    recv_bytes = 0;
  }

  bool udp::send(const void *data, size_t length, const address &dest){
    ssize_t len = sendto(fd, data, length, 0, &dest.addr, dest.addr_len);

    if (len > 0) {
      sent_packets++;
      sent_bytes += (size_t)len;
    }

    return (len >= 0 && (size_t)len == length);
  }

  ssize_t udp::recv(address &src){
    src.addr_len = sizeof(src.addr);
    ssize_t len = recvfrom(fd, buf.data, max_data_gram_size, 0, &src.addr, &src.addr_len);

    if (len > 0) {
      recv_packets++;
      recv_bytes += (size_t)len;
    }

    return len;
  }

  bool udp::have_pending_data() const{
    return wait(0);
  }

  bool udp::wait(int timeout_ms) const{
    static const bool debug = false;
    static bool pendingData = false;
    pollfd pfd;
    pfd.fd = fd;
    pfd.events = POLLIN;
    pfd.revents = 0;

    bool success = (poll(&pfd, 1, timeout_ms) > 0);

    if (!success) {
      // Poll now claims that there is no pending data.
      // What did have_pending_data get from Poll most recently?
      if (debug) {
        printf("wait failed, have_pending_data=%s\n", (pendingData ? "true" : "false"));
      }
    }
    pendingData = success;
    return success;
  }
}

typedef ferret::array<ferret::byte, multicast_aux::max_data_gram_size> datagram_t;

class multicast_socket final : public object {
  std::string ip;
  unsigned short port;
  multicast_aux::udp net;

public:

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

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

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

  explicit multicast_socket(var i, var p) :
    ip(string::to<std::string>(i)),
    port((unsigned short)number::to<number_t>(p)) {
    net.open(ip.c_str(), port,true);
  }

  bool have_pending_data() const {
    return net.have_pending_data();
  }

  bool send(datagram_t & data, number_t size) {
    multicast_aux::address dest_addr(ip.c_str(), port);
    return net.send(data.data, (size_t)size, dest_addr);
  }

  number_t recv(){
    multicast_aux::address src_addr(ip.c_str(), port);
    return (number_t)net.recv(src_addr);
  }

  const byte* data() const{ return net.data(); }
};

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))))))
  ([f s1 s2]
   (lazy-seq
    (when (and (not (empty? s1))
               (not (empty? s2)))
      (cons (f (first s1) (first s2))
            (map f (rest s1) (rest s2)))))))

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)))))))))

every?

Returns true if (pred x) is logical true for every x in coll, else false.

(defn every? [pred coll]
  "for(auto const& i : runtime::range(coll)){
     if (!run(pred, i))
      return cached::false_t;
   }
   __result = cached::true_t;")

interleave

Returns a lazy seq of the first item in each coll, then the second etc.

(defn interleave
  ([s1 s2]
   (lazy-seq
    (when (and (not (empty? s1))
               (not (empty? s2)))
      (cons (first s1) (cons (first s2) 
                             (interleave (rest s1) (rest s2))))))))

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);
   byte *p = (byte*)&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 {

  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 (keyword name) `(fn [] ~@body))))
                       [] states)
        transitions (->> transitions
                         (map (fn [v]
                                (let [[state & conds] v
                                      state (keyword state)
                                      conds (->> (partition 2 conds)
                                                 (reduce (fn [h v]
                                                           (let [[check state] v
                                                                 state (keyword state)]
                                                             (conj h `(~check) state))) []))]
                                  `(~state (fn [] (cond ~@conds true ~state))))))
                         (reduce (fn [h v]
                                   (let [[check transition] v]
                                     (conj h check transition)))
                                 []))]

    `((fn [state states transitions]
        (fn []
          (let [ret# ((states @state))]
            (if-let [next# (transitions @state)]
              (reset! state (next#)))
            ret#)))
      (atom ~(first states))
      (new-d-list ~@states)
      (new-d-list ~@transitions))))

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 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 lambda_i {
  T p;
  T i;
  T d;
  T maximum_output;
  T minimum_output;
  T maximum_input;
  T minimum_input;
  bool continuous;
  var setpoint_fn;
  mutable T setpoint;
  mutable T prev_error;
  mutable T total_error;
  mutable T error;
  mutable T result;
  mutable 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,
                 var const & sp){
    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();

    if (sp.is_type(runtime::type::lambda_i)){
      setpoint_fn = sp;
      set_setpoint(run(setpoint_fn));
    }else{
      set_setpoint(sp);
    }

    prev_error = 0;
    total_error = 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) const {
    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) const {
    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;
    }
  }

  var invoke(var const & args) const {
    if (!setpoint_fn.is_nil())
      set_setpoint(run(setpoint_fn));
    return update(runtime::first(args));
  }

  void reset(){
    prev_error = 0;
    total_error = 0;
    result = 0;
  }
};
(defn new-pid-controller [kp ki kd i-min i-max o-min o-max cont sp]
  "__result = obj<pid_controller<real_t>>(kp, ki, kd, i_min, i_max, o_min, o_max, cont, sp);")

(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]
    `(new-pid-controller ~kp ~ki ~kd ~in-min ~in-max ~out-min ~out-max ~continuous ~set-point)))

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.

(defobject moving_average_filter "ferret/obj/moving_average_filter_o.h")

(defn new-moving-average-filter [a]
  "__result = obj<moving_average_filter<real_t>>(a);")
template <typename T>
class moving_average_filter : public lambda_i {
  T alpha;
  mutable T avrg;
public:

  explicit moving_average_filter(var const & a) : avrg(0) {
    alpha = number::to<T>(a);
  }

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

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

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const {
    runtime::print("moving_average_filter<");
    runtime::print(alpha);
    runtime::print(",");
    runtime::print(avrg);
    runtime::print(">");
  }
#endif

  var invoke(var const & args) const {
    T data = number::to<T>(runtime::first(args));
    avrg = ((alpha * data) + ((1. - alpha) * avrg));
    return obj<number>(avrg);
  }
};

Arduino

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.

(require '[ferret.arduino :as gpio])

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

(gpio/pin-mode debug-pin :output)

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

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

(forever
 (sleep 100))
(defmacro attach-interrupt [pin mode callback]
  (let [mode    (-> mode name .toUpperCase)
        isr-fn  (gensym)
        isr-pin (gensym)]
    `(do
       (def ~isr-fn  ~callback)
       (def ~isr-pin ~pin)
       (cxx
        ~(str "::pinMode(" isr-pin " , INPUT_PULLUP);\n"
              "auto isr_pin = digitalPinToInterrupt(" isr-pin ");\n"
              "::attachInterrupt(isr_pin, [](){ run(" isr-fn ");}, " 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)
(defn detach-interrupt [p]
  "detachInterrupt(digitalPinToInterrupt(number::to<number_t>(p)));")

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-exit 1)))

(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)
      (system-exit 1))))

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

(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) (system-exit 0))
    `(do (system-exit 0))))

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));"))
  (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(memory::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/frameworks,

  • GCC 5
  • Clang 4.0
  • Arduino 1.8.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 and undefined behavior.

Tests are grouped into 4 categories. Compiler tests test the inner workings of the compiler, native tests tests the inner workings of the Ferret lisp runtime, core tests tests the behavior of complete Ferret programs and finally embedded tests are used to verify code compiles on various embedded systems.

Build options,

  • -std=c++11
  • -pedantic
  • -Werror
  • -Wall
  • -Wextra
  • -Wconversion
  • -Wpointer-arith
  • -Wmissing-braces
  • -Woverloaded-virtual
  • -Wuninitialized
  • -Winit-self
  • -Wsign-conversion
  • -fno-rtti
  • -fsanitize=undefined,address,leak
  • -fno-omit-frame-pointer

Static code analysis (cppcheck) options,

  • –std=c++11
  • –template=gcc
  • –enable=all
  • –error-exitcode=1

Compiler

Three Shaking

(deftest three-shaking
  (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)))))))

Compiler

(deftest compiler
  (let [program (compile '((defn one-plus-one []
                             (+ 1 1))

                           (while true
                             (+ 1 1))) {})]
    ;;while shoud use one-plus-one in its body
    ;;check lambda-defined?
    (is (= 2 (count (select-form program (fn [f] (= 'one_plus_one f))))))))

Unit Testing

(deftest testing-unit-test
  (is (= 1 (check-form '((assert (= 2 1))))))
  (is (= 0 (check-form '((assert (= 2 1))) {:release true})))
  (is (= 0 (check-form '((run-all-tests)))))

  (is (= 1 (check-form '((deftest some-test
                           (is (= 2 3)))
                         (run-all-tests)))))


  (is (= 0 (check-form '((deftest some-test
                           (is (= 2 2)))
                         (run-all-tests)))))

  (is (= 1 (check-form '((deftest some-test
                           (is (= 5 (apply + (list 1 2 3)))))
                         (run-all-tests)))))

  (is (= 0 (check-form '((deftest some-test
                           (is (= 6 (apply + (list 1 2 3)))))
                         (run-all-tests))))))

Misc

(deftest testing-compilation
  (is (= 0 (check-form '((defn handler []     )
                         (defn call [handler] "return obj<number>(42);")

                         (deftest some-test
                           (is (= 42 (call handler))))

                         (run-all-tests))))))

Native

Fixed Point

#include <cassert>
#include <runtime.h>

int main() {
  typedef ferret::fixed_real<32,8> fix_32;
  typedef ferret::fixed_real<64,8> fix_64;

  // Test Casting
  assert((char)          fix_32(char(25))  == char(25));
  assert((int)           fix_32(int(1024)) == int(1024));
  assert((long)          fix_64(long(25))  == long(25));
  assert((unsigned long) fix_64(2500UL)    == 2500UL);

  long max_int = std::numeric_limits<int>::max() + 1024L;
  assert((long)fix_64(max_int) == ((long)std::numeric_limits<int>::max() + 1024L));

  // Test Arithmetic
  fix_32 x;
  fix_32 y;
  x = 10;
  y = 0.250;
  assert(10.25 == (double)(x + y));

  x = fix_32(0);
  for(int i = 0; i < 100; i++)
    x += fix_32(0.0625);
  assert((double)x == 6.25);

  x = fix_32(22.75);
  y = fix_32(12.5);
  assert((double)(x + y) == 35.25);

  x = fix_32(22.75);
  y = fix_32(22.5);
  assert((double)(x - y) ==  0.25);
  assert((double)(y - x) == -0.25);

  x = fix_32(-0.25);
  y = fix_32(4);
  assert((double)(x / y) ==  -0.0625);

  x = fix_32(-0.0625);
  y = fix_32(-10);
  assert((double)(x - y) ==  9.9375);

  x = fix_32(9.9375);
  y = fix_32(-3);
  assert((double)(x * y) ==  -29.8125);

  x = fix_32(-29.8125);
  y = fix_32(0.1875);
  assert((double)(x - y) ==  -30);

  return 0;
}

Euclidean Vector

#include <cassert>
#include <runtime.h>

int main() {
  using namespace std;
  using namespace ferret::euclidean;

  vector_3d z = {{0, 0, 0}};
  vector_3d u = {{1, 2, 3}};
  vector_3d v = {{3, 2, 1}};

  vector_3d a = u + v;
  vector_3d s = u - v;
  vector_3d m = u * 2;


  assert((z == vector_3d{{ 0, 0, 0}}));
  assert((a == vector_3d{{ 4, 4, 4}}));
  assert((s == vector_3d{{-2, 0, 2}}));
  assert((m == vector_3d{{ 2, 4, 6}}));

  assert((10                    == vector_3d{{ 0, 10, 0}}.magnitude()));
  assert((vector_3d{{ 0, 1, 0}} == vector_3d{{ 0, 10, 0}}.normalize()));
  assert((10                    == vector_3d{{ 0, 0, 0}}.dist(vector_3d{{0, 10, 0}})));

  return 0;
}

Array

#include <cassert>
#include <runtime.h>

int main() {
  using namespace ferret;

  array<int, 5> numbers{{1, 2, 3, 4, 5}};

  assert((numbers[0] == 1));
  assert((numbers[1] == 2));
  assert((numbers[2] == 3));
  assert((numbers[3] == 4));
  assert((numbers[4] == 5));

  for (int& x : numbers) { x++; }

  assert((numbers[0] == 2));
  assert((numbers[1] == 3));
  assert((numbers[2] == 4));
  assert((numbers[3] == 5));
  assert((numbers[4] == 6));

  return 0;
}

Memory Pool

#define FERRET_MEMORY_POOL_SIZE 4_MB

#include <cassert>
#include <runtime.h>

int main() {
  using namespace ferret::memory;

  assert(0  == align_req(0,8));
  assert(7  == align_req(1,8));
  assert(0  == align_req(8,8));

  assert(0  == align_of(0,8));
  assert(8  == align_of(1,8));
  assert(8  == align_of(8,8));

  alignas(16) int buff [4];
  assert(0  == align_req<int16_t>(buff));
  assert(reinterpret_cast<std::uintptr_t>(buff) == align_of<int16_t>(buff));

  using namespace allocator;

  size_t item_size = sizeof(size_t);

  memory_pool<size_t,14> tiny_pool;

  assert(0  == tiny_pool.next_page(0));
  assert(nullptr  != tiny_pool.allocate(item_size * 2));
  assert(3  == tiny_pool.next_page(0));
  void* p = tiny_pool.allocate(item_size * 4);
  assert(nullptr  != p);
  assert(8  == tiny_pool.next_page(0));
  tiny_pool.free(p);
  assert(3  == tiny_pool.next_page(0));
  assert(nullptr  == tiny_pool.allocate(item_size * 40));
  assert(nullptr  != tiny_pool.allocate(item_size * 6));
  assert(nullptr  != tiny_pool.allocate(item_size * 1));
  assert(nullptr  != tiny_pool.allocate(item_size * 1));
  assert(nullptr  == tiny_pool.allocate(item_size * 10));

  memory_pool<size_t,256> even_pool;

  assert(0  == even_pool.next_page(0));
  p = even_pool.allocate(item_size * 255);
  assert(nullptr  != p);
  assert(256  == even_pool.next_page(0));
  even_pool.free(p);
  assert(0  == even_pool.next_page(0));
  assert(nullptr  == even_pool.allocate(item_size * 256));
  assert(0  == even_pool.next_page(0));

  memory_pool<size_t,255> odd_pool;

  assert(0  == odd_pool.next_page(0));
  p = odd_pool.allocate(item_size * 254);
  assert(nullptr  != p);
  assert(255  == odd_pool.next_page(0));
  odd_pool.free(p);
  assert(0  == odd_pool.next_page(0));
  assert(nullptr  == odd_pool.allocate(item_size * 255));
  assert(0  == odd_pool.next_page(0));  

  return 0;
}

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))))))

(def nested-multi-arity-call (do (fn
                                   ([]    0)
                                   ([x]   1)
                                   ([x y] 2))))

(deftest special-forms-test
  (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-arity-call)))
  (is (= 1 (nested-multi-arity-call 1)))
  (is (= 2 (nested-multi-arity-call 1 2)))

  (is (= 10 (adder 9)))
  (is (= 89 (fibo 10))))

(let [x 42]
  (defn let-over-lambda [] x))

(is (= 42 (let-over-lambda)))

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))))

FFI

(native-declare "ferret::number_t i = 0;")

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

(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 (= 0 (inc-int)))
  (is (= 1 (inc-int)))

  (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)))))

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 number-test
  (is (= 0.5       1/2))
  (is (= 0.33333   1/3))
  (is (= 3501      0xDAD))
  (is (= 2748      0xABC)))

(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))))

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-e)

(deftest simple-module-test
  (is (= 1  (modules.module-e/foo))))

(run-all-tests)
(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)

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 (= (list (list 1 4) (list 2 5))   (map (fn [a b] (list a b)) (list 1 2) (list 4 5))))
  (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 1 2)            (cons 1 (cons 2 (lazy-seq )))))
  (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 (= false (every? false? (list true false))))
  (is (= true  (every? false? (list false false))))

  (is (= (list 1 3 2 4) (interleave (list 1 2) (list 3 4))))
  (is (= (list 1 3)     (interleave (list 1 2) (list 3))))

  (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))))))

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))))))

Concurrency

(deftest atom-test
  (let [a (atom nil)
        b (atom nil)]
    (is (= nil          (deref a)))
    (is (= 1            @(atom 1)))
    (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)))))

(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))))))

Control

(deftest moving-average-filter-test
  (let [f (new-moving-average-filter 0.1)]

    (is (= 1.00 (f 10)))
    (is (= 1.90 (f 10)))
    (is (= 2.71 (f 10)))))

(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))))

  (let [machine (state-machine
                 (states
                  (setup :setup)
                  (done  :done))

                 (transitions
                  (setup (fn [] true) done)))]

    (is (= :setup (machine)))
    (is (= :done  (machine)))
    (is (= :done  (machine)))

    (dotimes [_ 8]
      (machine))))

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))))

Byte Stream

(def byte-stream-state (atom nil))

(defn byte-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! byte-stream-state vals)))))

(defn byte-sample-write-stream []
  (let [buffer (atom (list))]
    (list
     (fn [v]
       (swap! buffer conj v))
     (fn []
       (reverse (deref buffer))))))

(deftest byte-stream-test
  (let [[writer get-buffer] (byte-sample-write-stream)
        encoder (byte-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] (byte-sample-read-stream (get-buffer))
          decoder (byte-stream-decoder read in-waiting handler)]
      (dotimes [i 4]
        (decoder))
      (is (= (list 1 2 3 4) @byte-stream-state))
      (dotimes [i 4]
        (decoder))
      (is (= (list 5 6 7 8) @byte-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))))

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: 2018-05-26 Sat 18:12

Emacs 24.5.1 (Org mode 8.2.10)

Validate