/ferret

Permalink
Switch branches/tags
Nothing to show
Find file Copy path
3cf78ac Sep 20, 2018
3 contributors

Users who have contributed to this file
@nakkaya @0atman @akkartik
Raw Blame History
9773 lines (7892 sloc) 287 KB

Ferret Programmer’s Manual

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
echo "deb [trusted=yes]\
 https://ferret-lang.org/debian-repo ferret-lisp main" >> /etc/apt/sources.list
apt-get update
apt-get install ferret-lisp
[ferret "<<ferret-version()>>"]

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 lazy-sum.

$ ./ferret -i lazy-sum.clj
$ g++ -std=c++11 -pthread lazy-sum.cpp -o lazy-sum
$ ./lazy-sum
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
$ ./lazy-sum
15

Following shows a blink example for Arduino. (See section <a href=”Arduino Boards”>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

Articles

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 designed to be used in real time embedded control systems. It is heavily inspired by Clojure both syntactically and semantically. 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 Core library. Any getting started guide for Clojure should get you upto speed on Ferret.

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

All source code for the project is kept in a single org-mode file named ferret.org. emacs is used to extract the sources and documentation.

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 ferret.org 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 ferret.org 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,

./ferret-styles/graphs/compiler_arch.png

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)
       (let->fn)
       (do->fn)
       (fn->lift)
       (fn->inline options)
       (escape-analysis)
       (symbol-conversion)))

Modules

Supported require forms for importing modules,

(require 'package.io)

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

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

Helper functions or variables in modules that should not be exposed outside the namespace can be defined using the following form,

(def ^{:private true}  helper-var :value)

(defn ^{:private true} helper-fn [] 42)

If a file named deps.clj is found on the same path as the input file. Modules listed in it can be downloaded using --deps CLI argument.

;;deps.clj
(git :url    "https://github.com/nakkaya/ferret-opencv.git")

(git :url    "https://github.com/nakkaya/ferret-mosquitto.git"
     :commit "8c8c0890194a0b98130a3d4d78b71c99b833b12a")
(defn checkout-deps [path]
  (when (io/file-exists (str path "/deps.clj"))
    (let [deps (-> (read-clojure-file "deps.clj")
                   (parser/peek (parser/form? 'git)))
          deps (map (fn [[_ & kvs]] (apply hash-map kvs)) deps)]
      (doseq [{url :url commit :commit} deps]
        (let [folder (str path (jgit-util/name-from-uri url))]
          (info "dep =>" url)
          (when (io/file-exists folder)
            (org.apache.commons.io.FileUtils/deleteDirectory
             (java.io.File. folder)))
          (let [repo (jgit/git-clone-full
                      url (org.apache.commons.io.FilenameUtils/normalize folder))]
            (jgit/git-checkout (:repo repo)
                               (if commit
                                 commit
                                 "master"))))))))

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 from some-fn to io/some-function.

(defn import-modules-select-require [form]
  (let [norm-require (fn [f]
                       (if (symbol? f)
                         [f :as f]
                         f))]
    (->> (parser/peek form (parser/form? '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)
                                          (parser/drop (parser/form? 'configure-runtime!))
                                          (parser/drop (parser/form? 'configure-ferret!)))
                       macro-symbols  (->> (parser/peek mod (parser/form? 'defmacro))
                                           (map second)
                                           (into #{}))
                       def-symbols    (->> (parser/peek (expand-macros mod) (parser/form? 'def))
                                           (map second)
                                           (into #{}))
                       replace?       (set/union macro-symbols def-symbols)
                       mod            (parser/transform
                                       mod
                                       #(and (symbol? %)
                                             (replace? %))
                                       #(parser/new-symbol 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)]
    (parser/transform form symbol?
                      (fn [f]
                        (if-let [[_ alias fn] (re-find #"(.*?)/(.*)" (str f))]
                          (if-let [mod-sym (alias-to-mod (symbol alias))]
                            (parser/new-symbol 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         (parser/drop form (parser/form? 'require))
        modules      (import-modules-load-modules package-list options)
        non-public?  (->> modules
                          (reduce (fn[private-symbols mod]
                                    (-> mod
                                        (parser/peek #(and (symbol? %)
                                                           (-> % meta :private)))
                                        (concat private-symbols))) [])
                          (into #{}))
        form         (import-modules-convert-alias-to-module package-list form)
        violations   (parser/peek form #(non-public? %) #(zip/node (zip/up %)))]
    (when (not (empty? violations))
      (doseq [v violations]
        (warn "non-public-access =>" v))
      (io/exit-failure))
    (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 (io/read-file-from-url "build.info")]
                                    (str "// ferret-lisp " version))
                                  (catch Exception e
                                    (str "// ferret-lisp")))))))

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
      (parser/transform
       (parser/form? 'clojure.core/deref)
       (fn [f] (cons 'deref (rest f))))
      (parser/transform
       map?
       (fn [x] (cons 'fir-new-map (-> x seq flatten))))))

Prepare form f for macro expansion,

(defn macro-normalize [f]
  (parser/transform f
                    (parser/form? '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 parser/transform 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.

(defn expand-macros-single [form]
  (let [core-macros (->> (read-clojure-file "ferret/runtime.clj")
                         (filter (parser/form? 'defmacro)))
        core-macro-symbols (into #{} (map second core-macros))
        form-macros (->> (filter (parser/form? 'defmacro) form)
                         (filter (fn [[_ name]]
                                   (not (core-macro-symbols name)))))
        form-macro-symbols (map second form-macros)
        form (parser/drop form (parser/form? '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.io :only [exit-failure]])
      (use '[ferret.core :only [symbol-conversion]])
      (use '[ferret.parser :only [new-fir-fn]])
      
      (doseq [m (concat core-macros form-macros)]
        (eval m)))

    (let [form (-> form
                   (macro-normalize)
                   (expand-reader-macros)
                   (parser/transform
                    (fn [f]
                      (some true? (map #(parser/form? % f) macro-symbols)))
                    (fn [f]
                      (binding [*ns* (the-ns temp-ns)]
                        (-> (walk/macroexpand-all f)
                            ;;strip ns from symbols
                            (parser/transform symbol? #(-> % name symbol)))))))]
      (remove-ns temp-ns)
      form)))

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

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

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__1548] ((fn* [b__1549] (+ a__1548 b__1549)) 2)) 1)
(defn let-closure [bindings body]
  (if (empty? bindings)
    `((~'fir-let-fn () ~@body))
    (apply
     (fn close [[arg val] & more]
       (if (empty? more)
         `((~'fir-let-fn [~arg] ~@body) ~val)
         `((~'fir-let-fn [~arg] ~(apply close more)) ~val)))
     (partition 2 bindings))))

(defn let-assert [bindings body]
  (when (odd? (count bindings))
    (warn
     (str "let requires an even number of forms in binding vector => " bindings))
    (io/exit-failure)))

(defn let->fn [form]
  (-> form

      (parser/transform (parser/form? 'let*)
                        (fn [[_ bindings & body]]
                          (let-assert bindings body)
                          (let-closure bindings body)))

      (parser/transform (parser/form? 'fir-let-fn)
                        (fn [[_ args & body]]
                          (parser/new-fir-fn :args args :body 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]
  (parser/transform form
                    (parser/form? 'do)
                    (fn [f] `(~(parser/new-fir-fn :body (rest f))))))

fn->lift

fn->lift 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 function 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.

(fn->lift '(fn* [x]
                (fn* [n] (+ x n))))

Above form will be converted to,

(fir-defn-heap G__1333  (x) (n)  (+ x n))
(fir-defn-heap G__1334  ()  (x)  (fir-fn-heap G__1333 x))
(fir-fn-heap 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 fn-defined? [fns env args body]
  (if-let [fn-name (@fns (concat [env args] body))]
    (apply list 'fir-fn-heap fn-name env)))

(defn define-fn [fns env name args body]
  (let [n (if name
            name
            (gensym "FN__"))]
    (swap! fns assoc (concat [env args] body) n)
    (apply list 'fir-fn-heap n env)))

(defn fn->lift
  ([form]
   (let [fns  (atom (ordered-map/ordered-map))
         form (fn->lift form fns)
         fns  (map (fn [[body name]] (concat ['fir-defn-heap name] body)) @fns)]
     (concat fns form)))
  ([form fns & [env]]
   (parser/transform
    form
    (parser/form? 'fn*)
    (fn [sig]
      (let [[name args body] (parser/split-fn sig)
            ;; transform named recursion in body
            body (if name
                   (parser/transform
                    body
                    (parser/form? name)
                    (fn [[_ & args]]
                      (cons
                       (apply list 'fir-fn-heap name env)
                       args)))
                   body)
            body (fn->lift body fns (concat args env))
            symbols (parser/symbol-set body)
            env  (->> (set/intersection
                       symbols
                       (into #{} (flatten env)))
                      (into ()))

            args (if (parser/ffi-fn?
                      (filter #(not (parser/form? 'native-declare %)) body))
                   args
                   (parser/transform args
                                     symbol?
                                     (fn [v]
                                       (if (or (not (parser/fn-arg-symbol? v))
                                               (symbols v))
                                         v '_))))]
        (if-let [n (fn-defined? fns env args body)]
          n
          (define-fn fns env name 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 %))]
    (parser/transform form symbol? c)))

Remove Assertions

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

Optimizations

Inline Functions

This optimization trades memory for performance. When a global variable pointing to a function is defined, memory for that function is allocated at the start of the program and never released until program exits even if the said function is called only once in the program. In order to keep the memory usage low Ferret will replace all functions calls with new function objects. So every time a function is called a new function object is created used and released. If performance is more important than memory usage this optimization can be disabled using compiler option --global-functions. This optimization can be turned of on a per def basis by setting the metadata of the object to :volatile true,

(defn ^{:volatile true} no-inline [] 42)
(defn inline-defn? [f]
  (and (parser/form? 'def f)
       (-> f second meta :volatile not)
       (parser/form? 'fir-fn-heap
                     (->> f (drop 2) first))))

(defn fn->inline [options form]
  (if (:global-functions options)
    form
    (let [defns      (->> (parser/peek form inline-defn?)
                          (filter #(= 2 (-> % last count))))
          fn-table   (map (fn [[_ name [_ gensym]]] [name gensym]) defns)
          impl-table (apply hash-map (flatten fn-table))
          defn?      (fn [f]
                       (and (inline-defn? f)
                            (impl-table (second f))))
          invoke     #(if-let [imp (impl-table %)]
                        (list 'fir-fn-heap imp)
                        %)
          no-defn    (reduce (fn[h v] (parser/drop h defn?)) form defns)
          inlined    (reduce (fn[h [name gensym]]
                               (parser/transform h
                                                 #(or (parser/form? name %)
                                                      (parser/form? 'def %))
                                                 (fn [f] (map invoke f))))
                             no-defn fn-table)]
      (reduce (fn[h [name gensym]]
                (parser/transform h #(and (symbol? %)
                                          (= % gensym))
                                  (fn [_] (identity name))))
              inlined 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 (parser/form? 'defn f)
                          (parser/form? 'defnative f)))
         header-symbols (->> (parser/peek header seq?)
                             (parser/symbol-set))
         header-fns (->> (parser/peek header shakeable?)
                         (map #(vector (second %) %))
                         (into {}))
         header-non-shakeable (parser/drop header shakeable?)
         form-expanded (expand-macros (concat header-non-shakeable form))
         fns (atom #{})
         _ (shake-concat form-expanded header-fns fns header-non-shakeable)
         header-shaked (parser/drop header (fn [f]
                                             (and (shakeable? f)
                                                  (not (@fns (second f))))))]
     (concat header-shaked form)))
  ([form built-in fns non-shakeable]
   (parser/transform form symbol?
                     #(do
                        (if-let [f (built-in %)]
                          (when (not (@fns %))
                            (swap! fns conj %)
                            (shake-concat (expand-macros (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-fns)))
Function Calls

By default Ferret assumes all functions can escape their scope and they are allocated on the heap. Functions proven to not escape their scope are replaced with stack allocated functions.

(defn escape-fn-calls [form]
  (parser/transform form
                    (fn [f]
                      (and (seq? f)
                           (parser/form? 'fir-fn-heap (first f))))
                    (fn [f]
                      (let [[[_ & fn] & args] f]
                        `((~'fir-fn-stack ~@fn) ~@args)))))
Dispatch Functions

User programs has no access to dispatch functions used by multi-arity functions. They can be safely escaped and replaced by the stack allocated versions.

(defn escape-fn-dispatch [form]
  (parser/transform
   form
   (parser/form? 'fir-defn-arity)
   (fn [f]
     (parser/transform f
                       (parser/form? 'fir-fn-heap)
                       (fn [[_ & f]]
                         `(~'fir-fn-stack ~@f))))))
Function Classes

Each Ferret fn generates a corresponding C++ class that extends a Ferret Object. If a function can be proven to be only allocated on the stack in all uses of the said function, it can be replaced with a C++ POD type. This saves program space since said function does not need to inherit from a Ferret Object.

(defn escape-fns [form]
  (let [heap-fns (->> (parser/peek form (parser/form? 'fir-fn-heap))
                      (map second)
                      (into #{}))
        stack-fns (->> (parser/peek form (parser/form? 'fir-fn-stack))
                       (map second)
                       (into #{}))
        escapeable-fns (set/difference stack-fns heap-fns)]
    (parser/transform form
                      (fn [f]
                        (and (seq? f)
                             (= (first f) 'fir-defn-heap)
                             (escapeable-fns (second f))))
                      (fn [[_ & f]]
                        `(~'fir-defn-stack ~@f)))))

Parser

Ferret programs are read using the Clojure reader via read-string,

(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 \( (io/read-file f) \)))
          (parser/transform
           symbol?
           #(if (= (namespace %) ns-str)
              (-> % name symbol)
              %))
          ;;replace clojure.core/fn with fn
          ;;replace clojure.core/while with while
          (parser/transform
           (fn [x]
             (and (parser/form? 'quote x)
                  (or (= 'clojure.core/fn    (second x))
                      (= 'clojure.core/defn  (second x))
                      (= 'clojure.core/while (second x)))))
           (fn [[_ s]] `'~(-> s name symbol)))))))

Each transformation happens by walking over the program form. Forms are selected using form? function.

(form? 'fn* '(fn* [n] (+ x n)))
;; true
(defn form?
  ([s]
   #(form? s %))
  ([s f]
   (and (seq? f)
        (= (first f) s))))

Returns the set of symbols used in the form.

(defn symbol-set [form]
  (->> form flatten (filter symbol?) (into #{})))

Splits a function form into compnents.

(defn split-fn [sig]
  (let [name (if (symbol? (second sig)) (second sig) nil)
        sig  (if name (clojure.core/drop 2 sig) (rest sig))
        [args & body] sig]
    [name args body]))

Predicate for checking if function body is a FFI call or not.

(defn ffi-fn? [body]
  (and (not (nil? body))
       (not (empty? body))
       (->> (map string? body)
            (every? true?))))

Predicate for checking if a symbol in fn arguments is a valid symbol or not.

(defn fn-arg-symbol? [s]
  (and (symbol? s)
       (not= s '&)
       (not= s '_)
       (not= s 'fir-destructure-associative)))

During each pass we iterate over the nodes in the form using one of three functions, transform , drop and peek. They all take a s-expression and a predicate. If the predicate returns true, transform will call f passing the current node as an argument and replace that node with f ‘s return value, drop on the other hand does what its name suggests and removes the node when predicate returns true. peek is used to peek at sections of the form, does not alter the form only returns the list of nodes matching the predicate.

(defn transform [tree pred f]
  (walk/prewalk (fn [form]
                  (if (pred form)
                    (let [new-form (f form)
                          meta (meta form)]
                      (if (and (instance? clojure.lang.IMeta form)
                               (instance? clojure.lang.IMeta new-form))
                        (with-meta new-form meta)
                        new-form))
                    form))
                tree))

(defn drop [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 peek [tree pred & [node-fn]]
  (let [node-fn (if node-fn
                  node-fn
                  #(zip/node %))]
    (loop [loc (zip/seq-zip tree)
           nodes []]
      (if (zip/end? loc)
        nodes
        (recur
         (zip/next loc)
         (if (pred (zip/node loc))
           (conj nodes (node-fn loc))
           nodes))))))

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 new-symbol [& parts]
  (let [parts (map #(.replace (str %) "." "_") parts)]
    (symbol (apply str parts))))

(defn fn-make-unique [args body]
  (if (string?  (->> body
                     (filter #(not (form? 'native-declare %)))
                     first))
    [args body]
    (let [unique-args (->> args
                           flatten
                           (filter fn-arg-symbol?)
                           (map #(new-symbol % (gensym "__"))))
          replace? (->> (interleave (->> args
                                         flatten
                                         (filter fn-arg-symbol?))
                                    unique-args)
                        (apply hash-map))
          body      (transform body #(replace? %) #(replace? %))
          replace?  (merge replace? {'fir-new-map 'fir-destructure-associative})
          args      (transform args #(replace? %) #(replace? %))]
      [args body])))

(defn new-fir-fn
  ([& {:keys [name args body escape] :or {escape  true
                                          args    []}}]
   (let [name-unique (if name
                       (new-symbol name (gensym "__")))
         [args body] (if escape
                       (fn-make-unique args body)
                       [args body])
         body        (if name-unique
                       (transform body #(= % name) (fn [_] name-unique))
                       body)]
     (if name-unique
       `(fn* ~name-unique ~args ~@body)
       `(fn* ~args ~@body)))))

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.

(emit options '(list 1 2 3) (ref {}))
;;"run(list,obj<number>(1),obj<number>(2),obj<number>(3))"

(emit options '(+ 1 2) (ref {}))
;;"run(+,obj<number>(1),obj<number>(2))"

(emit options '(if (< a b)
                 b a)
              (ref {}))
;;"((<,b,a) ? a : b)"
(defmulti emit (fn [_ f _]
                 (cond (parser/form? 'fir_defn_heap f)   'fir_defn_heap
                       (parser/form? 'fir_defn_stack f)  'fir_defn_stack
                       (parser/form? 'fir_defn_arity f)  'fir_defn_arity
                       (parser/form? 'fir_fn_heap f)     'fir_fn_heap
                       (parser/form? 'fir_fn_stack f)    'fir_fn_stack
                       (parser/form? 'defobject f)       'defobject
                       (parser/form? 'native_header f)   'native_header
                       (parser/form? 'native_declare f)  'native_declare
                       (parser/form? 'native_define f)   'native_define
                       (parser/form? 'if f)              'if
                       (parser/form? 'def f)             'def
                       (parser/form? 'fir_new_map f)     'fir_new_map
                       (symbol? f)                 :symbol
                       (keyword? f)                :keyword
                       (number? f)                 :number
                       (nil? f)                    :nil
                       (char? f)                   :char
                       (string? f)                 :string
                       (instance?
                        java.util.regex.Pattern f) :regex-pattern
                       (or (true? f) (false? f))   :boolean
                       (seq? f)                    :invoke-fn
                       :default                    :unsupported-form)))

(defmethod emit :unsupported-form [_ form _]
  (warn "unsopported form =>" form)
  (io/exit-failure))

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

Code generation for a Ferret program is done by running emit on all nodes of the program AST.

(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>(\"" (io/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) ")"))

(defmethod emit 'fir_new_map [options [_ & kvs] state]
  (let [kvs (partition 2 kvs)
        keys (->> (map first kvs)
                  (map #(emit options % state))
                  (interpose \,))
        vals (->> (map second kvs)
                  (map #(emit options % state))
                  (interpose \,))]
    (str "obj<map_t>("
         "runtime::list(" (apply str keys) "),"
         "runtime::list(" (apply str vals) "))")))

(defmethod emit :regex-pattern [options regex state]
  (emit options
        (org.apache.commons.lang.StringEscapeUtils/unescapeJava
         (str regex))
        state))

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

Functions

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

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

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

(defn invoke-fn [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 "ref " name " = "
       parent ".cast<map_t>()->val_at(runtime::list(" (emit nil key nil) "));"))

(defn new-fn-arg [name parent pos]
  (str "ref " name " = " (destructure-nth parent pos)))

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

(defn destructure-associative [name parent pos]
  (let [tmp-name (gensym)]
    [(new-fn-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-fn-arg name parent pos)
                  
                  (parser/form? 'fir_destructure_associative name)
                  (let [[_ & args ] name
                        args (->> args
                                  (partition 2)
                                  (remove #(= (first %) '_))
                                  flatten
                                  (apply hash-map))]
                    (destructure-associative args 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-fn-var-arg name parent pos)
        (coll?    name)  (let [tmp-name (gensym)]
                           [(new-fn-var-arg tmp-name parent pos)
                            (destructure-arguments name tmp-name)])))

(defn destructure-as-arg [name parent]
  (if (symbol?     name)
    (new-fn-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-fn [options [fn & args] state]
  (invoke-fn (emit options fn state) (emit-ast options args state)))

(defmethod emit 'fir_fn_heap [_ f state]
  (new-fn-heap f))

(defmethod emit 'fir_fn_stack [_ f state]
  (new-fn-stack f))

(defn emit-lambda [options name env args body state]
  (let [native-declarations (filter (parser/form? 'native_declare) body)
        return (fn [b] (conj (pop b) (str "return " (last b))))
        body (filter #(not (parser/form? 'native_declare %)) body)
        body (cond  (empty? body)
                    ["return nil()"]
                    ;; multi arity dispacth
                    (parser/form? 'fir_defn_arity (first body))
                    (return
                     (emit options (first body) state))
                    ;; ffi call
                    (parser/ffi-fn? body)
                    (let [buffer (StringBuilder.)]
                      (doseq [b body]
                        (.append buffer b))
                      (let [body (.toString buffer)]
                        (cond (.contains body "__result")
                              ["var __result" body "return __result"]
                              (.contains body "return")
                              [body]
                              :default [body "return nil()"])))
                    ;; s-expression
                    :default (return
                              (emit-ast options body state)))
        env  (norm-fn-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_defn_heap [options [_ name env args & body] state]
  (append-to! state [:lambdas] (emit-lambda options name env args body state)))

(defmethod emit 'fir_defn_stack [options [_ name env args & body] state]
  (append-to! state [:lambdas] (-> (emit-lambda options name env args body state)
                                   (assoc :stack true))))
(defmethod emit 'fir_defn_arity [_ [_ switch default] state]
  (let [default (if default
                  (str (new-fn-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-fn-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:{ref $it$} ;separator=\",\"$) :
            $fn.env:{$it$($it$)} ;separator=\",\"$ { }
        $endif$

        var invoke (ref _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 (ref _args_) const {
        (void)(_args_);
        $fn.vars:{$it$;} ;separator=\"\n\"$
   
        $fn.body:{$it$;} ;separator=\"\n\"$
      }
     };separator=\"\n\n\"$"
   :fns fns))

Program

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
(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
                        (io/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             (io/read-file "ferret/runtime.h")
     :native_headers       native-headers
     :objects              objects
     :symbols              symbol-table
     :native_declarations  native-declarations
     :ferret_cpp           (io/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 io/extension-cpp
          :base-name "solution"
          :binary-file "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      (io/file-path output)
          output-extension (if (args :output) 
                             (io/file-extension (args :output))
                             io/extension-cpp)
          base-name        (io/file-base-name output)
          input-path       (io/file-path input)
          output-file      (io/make-file output-path base-name output-extension)
          binary-file      (if (args :binary) 
                             (args :binary)
                             base-name)
          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 :binary-file        binary-file)
          (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)]
    (io/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 (io/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)
                ["-o" (:binary-file 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)))
                  (io/exit-failure)))]
      (if (not= 0 (:exit ret))
        (do (warn "build error")
            (warn (:err ret))
            (io/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")
          (io/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 C++ File"]
   ["-b" "--binary FILE"        "Output Binary File"]
   ["-c" "--compile"            "Compile to Binary"]
   [nil  "--deps"               "Checkout Input Dependencies"]
   ["-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]
  (try
    (let [args (parse-opts args program-options)
          {:keys [help input deps watch-input]} (:options args)]

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

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

      (let [specs (build-specs input args)]

        (when deps
          (try
            (checkout-deps (:path (specs)))
            (catch Exception e
              (io/exit-failure)))
          (io/exit-success))
        
        (if (not watch-input)
          (build-solution specs)
          (do (watcher/watcher [input]
                               (watcher/rate 1000)
                               (watcher/on-change
                                (fn [_] (build-solution specs))))
              @(promise)))
        (shutdown-agents))
      (io/exit-success))
    (catch Exception e
      (stacktrace/print-stack-trace e 10))))

I/O

Common I/O operations.

(def extension-cpp "cpp")

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

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

Runtime

Runtime needed to support Core. Object system, Memory Management etc.

Object System

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;
typedef var const & ref;
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(ref) 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(ref 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= (ref other){
    if (obj != other.obj){
      dec_ref();
      obj = other.obj;
      inc_ref();
    }
    return *this;
  }

  bool equals (ref) const;

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

  bool operator!=(ref 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();
}
(defn identity [x] x)

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(ref 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 (ref 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 / Value

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(ref 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(ref v){
    return ((T *) v.cast<pointer>()->payload());
  }
  template<typename T> static T& to_reference(ref 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]
  "return obj<value<data>>(number::to<int>(x))")

(defn get-data [x]
  "return 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(ref 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(ref v){
    return v.cast<value<T>>()->to_value();
  }

  T & to_reference() {
    return _value;
  }
  
  static T & to_reference(ref 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 Numeric Tower 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(ref 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(ref v) const {
    return obj<number>(_word + v.cast<number>()->word());
  }
  var sub(ref v) const {
    return obj<number>(_word - v.cast<number>()->word());
  }
  var mul(ref v) const {
    return obj<number>(_word * v.cast<number>()->word());
  }
  var div(ref v) const {
    return obj<number>(_word / v.cast<number>()->word());
  }
  var is_smaller(ref v) const {
    return obj<boolean>(_word < v.cast<number>()->word());
  }
  var is_smaller_equal(ref v) const {
    return obj<boolean>(_word <= v.cast<number>()->word());
  }
  var is_bigger(ref v) const {
    return obj<boolean>(_word > v.cast<number>()->word());
  }
  var is_bigger_equal(ref v) const {
    return obj<boolean>(_word >= v.cast<number>()->word());
  }
  
  template<typename T> static T to(ref 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(ref) 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(ref o) const final {
    return seekable_i::equals(var((object*)this), o);
  }

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

  explicit sequence(ref d = nil(), ref n = nil()) : next(n), data(d) {} 

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(ref x) final {
    return obj<sequence>(x, var(this));
  }
  var first() final {
    return data;
  }
  var rest() final {
    return next;
  }
  template <typename T>
  static T to(ref){
    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(ref v) { 
    return obj<sequence>(v,cached::empty_sequence);
  }
                    
  template <typename... Args>
  inline var list(ref 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(ref v) { 
  std_vector ret;
  for(ref it : runtime::range(v))
    ret.push_back(it);
  return ret;
}

template <> var sequence::from(std_vector v) { 
  var ret;
  for(ref 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 {
  mutex lock;
  var thunk;
  var data;
  var seq;

public:

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

  bool equals(ref o) const final {
    return seekable_i::equals(var((object*)this), o);
  }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    var seq = var((object*)this);
    runtime::print("(");
    runtime::first(seq).stream_console();
    for(ref i : runtime::range(runtime::rest(seq))){
      runtime::print(" ");
      i.stream_console();
    }
    runtime::print(")");
  }
#endif

  explicit lazy_sequence(ref t) : thunk(t) {} 
  explicit lazy_sequence(ref d, ref t) : thunk(t), data(d) {} 

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(ref x) final {
    lock_guard guard(lock);

    if (data.is_nil())
      return obj<lazy_sequence>(x,thunk);

    return obj<sequence>(x, var((object*)this));
  }

  var first() final {
    lock_guard guard(lock);

    if (data.is_nil()){
      seq = run(thunk);
      data = runtime::first(seq);
      seq = runtime::rest(seq);
    }

    return data;
  }
  
  var rest() final {
    lock_guard guard(lock);

    if (seq.is_nil())
      seq = run(thunk);
    
    return seq;
  }
};
(defn new-lazy-seq [f]
  "return 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 [keys vals]
  "return obj<d_list>(keys, vals);")

(defmacro new-d-list [& args]
  (let [kvs (partition 2 args)
        keys (map first kvs)
        vals (map second kvs)]
    `(new-d-list-aux
      (list ~@keys) (list ~@vals))))

(defn assoc [m k v]
  "return m.cast<map_t>()->assoc(k,v);")

(defn dissoc [m k]
  "return m.cast<map_t>()->dissoc(k);")

(defn get [m & args]
  "return m.cast<map_t>()->val_at(args);")

(defn vals [m]
  "return m.cast<map_t>()->vals();")

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

  var data;

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

    for(auto const& 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(ref o) const final {
    return seekable_i::equals(var((object*)this), o);
  }

#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(ref l) : data(l) { }

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

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

  var dissoc(ref k) const {
    number_t idx = val_index(k);
    
    if ( idx == -1 )
      return obj<d_list>(data);

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

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

    var new_values;
    for(auto const& 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(ref args) const {
    ref key = runtime::first(args);
    ref 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(ref 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(ref v) final {
    return runtime::list(v,data);
  }
  
  var first() final {
    ref keys = runtime::first(data);
    ref values = runtime::rest(data);
    return runtime::list(runtime::first(keys),runtime::first(values));
  }
  
  var rest() final {
    ref keys = runtime::first(data);
    ref values = runtime::rest(data);

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

template<>
inline var obj<d_list>(var keys, var vals) {
  void * storage = FERRET_ALLOCATOR::allocate<d_list>();
  return var(new(storage) d_list(runtime::cons(keys,vals)));
}

#if !defined(FERRET_MAP_TYPE)
  typedef d_list map_t;
#endif

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(ref 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(ref args) const {
    ref map = runtime::first(args);
    ref map_args = runtime::cons(var((object*)this), runtime::rest(args));

    if (map.is_type(runtime::type::d_list)){
      return map.cast<map_t>()->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.

(defn new-string
  ([& ss]
   ((fn [s] "return obj<string>(s);")
    (reduce (fn [h v] (concat h v)) ss))))
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(ref other) const final {
    return (container() == other.cast<string>()->container());
  }

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

  explicit string() : data(nullptr) {} 

  explicit string(ref 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(ref x) final {
    return obj<string>(runtime::cons(x,data));
  }

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

  var rest() final {
    ref r = runtime::rest(data);

    if (r != runtime::list())
      return obj<string>(r);

    return runtime::list();
  }

  template <typename T>
  static T to(ref){
    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(ref v) { 
  ::std::stringstream ss;
  for(ref 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(ref 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(ref d) : data(d) {} 

  var swap(ref f, ref 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]
  "return obj<atomic>(x)")

(defn swap! [a f & args]
  "return 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] "return obj<async>(f);")

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

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

(defn thread [f]
  "return 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(ref 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(ref 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]
  "return obj<delayed>(f)")

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

(defn delay? [d]
  "return 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(ref 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(ref 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(ref x) = 0;
  virtual var first() = 0;
  virtual var rest() = 0;

  static bool equals(var lhs, var rhs) {

    for(;;lhs = runtime::rest(lhs), rhs = runtime::rest(rhs)){

      ref lf = runtime::first(lhs);
      ref rf = runtime::first(rhs);

      if (lf.is_nil() && rf.is_nil())
        return true;
      
      if (lf != rf)
        return false;
    }
  }
};

C++ API for the interface,

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

  var first(ref coll);
  var rest(ref coll);
  var cons(ref x, ref seq);
  var nth(ref seq, number_t index);
  var nthrest(ref seq, number_t index);
  size_t count(ref seq);
  bool is_seqable(ref 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(ref 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, ref v = nil()) : index(i) , value(v) { }
  };
  
  struct range_indexed{
    var p;
    number_t index;

    explicit range_indexed(ref 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));
    }
  };
}

Implementations for the C++ Seekable API,

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

  var rest(ref 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(ref x, ref coll){
    if (coll.is_nil() || coll == runtime::list())
      return runtime::list(x);

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

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

    return nil();
  }

  var nthrest(ref 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(ref seq){
    size_t acc = 0;
    for(ref v : runtime::range(seq)){
      (void)v;
      acc++;
    }
    return acc;
  }

  bool is_seqable(ref seq){
    if(seq.cast<seekable_i>())
      return true;
    else
      return false;
  }
}

Lambda

Every lambda object implements the lambda_i 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(ref args) const = 0;

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

  bool equals(ref 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(ref);
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(ref fn) {
  return fn.cast<lambda_i>()->invoke(nil());
}

template<typename... Args>
inline var run(ref 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]
  "return 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));
  }

  template <typename... Ts>
  constexpr size_t max_sizeof() {
    return runtime::max(sizeof(Ts)...);
  }
}

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

Numeric Tower

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 max
  #undef abs

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

  template <typename T, typename... Ts>
  static constexpr T max(T a, Ts... bs) {
    return max(a, max(bs...));
  }
  
  template<typename T>
  constexpr T min(T a, T b){
    return ((a) < (b) ? (a) : (b));
  }

  template <typename T, typename... Ts>
  static constexpr T min(T a, Ts... bs) {
    return min(a, min(bs...));
  }

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

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

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

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

Accessing C,C++ Libraries

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

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"
      "return 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 produce a compiler error. 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(ref 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.

Logic

true?

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

false?

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

nil?

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

not

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

=

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

not=

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

<

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

>

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

>=

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

<=

(defn <=
  ([] true)
  ([x] true)
  ([a b]
   "return 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))))

Flow

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

Iteration

doseq

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

(defn _doseq_ [seq f] "for(ref 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));")

Sequential

list

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

list?

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

empty?

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

cons

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

first

(defn first [x]
  "return runtime::first(x);")

second

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

rest

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

nth

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

nthrest

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

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

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

reduce

(defn reduce
  ([f xs]
   (reduce f (first xs) (rest xs)))
  ([f acc coll]
   "__result = acc;
    for (ref i : runtime::range(coll))
     __result = run(f, __result, i);"))

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

drop-while

Returns a lazy sequence of the items in coll starting from the first item for which (pred item) returns logical false.

(defn drop-while-aux [p c]
  "__result = c;
   while(run(p,__result))
     __result = runtime::rest(__result);")

(defn drop-while [pred coll]
  (lazy-seq
   (drop-while-aux
       (fn [c]
         (and (not (empty? c))
              (pred (first c))))
     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))))

apply

(defn apply [f args] "return 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(ref i : runtime::range(coll)){
     if (!run(pred, i))
      return cached::false_t;
   }
   return 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]
   "return h.cast<number>()->add(v);")
  ([x y & more]
   (reduce + (+ x y) more)))

-

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

*

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

/

(defn /
  ([x]
   (apply / (list 1 x)))
  ([h v]
   "return 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]
  "return 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] "return 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] "return obj<number>((number::to<number_t>(x) & number::to<number_t>(y)));")

bit-not

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

bit-or

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

bit-xor

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

bit-shift-left

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

bit-shift-right

(defn bit-shift-right [x n] "return 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);
    ref obj = runtime::nth(s,(number_t)idx);
    number_t val = number::to<number_t>(obj);
    res |= val << (i * 8);
   }
   return obj<number>(res);")

sqrt

Square root.

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

pow

Returns base raised to the power exponent:

(defn pow [b e]
  "return 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]
  "return obj<number>((real_t)::cos(number::to<real_t>(s)));")

sin

Returns the sine of an angle of x radians.

(defn sin [s]
  "return 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]
  "return 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]
  "return 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]
  "return obj<number>((real_t)::log(number::to<real_t>(x)));")

Returns the natural logarithm of x.

(defn log10 [x]
  "return 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]
  "return 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]
  "return obj<number>((real_t) (number::to<real_t>(x) * 1_pi / 180.0) );")

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

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();
       return obj<number>(time);")
  (on "defined FERRET_HARDWARE_ARDUINO"
      "return 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();
       return obj<number>(time);")
  (on "defined FERRET_HARDWARE_ARDUINO"
      "return 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 []
  "return obj<elapsed_micros>();")

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

(defn elapsed-micros-now [t]
  "return 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(ref 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))))

Functions

fn

Define a fn,

(fn [a] a)

Define a fn and bind name to it,

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

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

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

Functions may also define a variable number of arguments - this is known as a “variadic” function. The variable arguments must occur at the end of the argument list. They will be collected in a sequence for use by the function.

The beginning of the variable arguments is marked with &

(defn hello [greeting & who]
  (println greeting who))

See Accessing C,C++ Libraries for information on how to use Ferret with external libraries.

(defmacro fn [& sig]
  (let [name (if (symbol? (first sig)) (first sig) nil)
        body (if name (rest sig) sig)]
    (if (vector? (first body))
      (let [[args & body] body]
        (new-fir-fn :name name :args args :body body))
      ;; handle multi arity function
      (let [fns   (map (fn* [body]
                            (let [[args & body] body]
                              (new-fir-fn :args args :body body)))
                       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)]
                      `(fir-defn-arity ~switch ~default))
                    `(fir-defn-arity ~fns))]
        (new-fir-fn :escape false :name name :body [fns])))))

A simple macro for calling inline C++,

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

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 %)))
        enabled (-> (symbol-conversion name)
                    (str "_enabled")
                    .toUpperCase)
        body (->> (map #(vector (second %) (last %)) form)
                  (map #(str "\n#if " (first %) " \n"
                             "#define " enabled "\n"
                             (second %)
                             "\n#endif\n"))
                  (apply str))
        body (str body
                  "\n#if !defined " enabled " \n"
                  "# error " (symbol-conversion name)
                  " Not Supported on This Platform \n"
                  "#endif\n")
        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))))

->

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

I/O

print

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

newline

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

println

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

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

slurp

(defnative slurp [f]
  (on "defined FERRET_STD_LIB"
      ("fstream")
      "std::ifstream ifs(string::to<std::string>(f).c_str(),
                         std::ios::in | std::ios::binary | std::ios::ate);
 
       if (!ifs.good())
         return nil();
 
       std::ifstream::pos_type file_size = ifs.tellg();
       ifs.seekg(0, std::ios::beg);

       std::vector<char> bytes(file_size);
       ifs.read(bytes.data(), file_size);
       return obj<string>(std::string(bytes.data(), file_size));"))

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) 
         return nil();
       char buffer[128];
       ::std::string result = \"\";
       while (!feof(pipe.get()))
        if (fgets(buffer, 128, pipe.get()) != NULL)
         result += buffer;
       return obj<string>(result);"))

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

pr-object-sizes

(defn pr-object-sizes []
  (println "Object Sizes")
  (println "\tvar:\t\t\t" (cxx "return obj<number>(sizeof(var));"))
  (println "\tobject:\t\t\t" (cxx "return obj<number>(sizeof(object));"))
  (println "\tpointer:\t\t" (cxx "return obj<number>(sizeof(pointer));"))
  (println "\tnumber:\t\t\t" (cxx "return obj<number>(sizeof(number));"))
  (println "\tkeyword:\t\t" (cxx "return obj<number>(sizeof(keyword));"))
  (println "\tempty_sequence:\t\t" (cxx "return obj<number>(sizeof(empty_sequence));"))
  (println "\tsequence:\t\t" (cxx "return obj<number>(sizeof(sequence));"))
  (println "\tlazy_sequence:\t\t" (cxx "return obj<number>(sizeof(lazy_sequence));"))
  (println "\tstring:\t\t\t" (cxx "return obj<number>(sizeof(string));"))
  (println "\tboolean:\t\t" (cxx "return obj<number>(sizeof(boolean));"))
  (println "\tlambda_i:\t\t" (cxx "return obj<number>(sizeof(lambda_i));"))
  (println "\tatom:\t\t\t" (cxx "return obj<number>(sizeof(atomic));"))
  (println "\telapsed_micros:\t\t" (cxx "return obj<number>(sizeof(elapsed_micros));"))
  (println "\tpid_controller<real_t>:\t"
           (cxx "return 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++;
       return obj<number>((acc*sizeof(FERRET_MEMORY_POOL_PAGE_TYPE)));"))

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++){
     ref 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(ref 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]
  "return obj<multicast_socket>(ip,port);")

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

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

   for(ref b : runtime::range(data))
    buffer[idx++] = (byte)number::to<number_t>(b);
  
   return obj<boolean>(con.cast<multicast_socket>()->send(buffer,idx));")

(defn byte [conn idx]
  "return 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]
  "return 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(ref) 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(ref i, ref 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(); }
};

serial-port

ferret.io.serial includes functions for creating and manipulating serial ports in a portable manner. For example, a serial port may be opened in RAW mode at boud rate (assumes 8 data bits, no parity, one stop bit) using,

(require '[ferret.io.serial :as serial])

(def dev (serial/open "/dev/ttyArduino"))

Once opened, port is ready for read=/=write.

(when (not dev)
  (system-exit 0))

(sleep 2500)

(let [data-out (list \4 \2 \newline)]
  (doseq [byte data-out]
    (serial/write dev byte))

  (sleep 100)
  
  (let [data-in (repeatedly 3 #(serial/read dev))]
    (assert (= data-in data-out))))
(native-header "termios.h"
               "fcntl.h"
               "unistd.h"
               "sys/ioctl.h")

(defn open-aux [port speed v-min v-time]
  "struct termios toptions;
   int fd;

   fd = open(string::to<std::string>(port).c_str(), O_RDWR | O_NOCTTY | O_NDELAY);

   if (fd == -1){
     return nil();
    }else{

     if (tcgetattr(fd, &toptions) < 0) {
       return nil();
     }else{

     speed_t rate = B9600;
  
     switch (number::to<number_t>(speed)) {
         case 9600:
             rate = B9600;
             break;
         case 19200:
             rate = B19200;
             break;
         case 38400:
             rate = B38400;
             break;
         case 57600:
             rate = B57600;
             break;
         case 115200:
             rate = B115200;
             break;
         case 230400:
             rate = B230400;
             break;
         case 460800:
             rate = B460800;
             break;
         case 500000:
             rate = B500000;
             break;
         case 576000:
             rate = B576000;
             break;
         case 921600:
             rate = B921600;
             break;
         case 1000000:
             rate = B1000000;
             break;
         case 1152000:
             rate = B1152000;
             break;
         case 1500000:
             rate = B1500000;
             break;
         case 2000000:
             rate = B2000000;
             break;
         case 2500000:
             rate = B2500000;
             break;
         case 3000000:
             rate = B3000000;
             break;
         case 3500000:
             rate = B3500000;
             break;
         case 4000000:
             rate = B4000000;
             break;
         default: 
             return nil();
      }

      cfsetispeed(&toptions, rate);
      cfsetospeed(&toptions, rate);

      // 8N1
      toptions.c_cflag &= (tcflag_t)~PARENB;
      toptions.c_cflag &= (tcflag_t)~CSTOPB;
      toptions.c_cflag &= (tcflag_t)~CSIZE;
      toptions.c_cflag |= (tcflag_t)CS8;
      // no flow control
      toptions.c_cflag &= (tcflag_t)~CRTSCTS;

      toptions.c_cflag |= (tcflag_t)CREAD | CLOCAL;  // turn on READ & ignore ctrl lines
      toptions.c_iflag &= (tcflag_t)~(IXON | IXOFF | IXANY); // turn off s/w flow ctrl

      toptions.c_lflag &= (tcflag_t)~(ICANON | ECHO | ECHOE | ISIG); // make raw
      toptions.c_oflag &= (tcflag_t)~OPOST; // make raw

      toptions.c_cc[VMIN]  = (cc_t)number::to<number_t>(v_min);
      toptions.c_cc[VTIME] = (cc_t)number::to<number_t>(v_time);

      if( tcsetattr(fd, TCSANOW, &toptions) < 0) {
       return nil();
      }else
        return obj<number>(fd);
    }
   }")

(defn open
  ([port]
   (open-aux port 9600 0 20))
  ([port speed]
   (open-aux port speed 0 20))
  ([port speed v-min v-time]
   (open-aux port speed v-min v-time)))


(defn write [port byte]
  "char b[1] = {number::to<char>(byte)};
   write(number::to<number_t>(port), b, 1);")

(defn available [port]
  "int bytes_ready;
   int op = ioctl(number::to<number_t>(port), FIONREAD, &bytes_ready);
   if (op == -1)
     return nil();
   return obj<number>(bytes_ready);")

(defn read [port]
  "char b[1] = {0};
   ssize_t bytes_read = read(number::to<number_t>(port), b, 1);
   
   if (bytes_read == -1)
     return nil();
   else
     return obj<number>(b[0]);")

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(ref kp, ref ki, ref kd,
                 ref inMin, ref inMax, ref outMin, ref outMax,
                 ref cont,
                 ref 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(ref 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(ref 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(ref 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(ref 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]
  "return 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]
  "return 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(ref a) : avrg(0) {
    alpha = number::to<T>(a);
  }

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

  bool equals(ref 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(ref 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"
      "return 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"
      "return 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));"))

random

(defnative random-seed [pin]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "randomSeed(analogRead(number::to<number_t>(pin)));"))

(defnative random [x]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "return obj<number>(random(number::to<number_t>(x)));"))

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

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.

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 will create a function 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 framework, 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.

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

Function Transforms

(deftest test-fn->lift
  (let [prg-a (compile '((defn one-plus-one []
                           (+ 1 1))

                         (while true
                           (+ 1 1))) {})
        prg-b (fn->lift
               '(fn* outer [a]
                     (fn* inner-a [b]
                          (+ a b))
                     (fn* inner-b [c] c)))

        prg-c (fn->lift
               '((fn* inner-a [a]
                      ((fn* inner-b [b]
                            ((fn* inner-c [c] (+ b c))
                             3))
                       2))
                 1))
        prg-d (fn->lift
               '((fn* inner-a [a]
                      ((fn* inner-b [b]
                            ((fn* inner-c [c] (+ b))
                             3))
                       2))
                 1))]
    ;;while shoud use one-plus-one in its body
    ;;check fn-defined?
    (is (= 2 (count (parser/peek prg-a (fn [f] (= 'one_plus_one f))))))

    (is (= 1 (->> (fn [f] (= '(fir-defn-heap inner-a (a) [b] (+ a b)) f))
                  (parser/peek prg-b)
                  count)))
    (is (= 1 (->> (fn [f] (= '(fir-defn-heap inner-b () [c] c) f))
                  (parser/peek prg-b)
                  count)))
    (is (= 1 (->> (fn [f] (= '(fir-defn-heap inner-c (b) [c] (+ b c)) f))
                  (parser/peek prg-c)
                  count)))
    (is (= 1 (->> (fn [f] (= '(fir-defn-heap inner-c (b) [_] (+ b)) f))
                  (parser/peek prg-d)
                  count)))))
(deftest test-fn->inline
  (let [prg-a (compile '((defn  fn-inline [x] x)
                         (defn ^{:volatile true} fn-no-inline [y] y)
                         (fn-inline 42)
                         (fn-no-inline 42)) {})]
    (is (= 1 (->> (fn [f] (= '(fn_no_inline 42) f))
                  (parser/peek prg-a)
                  count)))
    (is (= 1 (->> (fn [f] (= '((fir_fn_stack fn_inline) 42) f))
                  (parser/peek prg-a)
                  count)))))

Escape Analysis

(deftest test-escape-analysis
  (let [prg-a (compile '((defn self [x] x)
                         (self 42)) {})
        prg-b (compile '((defn self [x] x)
                         (self self)) {})

        prg-c (compile '((defn multi ([x] x))) {})]

    (is (not (empty? (parser/peek prg-a (parser/form? 'fir_defn_stack)))))
    (is (not (empty? (parser/peek
                      prg-a (fn [f] (= '(fir_fn_stack self) f))))))
    
    (is (not (empty? (parser/peek prg-b (parser/form? 'fir_defn_heap)))))
    (is (not (empty? (parser/peek
                      prg-b (fn [f] (= '((fir_fn_stack self) (fir_fn_heap self)) f))))))

    (is (= (->> (parser/peek prg-c (parser/form? 'fir_defn_arity))
                first second first second second)
           (->> (parser/peek prg-c (parser/form? 'fir_defn_stack)) first second)))))

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

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

Functions

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

(deftest fn-test
  (let [f1 (fn [])
        f2 (fn [])
        m-func (fn
                 ([a] 1)
                 ([a b] 2)
                 ([a b c] 3))
        n-func (do (fn
                     ([]    0)
                     ([x]   1)
                     ([x y] 2)))]
    
    (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 (= 0 (n-func)))
    (is (= 1 (n-func 1)))
    (is (= 2 (n-func 1 2)))

    (is (= 3      (#(+ 1 2))))
    (is (= 11     ((fn [n] (+ n 1)) 10)))
    (is (= 3      (((fn [n] (fn [n] n)) 3) 3)))))

(deftest special-forms-test
  (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 (= 10 (adder 9)))
  (is (= 89 (fibo 10))))

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

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

(is (= (list 5 6 7 8 9)
       ((fn recursive-range [x y]
          (if (< x y)
            (cons x (recursive-range (inc x) y))))
        5 10)))
(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))

(defn destructure-test-8 [{a :a} b {c :c}]
  (list a b c))

(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))))
  (is (= (list 1 2 3)        (destructure-test-8 {:a 1} 2 {:c 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))))
(native-declare "ferret::number_t i = 0;")

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

(deftest ffi-test
  (is (= true  ((fn [a b] "return obj<boolean>((a == b))") (list 1 2) (list 1 2))))
  (is (= false ((fn [a b] "return obj<boolean>((a != b))") (list 1 2) (list 1 2))))
  (is (= true  ((fn [a b] "return obj<boolean>((a != b))") (list 1 2) 1)))
  (is (= false ((fn [a b] "return 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)))))
(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))))

Logic

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

Flow

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

Sequential

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

  (let [my-list (list 1 2 3 4 5 6)]
    (is (= (list 3 4 5 6) (drop-while #(> 3 %) my-list)))
    (is (= (list 4 5 6)   (drop-while #(>= 3 %) my-list))))

  (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(ref it : runtime::range(alist)){
                    sum += number::to<number_t>(it);
                  }
                  __result = obj<number>(sum);")]
    (is (= 6 sum))))
(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)))))

(let [acc (atom (list))]
  
  (defn thunk-acc [begin]
    (cons begin
          (lazy-seq
           (swap! acc conj begin)
           (thunk-acc (inc begin)))))

  (let [seq-a (reverse (take 5 (thunk-acc 0)))
        seq-b (map identity seq-a)]
    (is (= seq-a @acc))
    (is (= seq-b @acc))))

Associative

(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 (= {1 2}                         {1 2}))
    (is (not= mn                         {1 2}))
    (is (= (list 0 1)                    (keys m)))
    (is (= (list (list 0 1) (list 1 2))  (vals m)))
    (is (= (list 1 2)                    (m 1)))
    (is (= m                             m))
    (is (= (list 0)                      (keys (dissoc m 1))))
    (is (= mr                            mr))
    (is (= (list :a :b)                  (keys mr)))
    (is (= (list 1  2)                   (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 +))))))

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

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

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

I/O

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

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

Pointer

(deftest pointer-test
  (let [a-ptr (cxx "return obj<pointer>(nullptr);")
        b-ptr (cxx "return 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 "return obj<keyword>(\":space\")")))))

String

(deftest string-test
  (let [s1       "Some String"
        s1-added "ASome String"
        s2       "Other String"
        s1-ret   (fn [] "return obj<string>(\"Some String\");")
        s1-eq    (fn [s] "return obj<boolean>((string::to<std::string>(s) == \"Some String\"))")
        s2       "Ali Topu At"
        s3       (fn [] "std::string s = \"Some String\";
                        return 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))))
    (is (= 11 (count s1)))))

Modules

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 " return obj<number>(dummy_native_fn());")))
  (is (= 2   (cxx "return 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
      "return 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)

Roadmap

Compiler

  • fn
    • Pre/Post conditions for functions.
      • By default print error and abort.
      • Let user define a callback function.
    • Documentation String
  • apply - Behaves differently. (apply + 1 2 '(3 4)) equivalent to (apply + '(1 2 3 4)) in Clojure, (apply + '(1 2 (3 4))) in Ferret.
  • deps.clj
    • Support private git repositories. (HTTPS / SSH)
    • Recursively resolve dependencies of dependencies.
  • Escape Analysis
  • Multimethods
  • Hardware Support - On an unknown arch Ferret will run in safe mode. See Hardware / Operating System Support.
    • Support for user supplied machine architectures.
    • defnative calls in ferret.core are arch dependent.
      • Aggregate on sections from multiple modules.
      • Autogenerate combined defnative.
    • Runtime contains arch specific ifdefs
    • arch.clj similar to deps.clj where platform specific calls can be loaded from a file.
    • Or user tags functions via metadata that provides overrides for arch specific core functions.

Data Structures

Libraries

Issues

Hardware

The Rearview