Ferret Programmer's Manual

Table of Contents

Getting Started

What Is Ferret

Ferret is a free software lisp implementation designed to be used in real time embedded control systems. Ferret lisp compiles down to self contained C++11. Generated code is portable between any Operating System and/or Microcontroller that supports a C++11 compliant compiler. It has been verified to run on architectures ranging from embedded systems with as little as 2KB of RAM to general purpose computers running Linux/Mac OS X/Windows.

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

Features

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

Download

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

Platform independent builds (requires JVM),

Supported package managers,

  • Debian/Ubuntu
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 "0.4.0-bb18aba"]

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

(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

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

Support

Further Reading

Projects

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

License

BSD 2-Clause License

Copyright (c) 2019, 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.

Compiler

Ferret has a similar architecture to other modern compilers,

compiler_arch.png

Figure 1: Ferret Compiler Architecture

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

Compilation

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

(defn compile [form options]
  (->> (ferret-runtime options form)
       (remove-assertions options)
       (expand-macros)
       (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/core.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]
         (->> (seq x)
              (reduce
               (fn[h [k v]]
                 (conj h k v)) [])
              (seq)
              (cons 'fir-new-map))))))

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/lib/ferret/core.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/core.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 '[compiler.io :only [exit-failure]])
      (use '[compiler.core :only [symbol-conversion]])
      (use '[compiler.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)
(deftest let-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)))))

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

  (is (= 42 (let-over-lambda))))
(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)))

(def adder
  (make-adder 1))

(def fibo
  (fn [n]
    (if (< n 2)
      1
      (+ (fibo (- n 1))
         (fibo (- n 2))))))

(deftest fn->list-test
  (is (= 10 (adder 9)))
  (is (= 89 (fibo 10))))

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

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 no-inline [] 42)
(defn inline-defn? [f]
  (and (parser/form? 'def f)
       (-> f second meta :tag (not= 'volatile))
       (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))))
(deftest test-fn->inline
  (let [prg-a (compile '((defn fn-inline [x] x)
                         (defn ^volatile 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)))))
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))) %))))
(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)))))))
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]
  (->> form
       (escape-fn-calls)
       (escape-fn-inheritance)))
(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)))))
Function Calls

Some function calls can be optimized away depending on the following heuristics. 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. If dispatch functions can be resolved in compile time they will be replaced. 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]
  (let [arity (parser/peek
               form
               (fn [f]
                 (and (parser/form? 'fir-defn-heap f)
                      (-> (parser/peek f (parser/form? 'fir-defn-arity))
                          (empty?)
                          (not )))))
        arity (reduce
               (fn [h [_ name _ _ [_ dispatch [_ default]] :as form]]
                 (let [jmp (if default
                             {:default default}
                             {})
                       jmp (reduce (fn[h [arity [_ call]]]
                                     (assoc h arity call))
                                   jmp dispatch)]
                   (assoc h name jmp)))
               {} arity)
        arity-renames (reduce (fn [h [name jmps]]
                                (reduce
                                 (fn [h jump]
                                   (assoc h jump (gensym (str name "__"))))
                                 h (vals jmps)))
                              {} arity)]
    (-> form
        ;; resolve arity calls
        (parser/transform
         (parser/form? 'fir-defn-arity)
         (fn [f]
           (parser/transform f
                             (parser/form? 'fir-fn-heap)
                             (fn [[_ & f]]
                               `(~'fir-fn-stack ~@f)))))
        (parser/transform
         (fn [f]
           (and (seq? f)
                (parser/form? 'fir-fn-heap (first f))
                (arity (-> f first second))))
         (fn [f]
           (let [[[_ fn] & args] f
                 dispatch ((arity fn) (count args))
                 default  ((arity fn) :default)]
             (cond dispatch `((~'fir-fn-heap ~dispatch) ~@args)
                   default  `((~'fir-fn-heap ~default)  ~@args)
                   :default f))))
        (parser/transform
         (fn [f]
           (and (symbol? f)
                (arity-renames f)))
         (fn [f]
           (arity-renames f)))
        ;; resolve fn calls
        (parser/transform
         (fn [f]
           (and (seq? f)
                (parser/form? 'fir-fn-heap (first f))))
         (fn [f]
           (let [[[_ & fn] & args] f]
             `((~'fir-fn-stack ~@fn) ~@args)))))))
Function Inheritance

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-fn-inheritance [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_fn_stack list) f)   'fir_inline_list
                       (parser/form? '(fir_fn_stack first) f)  'fir_inline_first
                       (parser/form? '(fir_fn_stack rest) f)   'fir_inline_rest
                       (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? 'list f)            'list
                       (parser/form? 'defobject f)       'defobject
                       (parser/form? 'matrix f)          'matrix
                       (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 "unsupported 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) "\"," (count form) ")"))

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

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

(defmethod emit :number [_ form state] (str "obj<number>(" (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>("
         "rt::list(" (apply str keys) "),"
         "rt::list(" (apply str vals) "))")))

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

Special Forms

Special forms have evaluation rules that differ from standard Ferret evaluation rules and are understood directly by the compiler. Most special forms define control structures or perform variable bindings—things which functions cannot do.

(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$
       $body$
      #endif"
     :guard       (.toUpperCase (str name))
     :body        def)))

(defmethod emit 'list [options [fn & args] state]
  (let [elements  (->> (emit-ast options args state)
                       (interpose \,)
                       (apply str))]
    (str "rt::list(" elements ")")))

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

(defmethod emit 'matrix [options [_ elements] state]
  (let [rows (count elements)
        cols (-> elements first count)
        elements (apply concat elements)
        elements (map #(if (number? %)
                         (str "real_t(" % ")")
                         (str
                          "number::to<real_t>"
                          "(" (emit options % state) ")"))
                      elements)
        elements (apply str (interpose \, elements))
        matrix-t (str "size_t(" rows "), size_t(" cols ")," elements)
        matrix-decl (str "obj<matrix_t>(" matrix-t ")")]
    matrix-decl))

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

Inline primitive sequence operations. Some sequence operations such as first / rest are implemented as native C++ functions instead of executing a Ferret fn for these operations, these can be replaced with calls to native implementations resulting in much smaller code.

(defmethod emit 'fir_inline_list [options [_ & args] state]
  (str "rt::list(" (apply str (interpose \, (emit-ast options args state))) ")"))

(defmethod emit 'fir_inline_first [options [_ & seq] state]
  (str "rt::first(" (apply str (emit-ast options seq state)) ")"))

(defmethod emit 'fir_inline_rest [options [_ & seq] state]
  (str "rt::rest(" (apply str (emit-ast options seq state)) ")"))

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.

(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))))
(declare destructure-arguments)

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

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

(defn destructure-get [name parent key]
  (str "ref " name " = "
       parent ".cast<map_t>()->val_at(rt::list(" (emit nil key nil) "));"))

(defn new-fn-arg [name parent pos]
  (let [value (destructure-nth parent pos)
        tag   (-> name meta :tag)]
    (condp = tag
      'bool_t     (str "bool " name " = " "bool(" value ")")
      'real_t     (str "real_t " name " = " "number::to<real_t>(" value ")")
      'number_t   (str "number_t " name " = " "number::to<number_t>(" value ")")
      'size_t     (str "size_t " name " = " "number::to<size_t>(" value ")")
      'byte       (str "byte " name " = " "number::to<byte>(" value ")")
      'c_str      (str "var " name "_packed = string::pack(" value ");\n"
                       "char* " name " = " "string::c_str(" name "_packed)")
      'matrix     (str "matrix &" name " = " "value<matrix>::to_reference(" value ")")
      (str "ref " name " = " value))))

(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(rt::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/runtime/runtime.h)
  • Ferret Native Runtime Prototypes (rt::first, rt::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 "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\"$
        }

        // Symbols
        namespace $file${
         using namespace ferret;

         #if defined(ARDUINO)
           typedef ferret::boolean boolean;
         #endif

         $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 "runtime.h")
     :native_headers       native-headers
     :objects              objects
     :symbols              symbol-table
     :native_declarations  native-declarations
     :ferret_cpp           (io/read-file "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"]
   [nil  "--silent"             "Silent or quiet mode"]
   ["-h" "--help"               "Print Help"]])

Compiler main,

(defn -main [& args]
  (try
    (let [args (parse-opts args program-options)
          {:keys [help input deps watch-input silent]} (: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 silent
        (System/setProperty "org.slf4j.simpleLogger.defaultLogLevel" "warn"))

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

template<typename>
void type_id(){}

using type_id_t = void(*)();
typedef type_id_t type_t;

class var;
typedef var const & ref;
class seekable_i;

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

  virtual type_t type() const = 0;

#if !defined(FERRET_DISABLE_STD_OUT)
  virtual void stream_console() const {
    rt::print("var#");
    const void* addr = this;
    rt::print(addr);
  }
#endif

  virtual bool equals(ref) const;

  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 pointer_t holds a pointer to a Ferret object. Default pointer_t does nothing and delegates all requests to a regular object *. See Pointers for rationale.

#if !defined(FERRET_POINTER_T)
  #define FERRET_POINTER_T memory::pointer<object>
#endif

typedef FERRET_POINTER_T pointer_t;

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 inline var(object* o = nullptr) : obj(o) { inc_ref(); }
  inline var(ref o)   : obj(o.obj) { inc_ref(); }
  inline var(var&& o) : obj(o.detach()) { }

  ~var() { dec_ref(); }

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

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

  void* operator new(size_t, void* ptr){ return ptr; }

  operator bool() const;

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

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

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

  inline bool is_type(type_t type) const {
    if (obj)
      return (static_cast<object*>(obj)->type() == type);
    return false;
  }

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

private:
  object* detach(){
    object* _obj = obj;
    obj = nullptr;
    return _obj;
  }

  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
  }

  pointer_t obj;
};

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

template <typename rc>
bool object_i<rc>::equals(ref o) const {
  return (this == o.get());
}

#ifdef FERRET_STD_LIB
std::ostream &operator<<(std::ostream &os, var const &v) {
  v.stream_console();
  return os;
}
#endif

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 "boolean_o.h")
class boolean final : public object {
  const bool value;
public:

  type_t type() const final { return type_id<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)
      rt::print("true");
    else
      rt::print("false");
  }
#endif

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

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

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

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

bool var::equals (ref other) const {
  if (get() == other.get())
    return true;

  if (!is_nil() && !other.is_nil()){

    if (rt::is_seqable(*this) && rt::is_seqable(other))
      return seekable_i::equals(*this, other);
    else if (obj->type() != other.get()->type())
      return false;
    else
      return get()->equals(other);

  }else
    return false;
}
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);
(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)))
(defobject pointer "pointer_o.h")
class pointer final : public object {
  void * payload;
public:


  type_t type() const final { return type_id<pointer>; }

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

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

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

(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))))))
(defobject value "value_o.h")
template <typename T>
class value final : public object {
  T payload;
public:

  type_t type() const final { return type_id<value>; }

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

  T to_value() const {
    return payload;
  }

  static T to_value(ref v){
    return v.cast<value<T>>()->payload;
  }

  T & to_reference() {
    return payload;
  }

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

typedef value<matrix> matrix_t;
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 "number_o.h")
class number final : public object {
  const real_t n;
public:

  type_t type() const final { return type_id<number>; }

  bool equals(ref o) const final {
    return (rt::abs(n - number::to<real_t>(o)) < real_epsilon);
  }

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

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

  template<typename T> static T to(ref v){
    return (T)v.cast<number>()->n;
  }
};
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 "empty_sequence_o.h")
(defobject sequence "sequence_o.h")
class empty_sequence final : public object {

  type_t type() const final { return type_id<empty_sequence>; }

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

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

    type_t type() const final { return type_id<sequence>; }

#if !defined(FERRET_DISABLE_STD_OUT)
    void stream_console() const final {
      seekable_i::stream_console(var((object*)this));
    }
#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_o;
    }
    inline var list(ref v) { 
      return obj<sequence>(v,cached::empty_sequence_o);
    }

    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_each(i, v)
      ret.push_back(i);
    return ret;
  }

  template <> var sequence::from(std_vector v) { 
    var ret;
    std::vector<var>::reverse_iterator rit;
    // cppcheck-suppress postfixOperator
    for(rit = v.rbegin(); rit != v.rend(); rit++)
      ret = rt::cons(*rit,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. By default Ferret lazy_sequence=s does not cache their values unless forced using =lazy-seq-cache.

(defobject lazy_sequence "lazy_sequence_o.h")
class lazy_sequence final : public object, public seekable_i {
  mutex lock;
  bool cache;
  var thunk;
  var data;
  var seq;

  void yield(){
    if (thunk.is_nil())
      return;

    seq = run(thunk);

    if (data.is_nil()){
      data = rt::first(seq);
      seq = rt::rest(seq);
    }

    thunk = nil();
  }

public:

  type_t type() const final { return type_id<lazy_sequence>; }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    seekable_i::stream_console(var((object*)this));
  }
#endif

  explicit lazy_sequence(ref t, bool c = false) : cache(c), thunk(t) {}
  explicit lazy_sequence(ref d, ref t, bool c = false) : cache(c), 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, cache);

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

  var first() final {
    lock_guard guard(lock);
    if (cache)
      yield();
    else
      if (data.is_nil())
        return rt::first(run(thunk));
    return data;
  }

  var rest() final {
    lock_guard guard(lock);
    var tail;

    if (cache){
      yield();
      tail = seq;
    }else{
      tail = run(thunk);
      if (data.is_nil())
        return rt::rest(tail);
    }

    if (tail.is_nil())
      return rt::list();

    return tail;
  }

  static var from(ref seq) {
    class walk : public lambda_i {
      var seq;
    public:
      explicit walk(ref s) : seq(s) { }
      var invoke(ref) const final {
        var tail = rt::rest(seq);
        if (tail.is_nil())
          return nil();

        return obj<lazy_sequence>(rt::first(seq), obj<walk>(tail), true);
      }
    };

    return obj<lazy_sequence>(obj<walk>(seq), true);
  }
};
Array Sequence

Creates a view of an array.

(deftest array-seq-test
  (is (= (cxx "int buff[3] = {1,2,3};
               return obj<array_seq<int, number>>(buff, size_t(3));")
         (list 1 2 3))))
(deftest dense-list-test
  (is (= (cxx "return rt::dense_list
                   (obj<number>(42), obj<number>(43));")
         (list 42 43))))
(defobject array_sequence "array_sequence_o.h")
template<typename element_t, typename object_t>
class array_seq : public object , public seekable_i {
  size_t pos;

public:
  typedef array<element_t> array_t;
  typedef value<array_t> value_t;

  var storage;

  explicit array_seq(const element_t* src, size_t s = 0)
    : pos (0), storage(obj<value_t>(src, s)) { }

  explicit array_seq(var b, size_t p = 0) : pos(p), storage(b){ }

  explicit array_seq(size_t size) : pos(0), storage(obj<value_t>(size)){ }

  type_t type() const final { return type_id<array_seq>; }

#if !defined(FERRET_DISABLE_STD_OUT)
    void stream_console() const final {
      seekable_i::stream_console(var((object*)this));
    }
#endif

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(ref x) final {
    return obj<sequence>(x, var(this));
  }

  var first() final {
    array_t& b = value_t::to_reference(storage);
    return obj<object_t>(b[pos]);
  }

  var rest() final {
    array_t& b = value_t::to_reference(storage);

    if (pos < b.size() - 1)
      return obj<array_seq>(storage, pos + 1);

    return rt::list();
  }
};
template <>
class array<var> {
  size_t  _size{0};

  var* allocate(){
    var* storage = static_cast<var*>(FERRET_ALLOCATOR::allocate(_size * sizeof(var))) ;
    for(size_t i = 0; i < _size; i++)
      new (&storage[i]) var();
    return storage;
  }

public:

  var* data {nullptr};

  explicit inline array(size_t s = 0) : _size(s), data(allocate()) { }

  inline array(array&& m) :
    _size(m.size()), data(m.data) { m.data = nullptr; }

  inline array(array& m) : _size(m.size()), data(allocate()) {
    for(size_t i = 0; i < _size; i++)
      data[i] = m.data[i];
  }

  ~array(){
    for(size_t i = 0; i < size(); i++)
      (&data[i])->~var();
    FERRET_ALLOCATOR::free(data);
  }

  inline array& operator=(array&& x){
    data = x.data;
    _size = x._size;
    x.data = nullptr;
    return *this;
  }

  inline var& operator [](size_t idx)      { return data[idx]; }
  inline var operator [](size_t idx) const { return data[idx]; }

  inline var*    begin() const { return &data[0];      }
  inline var*    end()   const { return &data[_size];  }
  inline size_t  size()  const { return _size;         }
};
typedef array<var> var_array_t;
typedef value<var_array_t> var_array;
typedef array_seq<var,var> var_array_seq;

template<>
class array_seq<var,var> : public object , public seekable_i {
  size_t pos{0};

  inline static void into_aux(ref){ }

  template<typename... Args>
  inline static void into_aux(ref arr, ref first, Args... rest){
    auto& data = var_array::to_reference(arr);
    data[data.size() - sizeof...(rest) - 1] = first;
    into_aux(arr, rest...);
  }

public:
  var storage;

  explicit array_seq(var b, size_t p = 0) : pos(p), storage(b){ }

  type_t type() const final { return type_id<array_seq>; }

#if !defined(FERRET_DISABLE_STD_OUT)
    void stream_console() const final {
      seekable_i::stream_console(var((object*)this));
    }
#endif

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(ref x) final {
    return obj<sequence>(x, var(this));
  }

  var first() final {
    var_array_t& b = var_array::to_reference(storage);
    return b[pos];
  }

  var rest() final {
    var_array_t& b = var_array::to_reference(storage);

    if (pos < b.size() - 1)
      return obj<array_seq>(storage, pos + 1);

    return rt::list();
  }

  template<typename... Args>
  static inline var into(Args... rest){
    var arr = obj<var_array>(sizeof...(rest));
    into_aux(arr, rest...);
    return obj<var_array_seq>(arr);
  }
};

namespace runtime{
  template<typename... Args>
  static inline var dense_list(Args... rest){
    return var_array_seq::into(rest...);
  }
}
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 ...)
(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 +))))))
(defobject d-list "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;

  var dissoc_aux(ref k) const {
    ref _keys = rt::first(data);
    var _values = rt::rest(data);

    var new_keys;
    var new_values;

    for_each(i, _keys){
      if ( i == k)
        continue;
      new_keys = rt::cons(i, new_keys);
      new_values = rt::cons(rt::first(_values), new_values);
      _values = rt::rest(_values);
    }

    return rt::cons(new_keys,new_values);
  }

 public:

  type_t type() const final { return type_id<d_list>; }

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

  explicit d_list() : data(rt::list(rt::list())) { }
  explicit d_list(ref l) : data(l) { }

  var assoc(ref k, ref v) const {
    ref map = dissoc_aux(k);
    ref _keys = rt::first(map);
    ref _values = rt::rest(map);

    return obj<d_list>(rt::cons(rt::cons(k,_keys),
                                     rt::cons(v,_values)));
  }

  var dissoc(ref k) const {
    return obj<d_list>(dissoc_aux(k));
  }

  var val_at(ref args) const {
    ref key = rt::first(args);
    ref not_found = rt::first(rt::rest(args));

    ref _keys = rt::first(data);
    var _values = rt::rest(data);

    for_each(i, _keys){
      if (key == i)
        return rt::first(_values);

      _values = rt::rest(_values);
    }

    if (!not_found.is_nil()){
      return not_found;
    }else{
      return nil();  
    }
  }

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

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

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(ref v) final {
    return rt::list(v,data);
  }

  var first() final {
    ref _keys = rt::first(data);
    ref _values = rt::rest(data);
    return rt::list(rt::first(_keys),rt::first(_values));
  }

  var rest() final {
    ref _keys = rt::first(data);
    ref _values = rt::rest(data);

    if(rt::rest(_keys).is_type(type_id<empty_sequence>))
      return rt::list();

    return obj<d_list>(rt::cons(rt::rest(_keys),rt::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(rt::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.

(deftest keyword-test
  (is (= true  (= :test  :test)))
  (is (= false (= :test  :other_test)))
  (is (= true  (= :space (cxx "return obj<keyword>(\":space\")")))))
(defobject keyword "keyword_o.h")
class keyword final : public lambda_i {
  const number_t hash;

  static constexpr number_t hash_key(const char * key){
    return *key ? (number_t)*key + hash_key(key + 1) : 0;
  }

public:

  type_t type() const final { return type_id<keyword>; }

  bool equals(ref o) const final { return (hash == o.cast<keyword>()->hash); }

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

  explicit keyword(number_t w) : hash(w) {} 
  explicit keyword(const char * str): hash(hash_key(str)) { }

  var invoke(ref args) const final {
    ref map = rt::first(args);
    ref map_args = rt::cons(var((object*)this), rt::rest(args));

    if (map.is_type(type_id<map_t>)){
      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 "string_o.h")
(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)))
    (is (true?       (string? s1)))
    (is (false?      (string? 42)))))

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
  ([]
   "")
  ([x]
   "return obj<string>(x);")
  ([x y]
   (new-string (concat x y)))
  ([x y & more]
   (new-string (concat x y) (apply concat more))))
class string final : public object, public seekable_i {
  var data;

  typedef array_seq<byte, number> array_seq_t;
  typedef array<byte> array_t;

  void from_char_pointer(const char * str, int length){
    data = obj<array_seq_t>((byte*)str, (size_t)(length + 1));

    var seq = (data.cast<array_seq_t>()->storage);
    auto & arr = value<array_t>::to_reference(seq).data;
    arr[length] = 0x00;
  }

public:

  type_t type() const final { return type_id<string>; }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    var packed = string::pack(var((object*)this));
    char* str = string::c_str(packed);
    rt::print(str);
  }
#endif

  explicit string() : data(rt::list()) {} 

  explicit string(ref s) : data(s) {}

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

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

  virtual seekable_i* cast_seekable_i() { return this; }

  var cons(ref x) final {
    return obj<string>(rt::cons(x,data));
  }

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

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

    if (r.is_type(type_id<array_seq_t>))
      if (rt::first(r) == obj<number>(0))
        return rt::list();

    if (!r.is_type(type_id<empty_sequence>))
      return obj<string>(r);

    return rt::list();
  }

  static var pack(ref s)  {
    if (s.cast<string>()->data.is_type(type_id<array_seq_t>))
      return s.cast<string>()->data;

    size_t size = rt::count(s);
    var packed_array = obj<value<array_t>>(size + 1);
    auto& packed_data = value<array_t>::to_reference(packed_array).data;

    size_t pos = 0;
    for_each(c, s){
      packed_data[pos] = number::to<byte>(c);
      pos++;
    }
    packed_data[pos] = 0x00;

    return obj<array_seq_t>(packed_array);
  }

  static char* c_str(ref s)  {
    var seq = (s.cast<array_seq_t>()->storage);
    auto & str = value<array<byte>>::to_reference(seq).data;
    return (char*) str;
  }

  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 str) {
  var packed = string::pack(str);
  return std::string(string::c_str(packed));
}
#endif

#ifdef FERRET_HARDWARE_ARDUINO
template<>
inline var obj<string>(String s) {
  void * storage = FERRET_ALLOCATOR::allocate<string>();
  return var(new(storage) string(s.c_str(), (number_t)s.length()));
}

template <> String string::to(ref str) {
  var packed = string::pack(str);
  return String(string::c_str(packed));
}
#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.

(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)))))
(defobject atomic "atomic_o.h")
class atomic final : public deref_i {
  mutex lock;
  var data;

  public:

  type_t type() const final { return type_id<atomic>; }

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

  explicit atomic(ref d) : data(d) {} 

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

  var reset(ref newval){
    lock_guard guard(lock);
    data = newval;
    return data;
  }

  var deref() final {
    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]
  "return a.cast<atomic>()->reset(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.

(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)))))
(defobject async "async_o.h")

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

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

(defn future-done? [f]
  "if (f.cast<async>()->is_ready())
     return cached::true_o;
   else
     return cached::false_o;")

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 {
  mutex lock;
  bool cached;
  var value;
  var fn;
  std::future<var> task;

  inline var exec() {
    return run(fn);
  }

  public:

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

  type_t type() const final { return type_id<async>; }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    rt::print("future<");
    fn.stream_console();
    rt::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() final {
    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.

(deftest delay-test
  (let [d (delay   (+ 1 1))]

    (is (= true    (delay? d)))
    (is (= 2       @d))
    (is (= 2       @d))
    (is (= 42      (force (delay 42))))))
(defobject delayed "delayed_o.h")

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

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

(defn delay? [d]
  "if (d.is_type(type_id<delayed>))
     return cached::true_o;
   else
     return cached::false_o;")

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

  public:

  type_t type() const final { return type_id<delayed>; }

  explicit delayed(ref f) : fn(f) {} 

  var deref() final {
    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 "seekable_i.h")
  class seekable_i {
  public:

    virtual var cons(ref x) = 0;
    virtual var first() = 0;
    virtual var rest() = 0;

#if !defined(FERRET_DISABLE_STD_OUT)
    static void stream_console(ref coll) {
      var tail = rt::rest(coll);

      rt::print('(');
      if (tail)
        rt::first(coll).stream_console();

      for_each(i, tail){
        rt::print(' ');
        i.stream_console();
      }
      rt::print(')');
    }
#endif

    static bool equals(var lhs, var rhs) {

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

        ref lf = rt::first(lhs);
        ref rf = rt::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);
    template <typename... Args>
    var list(ref first, Args const & ... args);

    inline bool is_seqable(ref seq);

    inline var first(ref seq);
    inline var rest(ref seq);
    inline var cons(ref x, ref seq);

    var nth(var seq, number_t index);
    var nthrest(var seq, number_t index);

    inline size_t count(ref seq);

    inline var range(number_t low, number_t high);
  }

#define for_each(x,xs) for(var _tail_ = rt::rest(xs), x = rt::first(xs);     \
                           !_tail_.is_nil();                                 \
                           x = rt::first(_tail_), _tail_ = rt::rest(_tail_))

Implementations for the C++ Seekable API,

namespace runtime {
  inline bool is_seqable(ref coll){
    if(coll.cast<seekable_i>())
      return true;
    else
      return false;
  }

  inline var first(ref seq){
    if (seq.is_nil() || seq.is_type(type_id<empty_sequence>))
      return nil();
    return seq.cast<seekable_i>()->first();
  }

  inline var rest(ref seq){
    if (seq.is_nil() || seq.is_type(type_id<empty_sequence>))
      return nil();
    return seq.cast<seekable_i>()->rest();
  }

  inline var cons(ref x, ref seq){
    if (seq.is_nil() || seq.is_type(type_id<empty_sequence>))
      return rt::list(x);
    return seq.cast<seekable_i>()->cons(x);
  }

  var nth(var seq, number_t index){
    if (index < 0)
      return nil();

    for(number_t i = 0; i < index; i++)
      seq = rt::rest(seq);
    return rt::first(seq);
  }

  var nthrest(var seq, number_t index){
    for(number_t i = 0; i < index; i++)
      seq = rt::rest(seq);

    if (seq.is_nil())
      return rt::list(); 

    return seq;
  }

  inline size_t count(ref seq){
    size_t acc = 0;

    for(var tail = rt::rest(seq);
        !tail.is_nil();
        tail = rt::rest(tail))
      acc++;

    return acc;
  }

  inline var range(number_t low, number_t high){
    class seq : public lambda_i {
      number_t low, high;
    public:
      explicit seq(number_t l, number_t h) : low(l), high(h) { }
      var invoke(ref) const final {
        if (low < high)
          return obj<lazy_sequence>(obj<number>(low), obj<seq>((low + 1), high));
        return nil();
      }
    };
    return obj<lazy_sequence>(obj<seq>(low, high));
  }
}
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 "lambda_i.h")
struct lambda_i : public object {
  virtual var invoke(ref args) const = 0;
  type_t type() const { return type_id<lambda_i>; }
};

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

namespace runtime{
  inline var apply(ref fn, ref argv);
}
template<typename T, typename... Args>
inline var run(T const & fn, Args const & ... args) {
  return fn.invoke(rt::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(rt::list(args...));
}

namespace runtime {
  inline var apply(ref f, ref argv){
    if (rt::rest(argv).is_type(type_id<empty_sequence>))
      return f.cast<lambda_i>()->invoke(rt::first(argv));

    struct{
      var operator()(ref seq) const {
        ref head = rt::first(seq);

        if (head.is_nil())
          return cached::empty_sequence_o;

        if (head.cast<seekable_i>())
          return head;

        return rt::cons(head, (*this)(rt::rest(seq)));
      }
    } spread;

    return f.cast<lambda_i>()->invoke(spread(argv));
  }
}
Deref
(defobject deref_i "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 size_t=s. By default page size is =sizeof(size_t). This can be changed using,

(configure-runtime! FERRET_MEMORY_POOL_PAGE_TYPE byte)

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

Pointers

Each var holds a reference to a Ferret object using one of the pointer types below. Default pointer_t does nothing and delegates all requests to a regular object *. Using this scheme allows optional use of tagged pointers on systems that support them.

namespace memory {
  template <typename T>
  class pointer{
    T *ptr;

  public:

    inline explicit pointer(T *p = nullptr) : ptr(p){ }
    inline operator T* () const { return ptr; }

    inline pointer& operator= (T *other){
      ptr = other;
      return *this;
    }

    inline T *operator->() const { return ptr; }
  };
}

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
 #endif

namespace memory{
  namespace allocator{

    memory_pool<FERRET_MEMORY_POOL_PAGE_TYPE, FERRET_MEMORY_POOL_SIZE> program_memory;

    class pool{
    public:

      static void init(){ }

      static inline void*  allocate(size_t s){
        return program_memory.allocate(s);
      }

      template<typename FT>
      static inline void* allocate(){ return 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.

#define FERRET_MEMORY_POOL_SIZE 4_MB
#define FERRET_BITSET_WORD_TYPE unsigned int

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

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

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

  size_t byte_s = sizeof(ferret::byte);

  memory_pool<ferret::byte, 8, unsigned char> nano_pool;

  void* a = nano_pool.allocate(byte_s);
  assert(nullptr  != a);
  assert(2        == nano_pool.used.ffr(0));
  assert(nullptr  != nano_pool.allocate(byte_s));
  assert(4        == nano_pool.used.ffr(0));

  void* c = nano_pool.allocate(byte_s);

  assert(nullptr  != c);
  assert(6        == nano_pool.used.ffr(0));
  assert(nullptr  != nano_pool.allocate(byte_s));

  nano_pool.free(c);

  assert(4        == nano_pool.used.ffr(0));
  assert(6        == nano_pool.used.ffs(4));
  assert(nullptr  != nano_pool.allocate(byte_s));

  memory_pool<ferret::byte, 16, unsigned char> tiny_pool;

  assert(0        == tiny_pool.used.ffr(0));
  assert(nullptr  != tiny_pool.allocate(byte_s * 2));
  assert(3        == tiny_pool.used.ffr(0));

  void* p = tiny_pool.allocate(byte_s * 4);

  assert(nullptr  != p);
  assert(8        == tiny_pool.used.ffr(0));

  tiny_pool.free(p);

  assert(3        == tiny_pool.used.ffr(0));
  assert(nullptr  == tiny_pool.allocate(byte_s * 40));
  assert(nullptr  != tiny_pool.allocate(byte_s * 6));
  assert(nullptr  != tiny_pool.allocate(byte_s * 1));
  assert(nullptr  != tiny_pool.allocate(byte_s * 1));
  assert(nullptr  == tiny_pool.allocate(byte_s * 10));

  memory_pool<uint64_t, 256> big_pool;

  assert(0        == big_pool.used.ffr(0));

  p = big_pool.allocate(1);

  assert(nullptr  != p);

  assert(2        == big_pool.used.ffr(0));

  big_pool.free(p);

  assert(0        == big_pool.used.ffr(0));
  assert(nullptr  == big_pool.allocate(2048));
  assert(0        == big_pool.used.ffr(0));

  return 0;
}
#ifdef FERRET_MEMORY_POOL_SIZE
namespace memory{
  namespace allocator{
    template<typename page_t, size_t pool_size,
             typename bitset_word_t = FERRET_BITSET_WORD_TYPE>
    struct memory_pool {
      bitset<pool_size, bitset_word_t> used;
      page_t pool[pool_size];
      size_t next_ptr;

      memory_pool() : pool{0}, next_ptr(0) { }

      inline size_t scan(size_t n_pages, size_t from_page = 0) const {
        for(;;){
          size_t begin = used.ffr(from_page);
          size_t end   = begin + n_pages;

          if (end > pool_size)
            return pool_size;

          if (used.ffs(begin, end) >= end)
            return begin;

          from_page = end;
        }
      }

      void *allocate(size_t req_size){
        req_size = align_of(req_size, sizeof(page_t)) + sizeof(page_t);
        size_t n_pages = req_size / sizeof(page_t);
        size_t page   = scan(n_pages, next_ptr);

        if (page == pool_size){
          page = scan(n_pages);
          if (page == pool_size)
            return nullptr;
        }

        pool[page] = (page_t)n_pages;
        next_ptr = page + n_pages;
        used.flip(page, next_ptr);

        return &pool[++page];
      }

      void free(void *p){
        ptrdiff_t begin = (static_cast<page_t *>(p) - pool) - 1;
        ptrdiff_t end = begin + (ptrdiff_t)pool[begin];
        used.flip((size_t)begin, (size_t)end);
      }
    };
  }
}
#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(); }

      static inline void* allocate(size_t s){
#ifdef FERRET_DISABLE_MULTI_THREADING
        return GC_MALLOC(s);
#else
        return GC_MALLOC_ATOMIC(s);
#endif
      }

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

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

      static inline void* allocate(size_t s){ return ::malloc(s); }

      template<typename FT>
      static inline void* allocate(){ return allocate(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(); }

      static inline void* allocate(size_t s){
        lock_guard guard(lock);
        return FERRET_ALLOCATOR::allocate(s);
      }

      template<typename FT>
      static inline void* allocate(){ return allocate(sizeof(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; }

  static inline void* allocate(size_t s){ return ::malloc(s); }

  template<typename FT>
  static inline void* allocate(){ return allocate(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 rt::max(sizeof(Ts)...);
  }
}
Alloca

alloca is a special allocator used by the compiler. If a variable can be proven to not escape its scope, storage for it can be allocated on the stack instead of the heap.

#undef alloca

template<typename T>
class alloca {

  byte memory [sizeof(T)];

public:

  template<typename... Args>
  inline explicit alloca(Args... args) {
    (new(memory) T(args...))->inc_ref();
  }

  inline operator object*() {
    return (object*)memory;
  }
};

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.

#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.0001
#endif

  int req_real_precision(double t) {
    return ((-1 * (int)log10(t)));
  }

  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);
  const   int                 real_precision = req_real_precision(FERRET_REAL_EPSILON);

Math

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

Fixed Point Math

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>")
(configure-runtime! FERRET_REAL_TYPE    "ferret::fixed_real<24,16>"
                    FERRET_REAL_EPSILON 0.0001)

(cxx "static_assert(sizeof(int24_t) == 3 * sizeof(byte), \"\");")
(cxx "static_assert(sizeof(int24_t) ==     sizeof(real_t), \"\");")

(deftest math
  (is (=  3    (+  1.25   1.75)))
  (is (=  0.5  (- -1.25  -1.75)))
  (is (=  255  (+  254    1)))
  (is (=  255  (+  253.4  1.6)))
  (is (= -255  (- -254    1))))

(run-all-tests)
#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;
}
#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 int24_t next_type; };
template<> struct fixed_real_container<24> { typedef int24_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; };

#pragma pack(push, 1)
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
};
#pragma pack(pop)

Matrices

A matrix is a two-dimensional array often used for linear algebra.

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

int main() {
  using namespace ferret;

  //initializers
  assert((matrix::zeros(2,2)  == matrix::into<2,2>(0,0,0,0)));
  assert((matrix::ones(2,2)   == matrix::into<2,2>(1,1,1,1)));
  assert((matrix::eye(2)      == matrix::into<2,2>(1,0,0,1)));
  assert((matrix::full(2,2,4) == matrix::into<2,2>(4,4,4,4)));

  //shape
  assert((matrix::row_count(matrix::zeros(2,3))    == 2));
  assert((matrix::column_count(matrix::zeros(2,3)) == 3));

  //operations
  matrix ones  = matrix::ones(2,2);
  matrix zeros = matrix::zeros(2,2);
  matrix twos  = matrix::full(2,2,2);

  assert((ones - ones == zeros));
  assert((ones + ones == twos));
  assert((ones * 2    == twos));

  auto v3d = matrix::into<1,3>(0, 10, 0);

  assert((matrix::norm_euclidean(v3d) == 10));
  assert((matrix::normalise(v3d)      == matrix::into<1,3>(0, 1, 0)));
  return 0;
}
class matrix {
  //row-major
  array<real_t> data;
  //shape
  size_t  rows{0};
  size_t  cols{0};

  inline static void into_aux(matrix &){ }

  template<typename... Args>
  inline static void into_aux(matrix &m, real_t first, Args... rest){
    m.data[m.data.size() - sizeof...(rest) - 1] = first;
    into_aux(m, rest...);
  }

public:
  inline matrix(size_t r = 0, size_t c = 0) :
    data(r * c), rows(r) , cols(c) { }

  template<typename... Args>
  inline matrix(size_t rows, size_t cols, Args... elements)
    : matrix(rows,cols) {
    into_aux(*this, elements...);
  }

  inline matrix(matrix&& m) :
    data(m.data), rows(m.rows), cols(m.cols) { }

  inline matrix(matrix& m)
    : matrix(m.rows,m.cols){
    for(size_t i = 0; i < data.size(); i++)
      data[i] = m.data[i];
  }

  inline matrix operator+ (const matrix& m) const {
    matrix sum(rows,cols);
    for(size_t i = 0; i < data.size(); i++)
      sum.data[i] = data[i] + m.data[i];
    return sum;
  }

  inline matrix operator- (const matrix& m) const {
    matrix diff(rows,cols);
    for(size_t i = 0; i < data.size(); i++)
      diff.data[i] = data[i] - m.data[i];
    return diff;
  }

  matrix operator* (const matrix& m) const {
    matrix mul = matrix::zeros(rows, m.cols);

    if (cols != m.rows)
      return mul;

    for (size_t i = 0; i < rows; i++) {
      for (size_t j = 0; j < m.cols; j++) {
        for (size_t k = 0; k < m.rows; k++) {
          mul(i,j, mul(i,j) + operator()(i,k) * m(k,j));
        }
      }
    }

    return mul;
  }

  matrix operator* (const real_t& val) const {
    matrix mul(rows,cols);
    for(size_t i = 0; i < data.size(); i++)
      mul.data[i] = data[i] * val;
    return mul;
  }

  inline real_t operator()(size_t row, size_t col) const {
    return data[row * cols + col];
  }

  inline void operator()(size_t row, size_t col, real_t val) {
    data[row * cols + col] = val;
  }

  inline matrix& operator=(matrix&& x){
    data = array<real_t>(x.data);
    rows = x.rows;
    cols = x.cols;
    return *this;
  }

  inline bool operator ==(const matrix& m) const {
    for (size_t i = 0; i < data.size(); i++)
      if (data[i] != m.data[i])
        return false;
    return true;
  }

#if defined(FERRET_STD_LIB)
  friend std::ostream& operator<< (std::ostream& stream, const matrix& x) {
    stream << "[";
    for (size_t r = 0; r < x.rows; r++){
      stream << "[";
      stream << x(r, 0);
      for (size_t c = 1; c < x.cols; c++)
        stream << " " << x(r,c);
      stream << "]";
    }
    return stream << "]";
  }
#endif

  inline static matrix empty(size_t r = 0, size_t c = 0) {
    return matrix(r,c);
  }

  inline static void fill(matrix& m, real_t val) {
    for(size_t i = 0; i < m.data.size(); i++)
      m.data[i] = val;
  }

  inline static matrix zeros(size_t r = 0, size_t c = 0) {
    matrix m(r,c);
    fill(m, real_t(0));
    return m;
  }

  inline static matrix ones(size_t r = 0, size_t c = 0) {
    matrix m(r,c);
    fill(m, real_t(1));
    return m;
  }

  inline static matrix full(size_t r = 0, size_t c = 0, real_t v = real_t(0)) {
    matrix m(r,c);
    fill(m, v);
    return m;
  }

  static matrix eye(size_t n = 1){
    matrix m = matrix::zeros(n,n);

    for(size_t r = 0; r < m.rows; r++)
      m(r,r,real_t(1));

    return m;
  }

  template<size_t rows, size_t cols, typename... Args>
  inline static matrix into(Args... rest){
    matrix m(rows, cols);
    into_aux(m, rest...);
    return m;
  }

  inline static size_t row_count(const matrix& m){
    return m.rows;
  }

  inline static size_t column_count(const matrix& m){
    return m.cols;
  }

  static real_t norm_euclidean(const matrix& m){
    real_t norm = real_t(0);

    for(size_t i = 0; i < m.data.size(); i++){
      norm += m.data[i] * m.data[i];
    }

    return real_t(sqrt((double)norm));
  }

  static matrix normalise(const matrix& m){
    real_t mag = matrix::norm_euclidean(m);
    matrix norm = matrix::zeros(m.rows,m.cols);

    if (mag == real_t(0))
      return norm;

    for(size_t i = 0; i < m.data.size(); i++)
      norm.data[i] = m.data[i] / mag;

    return norm;
  }
};

Literals

Math related string literals.

constexpr auto operator "" _MB( unsigned long long const x ) -> long {
  return 1024L * 1024L * (long)x;
}

constexpr auto operator "" _KB( unsigned long long const x ) -> long {
  return 1024L * (long)x;
}

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

Native Types

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

byte

byte is a collection of bits.

typedef uint8_t byte;

int24_ t

24 bit Little-endian integer type.

#pragma pack(push, 1)
class int24_t {
protected:
  byte word[3];
public:
  int24_t(){ }

  template<typename T>
  explicit int24_t( T const & val ) {
    *this   = (int32_t)val;
  }

  int24_t( const int24_t& val ) {
    *this   = val;
  }

  operator int32_t() const {
    if (word[2] & 0x80) { // negative? - then sign extend.
      return
        (int32_t)(((uint32_t)0xff    << 24) |
                  ((uint32_t)word[2] << 16) |
                  ((uint32_t)word[1] << 8)  |
                  ((uint32_t)word[0] << 0));
    }else{
      return
        (int32_t)(((uint32_t)word[2] << 16) |
                  ((uint32_t)word[1] << 8)  |
                  ((uint32_t)word[0] << 0));
    }
  }

  int24_t& operator =( const int24_t& input ) {
    word[0]   = input.word[0];
    word[1]   = input.word[1];
    word[2]   = input.word[2];

    return *this;
  }

  int24_t& operator =( const int32_t input ) {
    word[0]   = ((byte*)&input)[0];
    word[1]   = ((byte*)&input)[1];
    word[2]   = ((byte*)&input)[2];

    return *this;
  }

  int24_t operator +( const int24_t& val ) const {
    return int24_t( (int32_t)*this + (int32_t)val );
  }

  int24_t operator -( const int24_t& val ) const {
    return int24_t( (int32_t)*this - (int32_t)val );
  }

  int24_t operator *( const int24_t& val ) const {
    return int24_t( (int32_t)*this * (int32_t)val );
  }

  int24_t operator /( const int24_t& val ) const {
    return int24_t( (int32_t)*this / (int32_t)val );
  }

  int24_t& operator +=( const int24_t& val ) {
    *this   = *this + val;
    return *this;
  }

  int24_t& operator -=( const int24_t& val ) {
    *this   = *this - val;
    return *this;
  }

  int24_t& operator *=( const int24_t& val ) {
    *this   = *this * val;
    return *this;
  }

  int24_t& operator /=( const int24_t& val ) {
    *this   = *this / val;
    return *this;
  }

  int24_t operator -() {
    return int24_t( -(int32_t)*this );
  }

  bool operator ==( const int24_t& val ) const {
    return (int32_t)*this == (int32_t)val;
  }

  bool operator !=( const int24_t& val ) const {
    return (int32_t)*this != (int32_t)val;
  }

  bool operator >=( const int24_t& val ) const {
    return (int32_t)*this >= (int32_t)val;
  }

  bool operator <=( const int24_t& val ) const {
    return (int32_t)*this <= (int32_t)val;
  }

  bool operator >( const int24_t& val ) const {
    return (int32_t)*this > (int32_t)val;
  }

  bool operator <( const int24_t& val ) const {
    return (int32_t)*this < (int32_t)val;
  }
};
#pragma pack(pop)

array

array is a container that encapsulates fixed size arrays.

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

int main() {
  using namespace ferret;

  array<char> buffer(16);
  assert((buffer.size() == 16));

  array<char> str("abcde",5);
  assert((str[0] == 'a'));
  assert((str[1] == 'b'));
  assert((str[4] == 'e'));

  array<int> 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));

  // cppcheck-suppress useStlAlgorithm
  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;
}
template <typename T>
class array {
  size_t  _size{0};

public:

  T* data {nullptr};

  explicit inline array(size_t s = 0) : _size(s) {
    data = (T *)FERRET_ALLOCATOR::allocate(_size * sizeof(T));
  }

  explicit inline array(const T* source, size_t s = 0) : _size(s) {
    data = (T *)FERRET_ALLOCATOR::allocate(_size * sizeof(T));
    for(size_t i = 0; i < _size; i++)
      data[i] = source[i];
  }

#if defined(FERRET_STD_LIB)
  explicit inline array(std::initializer_list<T> source) :
    _size(source.size()) {
    data = (T *)FERRET_ALLOCATOR::allocate(_size * sizeof(T));
    size_t idx = 0;
    for(auto item : source){  
      data[idx] = item;
      idx++;
    }
  }
#endif

  inline array(array&& m) :
    data(m.data), _size(m.size()) { m.data = nullptr; }

  inline array(array& m) : _size(m.size()){
    for(size_t i = 0; i < _size; i++)
      data[i] = m.data[i];
  }

  ~array(){
    FERRET_ALLOCATOR::free(data);
  }


  inline array& operator=(array&& x){
    data = x.data;
    _size = x._size;
    x.data = nullptr;
    return *this;
  }

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

  inline T*      begin() const { return &data[0];      }
  inline T*      end()   const { return &data[_size];  }
  inline size_t  size()  const { return _size;         }
};

bitset

bitset represents a fixed-size sequence of N bits.

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

int main() {
  using namespace ferret;

  assert(FERRET_BITSET_USE_COMPILER_INTRINSICS == true);

  bitset<32> bs_a;
  assert(32 == bs_a.ffs(0));
  for(size_t i = 0; i < 2; i++)  bs_a.set(i);
  assert(0  == bs_a.ffs(0));
  assert(1  == bs_a.ffs(1));
  for(size_t i = 7; i < 16; i++) bs_a.set(i);
  assert(2  == bs_a.ffr(0));
  assert(5  == bs_a.ffr(5));
  assert(16 == bs_a.ffr(10));
  assert(32 == bs_a.ffs(31));

  bitset<64> bs_b;
  assert(0  == bs_b.ffr(0));
  assert(64 == bs_b.ffs(0));
  for(size_t i = 0; i < 8; i++)   bs_b.set(i);
  assert(0  == bs_b.ffs(0));
  assert(5  == bs_b.ffs(5));
  assert(8  == bs_b.ffr(5));
  for(size_t i = 16; i < 48; i++) bs_b.set(i);
  assert(16 == bs_b.ffs(8));
  assert(48 == bs_b.ffr(16));

  bitset<1024> bs_c;
  assert(0     == bs_c.ffr(0));
  assert(1024  == bs_c.ffs(0));
  for(size_t i = 0; i < 32; i++)  bs_c.set(i);
  assert(0     == bs_c.ffs(0));
  assert(32    == bs_c.ffr(0));
  for(size_t i = 256; i < 512; i++) bs_c.set(i);
  assert(256   == bs_c.ffs(256));
  assert(512   == bs_c.ffr(256));
  for(size_t i = 768; i < 1024; i++) bs_c.set(i);
  assert(1024  == bs_c.ffr(768));

  bitset<1024> bs_d;
  assert(0    == bs_d.ffr(0));
  bs_d.flip(0);
  assert(1    == bs_d.ffr(0));
  bs_d.flip(0);
  assert(0    == bs_d.ffr(0));

  assert(1024 == bs_d.ffs(0));
  bs_d.set(0, 1024);
  assert(0 == bs_d.ffs(0));
  bs_d.reset(0, 1024);
  assert(1024 == bs_d.ffs(0));
  bs_d.flip(0, 1024);
  assert(0 == bs_d.ffs(0));
  bs_d.flip(0, 1024);
  assert(1024 == bs_d.ffs(0));

  bs_d.set(256,512);
  bs_d.set(768,1024);

  assert(512  == bs_d.ffr(256));
  assert(256  == bs_d.ffs(256));
  assert(1024 == bs_d.ffr(768));
  assert(768  == bs_d.ffs(768));

  bs_d.reset(0,1024);
  for(size_t i = 0; i < 87; i++)  bs_d.set(i);
  for(size_t i = 90; i < 94; i++)  bs_d.set(i);
  for(size_t i = 106; i < 111; i++)  bs_d.set(i);
  for(size_t i = 136; i < 149; i++)  bs_d.set(i);

  assert(106 == bs_d.ffs(94,100));

  assert((15    == bitset<8,unsigned char>::bit_block(0,4)));
  assert((15    == bitset<32,unsigned int>::bit_block(0,4)));
  assert((60    == bitset<32,unsigned int>::bit_block(2,4)));
  assert((1024  == bitset<32,unsigned int>::bit_block(10,1)));
  assert((3072  == bitset<32,unsigned int>::bit_block(10,2)));
  assert((98304 == bitset<32,unsigned int>::bit_block(15,2)));
  assert((-1U   == bitset<32,unsigned int>::bit_block(0,60)));
  assert((-1U   == bitset<32,unsigned int>::bit_block(0,32)));

  return 0;
}
#undef bit

#if !defined(FERRET_BITSET_WORD_TYPE)
  #define FERRET_BITSET_WORD_TYPE unsigned int
  #if defined(__clang__) || defined(__GNUG__)
    #define FERRET_BITSET_USE_COMPILER_INTRINSICS true
  #endif
#endif

template<size_t S, typename word_t = FERRET_BITSET_WORD_TYPE>
class bitset {
  static const size_t bits_per_word = sizeof(word_t) * 8;
  static const size_t n_words = S / bits_per_word;

  static_assert((S % bits_per_word) == 0, "bitset size must be a multiple of word_t");

  word_t bits[n_words];

  inline size_t word (size_t i) const { return i / bits_per_word; }
  inline size_t bit  (size_t i) const { return i % bits_per_word; }

public:
  bitset() : bits{ word_t(0x00) } { }

  inline void set   (size_t b){
    bits[word(b)] = (word_t)(bits[word(b)] |  (word_t(1) << (bit(b))));
  }

  inline void set (size_t b, size_t e){
    size_t word_ptr = word(b);
    size_t n_bits = e - b;

    bits[word_ptr] = (word_t)(bits[word_ptr] | bit_block(bit(b), n_bits));

    n_bits -= bits_per_word - bit(b);
    word_ptr++;
    size_t last_word = (word(e) == n_words) ? n_words : word(e) + 1;
    for (; word_ptr < last_word; word_ptr++){
      bits[word_ptr] = (word_t)(bits[word_ptr] | bit_block(0, n_bits));
      n_bits -= bits_per_word;
    }
  }

  inline void reset (size_t b){
    bits[word(b)] = (word_t)(bits[word(b)] & ~(word_t(1) << (bit(b))));
  }

  inline void reset (size_t b, size_t e){
    size_t word_ptr = word(b);
    size_t n_bits = e - b;

    bits[word_ptr] = (word_t)(bits[word_ptr] & ~bit_block(bit(b), n_bits));

    n_bits -= bits_per_word - bit(b);
    word_ptr++;
    size_t last_word = (word(e) == n_words) ? n_words : word(e) + 1;
    for (; word_ptr < last_word; word_ptr++){
      bits[word_ptr] = (word_t)(bits[word_ptr] & ~bit_block(0, n_bits));
      n_bits -= bits_per_word;
    }
  }

  inline void flip (size_t b){
    bits[word(b)] = (word_t)(bits[word(b)] ^  (word_t(1) << (bit(b))));
  }

  inline void flip (size_t b, size_t e){
    size_t word_ptr = word(b);
    size_t n_bits = e - b;

    bits[word_ptr] = (word_t)(bits[word_ptr] ^ bit_block(bit(b), n_bits));

    n_bits -= bits_per_word - bit(b);
    word_ptr++;
    size_t last_word = (word(e) == n_words) ? n_words : word(e) + 1;
    for (; word_ptr < last_word; word_ptr++){
      bits[word_ptr] = (word_t)(bits[word_ptr] ^ bit_block(0, n_bits));
      n_bits -= bits_per_word;
    }
  }

  inline bool test  (size_t b) const {
    return (bits[word(b)] & (word_t(1) << (bit(b))));
  }

  inline size_t ffs(size_t b = 0, size_t e = S) const {
#if defined(FERRET_BITSET_USE_COMPILER_INTRINSICS)
      // search first word
      size_t word_ptr = word(b);
      word_t this_word = bits[word_ptr];

      // mask off bits below bound
      this_word &= (~static_cast<word_t>(0)) << bit(b);

      if (this_word != static_cast<word_t>(0))
        return ((word_ptr * bits_per_word) + (size_t) __builtin_ctz(this_word));

      // check subsequent words
      word_ptr++;
      size_t last_word = (word(e) == n_words) ? n_words : word(e) + 1;
      for (; word_ptr < last_word; word_ptr++){
        this_word = bits[word_ptr];
        if (this_word != static_cast<word_t>(0))
          return ((word_ptr * bits_per_word) + (size_t) __builtin_ctz(this_word));
      }
#else
      for(size_t i = b; i < e; i++)
        if (test(i))
          return i;
#endif
    return S;
  }

  inline size_t ffr(size_t b = 0, size_t e = S) const {
#if defined(FERRET_BITSET_USE_COMPILER_INTRINSICS)
      // same as ffs but complements word before counting
      size_t word_ptr = word(b);
      word_t this_word = ~bits[word_ptr];

      this_word &= (~static_cast<word_t>(0)) << bit(b);

      if (this_word != static_cast<word_t>(0))
        return ((word_ptr * bits_per_word) + (size_t) __builtin_ctz(this_word));

      word_ptr++;
      size_t last_word = (word(e) == n_words) ? n_words : word(e) + 1;
      for (; word_ptr < last_word; word_ptr++){
        this_word = ~bits[word_ptr];
        if (this_word != static_cast<word_t>(0))
          return ((word_ptr * bits_per_word) + (size_t) __builtin_ctz(this_word));
      }
#else
      for(size_t i = b; i < e; i++)
        if (!test(i))
          return i;
#endif
    return S;
  }

  // Return word with length-n bit block starting at bit p set.
  // Both p and n are effectively taken modulo bits_per_word.
  static inline word_t bit_block(size_t p, size_t n){
    if (n >= bits_per_word)
      return (word_t)(word_t(-1) << p);

    word_t x = (word_t)((word_t(1) << n) - word_t(1));
    return  (word_t)(x << p);
  }

#if defined(FERRET_STD_LIB)
  friend std::ostream& operator<< (std::ostream& stream, bitset& x) {
    for(size_t i = 0; i < S; i++)
      stream << x.test(i);
    return stream;
  }
#endif
};

mutex

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

#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

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
  #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(real_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 <>
    // cppcheck-suppress passedByValue
    void print(const real_t d){
      FERRET_HARDWARE_ARDUINO_UART_PORT.print(double(d), real_precision);
    }

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

Prints data to the output stream as human-readable ASCII text followed by a newline character (ASCII 10, or \n).

#if !defined(FERRET_DISABLE_STD_OUT)
   namespace runtime{
     template <typename T>
     void println(T t){
       print(t);
       print((char)0xA);
     }
   }
#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();
    rt::init();

   #if defined(FERRET_STD_LIB) && !defined(FERRET_DISABLE_CLI_ARGS)
    for (int i = argc - 1; i > -1 ; i--)
      _star_command_line_args_star_ =  rt::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();
    rt::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.0001       | 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.

(deftest inc-int-test
  (is (= 0 (inc-int)))
  (is (= 1 (inc-int))))

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);")
(deftest my-sort-test
  (is (= (list 3 2 1) (my-sort > (list 1 3 2))))
  (is (= (list 1 2 3) (my-sort < (list 1 3 2)))))
(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_o;")

(deftest my-find-test
  (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))))))

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 [^number_t t]
  (on "defined FERRET_STD_LIB"
      "auto duration = ::std::chrono::milliseconds(t);
       ::std::this_thread::sleep_for(duration);")
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::delay(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 = rt::list(obj<number>(1),obj<number>(2),obj<number>(3));

int sum = 0;
for_each(it, alist){
  sum += number::to<number_t>(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?

(deftest true?-test
  (is (= true  (true? true)))
  (is (= false (true? false))))
(defn true? [x]
  "if (x)
     return cached::true_o;
   return cached::false_o;")

false?

(deftest false?-test
  (is (= false (false? true)))
  (is (= true  (false? false))))
(defn false? [x]
  "if (!x)
     return cached::true_o;
   return cached::false_o;")

nil?

(deftest nil?-test
  (is (= false (= nil 1)))
  (is (= false (= 1 nil)))
  (is (= true  (= nil nil))))
(defn nil? [x]
  "if (x.is_nil())
       return cached::true_o;
   return cached::false_o;")

not

(defn not [x]
  "if (x)
     return cached::false_o;
   return cached::true_o;")

=

(deftest =-test
  (is (= true   (= true true)))
  (is (= false  (not (= true true))))
  (is (= false  (not 1)))
  (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))))
(defn = [& args]
  "var curr = rt::first(args);
   for_each(it, rt::rest(args)){
    if (curr != it)
      return cached::false_o;
    curr = it;
   }
   return cached::true_o;")

not=

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

identical?

Tests if 2 arguments are the same object.

(defn identical? [x y]
  "if(x.get() == y.get())
    return cached::true_o;
   return cached::false_o;")

<

(deftest <-test
  (is (= true  (< 2)))
  (is (= true  (< 2 3 4 5))))
(defn < [& args]
  "var a = rt::first(args);

   for_each(b, rt::rest(args)){
    if (number::to<real_t>(a) >= number::to<real_t>(b))
      return cached::false_o;
    a = b;
   }

   return cached::true_o;")

>

(deftest >-test
  (is (= true  (> 2)))
  (is (= false (> 2 3 4 5)))
  (is (= true  (> 6 5 4 3))))
(defn > [& args]
  "var a = rt::first(args);

   for_each(b, rt::rest(args)){
    if (number::to<real_t>(a) <= number::to<real_t>(b))
      return cached::false_o;
    a = b;
   }

   return cached::true_o;")

>=

(deftest >=-test
  (is (= true  (>= 2)))
  (is (= true  (>= 5 4 3 2 2 2)))
  (is (= false (>= 5 1 3 2 2 2))))
(defn >= [& args]
  "var a = rt::first(args);

   for_each(b, rt::rest(args)){
    if (number::to<real_t>(a) < number::to<real_t>(b))
      return cached::false_o;
    a = b;
   }

   return cached::true_o;")

<=

(deftest <=-test
  (is (= true  (<= 2)))
  (is (= true  (<= 2 2 3 4 5)))
  (is (= false (<= 2 2 1 3 4))))
(defn <= [& args]
  "var a = rt::first(args);

   for_each(b, rt::rest(args)){
    if (number::to<real_t>(a) > number::to<real_t>(b))
      return cached::false_o;
    a = b;
   }

   return cached::true_o;")

and

(deftest and-test
  (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)))))
(defmacro and
  ([] true)
  ([x] x)
  ([x & next]
   `(if ~x (and ~@next) false)))

or

(deftest or-test
  (is (= true  (or  true  (identity false))))
  (is (= false (or  false (identity false)))))
(defmacro or
  ([] nil)
  ([x] x)
  ([x & next]
   `(if ~x ~x (or ~@next))))

Flow

if

(deftest if-test
  (is (= 2     (if 1
                 2)))
  (is (= 1     (if (zero? 0)
                 1 -1)))
  (is (= -1    (if (zero? 1)
                 1 -1)))

  (is (= 2     (if nil
                 1 2))))

when

(deftest when-test
  (is (= 1     (when (< 2 3) 1)))
  (is (= 2     (when true    2))))
(defmacro when [test & body]
  `(if ~test (do ~@body)))

cond

(defn pos-neg-or-zero [n]
  (cond
    (< n 0) -1
    (> n 0)  1
    :else    0))

(deftest cond-test
  (is (= -1  (pos-neg-or-zero -5)))
  (is (=  1  (pos-neg-or-zero  5)))
  (is (=  0  (pos-neg-or-zero  0))))
(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

Repeatedly executes body while test is true. Presumes some side-effect will cause test to become false/nil. Returns nil.

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

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

while-let

Repeatedly executes body while test expression is true, evaluating the body with binding-form bound to the value of test.

(deftest while-let-test
  (let [lst (atom (list 1 2 3 4 5))
        acc (atom )]

    (while-let [item (first @lst)]
      (swap! lst rest)
      (swap! acc conj item))

    (is (= (list ) @lst))
    (is (= (list 5 4 3 2 1) @acc))))
(defn _while-let_ [pred fn]
  "var v;
   while((v = run(pred)))
     run(fn,v);")

(defmacro while-let
  [[form test] & body]
  `(_while-let_ (fn [] ~test) (fn [~form] ~@body)))

forever

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

if-let

(deftest if-let-test
  (is (= nil   (if-let [a nil] a)))
  (is (= 5     (if-let [a 5]   a)))
  (is (= 2     (if-let [[_ a]  (list 1 2)] a))))
(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.

(deftest when-let-test
  (is (= nil   (when-let [a nil] a)))
  (is (= 5     (when-let [a 5]   a)))
  (is (= 2     (when-let [[_ a]  (list 1 2)] a))))
(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_each(it, seq) run(f,it);")

dotimes

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

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

Sequential

list

Creates a new list. See also Spacial Forms.

(deftest list-test
  (is (= true  (= (list )       (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)))))
(defn list [& xs] "return xs;")

list?

Returns true if x implements Sequence.

(defn list? [x]
  "if (x.is_type(type_id<sequence>))
     return cached::true_o;
   return cached::false_o;")

seqable?

Return true if the x implements seekable_i.

(deftest seqable?-test
  (is (seqable? (list 1 2 3))))
(defn seqable? [coll]
  "if (rt::is_seqable(coll))
     return cached::true_o;
   return cached::false_o;")

cons

Returns a new seq where x is the first element and seq is the rest.

(deftest cons-test
  (is (= (list 1)           (cons 1 nil)))
  (is (= (list nil)         (cons nil nil)))

  (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))))))))
(defn cons [x seq] "return rt::cons(x, seq);")

first

Returns the first item in the collection.

(deftest first-test
  (is (= 1   (first (list 1 2 3 4))))
  (is (nil?  (first (rest (rest (list)))))))
(defn first [x]
  "return rt::first(x);")

second

Returns the first item in the collection.

(deftest second-test
  (is (= 2 (second (list 1 2 3 4)))))
(defn second [x]
  "return rt::first(rt::rest(x));")

rest

Returns a possibly empty seq of the items after the first.

(deftest rest-test
  (is (= (list 2 3 4)  (rest (list 1 2 3 4))))
  (is (= (list 3 4)    (rest (rest (list 1 2 3 4))))))
(defn rest [x] "return rt::rest(x);")

nth

Returns the value at the index.

(deftest nth-test
  (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))))
(defn nth [coll ^number_t index]
  "return rt::nth(coll,index);")

nthrest

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

(deftest nthrest-test
  (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))))
(defn nthrest [coll ^number_t n]
  "return rt::nthrest(coll,n);")

count

Returns the number of items in the collection. (count nil) returns

(deftest count-test
  (is (= 0  (count (list ))))
  (is (= 4  (count (list 1 2 3 4)))))
(defn count [s] "return obj<number>(rt::count(s))")

lazy-seq

(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 (= 0 (count (lazy-seq ))))
  (is (= (list 1 2)  (cons 1 (cons 2 (lazy-seq )))))

  (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)))))
(defn new-lazy-seq
  ([thunk]
   "return obj<lazy_sequence>(thunk);")
  ([data thunk]
   "return obj<lazy_sequence>(data, thunk);"))

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

(defn lazy-seq-cache [seq]
  "return lazy_sequence::from(seq);")

map

Returns a lazy sequence consisting of the result of applying f to the first item of the coll, followed by applying f to the second item in the coll, until the colls is exhausted.

(deftest map-test
  (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))))))
(defn map [f coll]
  (lazy-seq
   (if (seqable? coll)
     (cons (f (first coll))
           (map f (rest coll))))))

reduce

(deftest reduce-test
  (is (= 21               (reduce + (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)))))
(defn reduce
  ([f xs]
   (reduce f (first xs) (rest xs)))
  ([f acc coll]
   "__result = acc;
    for_each(i, coll)
     __result = run(f, __result, i);"))

range

(deftest range-test
  (is (= false (= (range 10) (range 15))))
  (is (= false (= (range 15) (range 10))))
  (is (= true  (= (range 10) (range 10))))

  (is (= 10  (apply + (range 5))))
  (is (= 5   (count   (range 5)))))
(defn range
  ([high]
   (range 0 high))
  ([^number_t low ^number_t high]
   "return rt::range(low, high)"))

take

(deftest take-test
  (is (= 2   (->> (map inc (list 1 2 3))
                  (take 2)
                  (first))))

  (is (= 3   (->> (map inc (list 1 2 3))
                  (take 20)
                  (count))))

  (is (= 3   (->> (map inc (list 1 2 3))
                  (take 2)
                  (rest)
                  (first))))

  (is (= 3   (->> (map inc (list 1 2 3))
                  (take 20)
                  (count))))


  (= (list 1 1 2 3 5) (take 5 (fib-seq)))
  (= 12               (apply + (take 5 (fib-seq)))))
(defn take [n coll]
  (lazy-seq
   (if (seqable? coll)
     (if (> n 0)
       (cons (first coll)
             (take (- n 1) (rest coll)))))))

take-while

(deftest take-while-test
  (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)))))
(defn take-while [pred s]
  (lazy-seq
   (if (and (seqable? s)
            (pred (first s)))
     (cons (first s) (take-while pred (rest s))))))

drop

Returns a lazy sequence of all but the first n items in coll.

(deftest drop-test
  (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)))))
(defn drop [^number_t n coll]
  "return rt::nthrest(coll, n);")

drop-while

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

(deftest drop-while-test
  (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)))))
(defn drop-while-aux [p c]
  "__result = c;
   while(run(p,__result))
     __result = rt::rest(__result);")

(defn drop-while [pred coll]
  (lazy-seq
   (drop-while-aux #(and (seqable? %) (pred (first %))) coll)))

concat

(deftest concat-test
  (let [a-list (concat (list 1 2 3) (list 4 5 6))
        b-list (concat (list 1 2 3) (list 4 5 6) (list 7 8 9))]

    (is (= 0      (count (concat ))))
    (is (= 1      (first a-list)))
    (is (= 4      (first (drop 3 a-list))))
    (is (= 21     (reduce + a-list)))
    (is (= b-list (list 1 2 3 4 5 6 7 8 9)))))
(defn concat
  ([]
   (list))
  ([x]
   (if (seqable? x)
     (cons (first x) (lazy-seq (concat (rest x))))))
  ([x y]
   (if (seqable? x)
     (cons (first x) (lazy-seq (concat (rest x) y)))
     (concat y)))
  ([x y & more]
   (concat (concat x y) (apply concat more))))

apply

Applies fn f to the argument list formed by prepending intervening arguments to argv.

(deftest apply-test
  (is (= 21 (apply +       (list 1 2 3 4 5 6))))
  (is (= 9  (apply + 1 2   (list 1 2 3))))
  (is (= 12 (apply + 1 2 3 (list 1 2 3)))))
(defn apply [f & argv]
  "return rt::apply(f,argv);")

conj

(deftest conj-test
  (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))))
(defn conj [coll & xs]
  (reduce (fn[h v] (cons v h)) (if (nil? coll) (list) coll) xs))

reverse

(deftest reverse-test
  (is (= (list 6 5 4 3 2 1) (reverse (list 1 2 3 4 5 6)))))
(defn reverse [s]
  (reduce (fn[h v] (cons v h)) (list) s))

filter

Returns a lazy sequence of the items in coll for which (pred item) returns logical true.

(deftest filter-test
  (is (= 1  (->> (list false false true)
                 (filter true?)
                 (count ))))

  (is (= 2  (->> (list true false true false false)
                 (filter true?)
                 (count ))))

  (is (= 2  (->> (list true false true false)
                 (filter true?)
                 (count ))))

  (is (= 2  (->> (list true false true false)
                 (filter false?)
                 (count ))))

  (is (= 3  (->> (list true false true false false)
                 (filter false?)
                 (count ))))

  (is (= 2  (->> (list true false true false false)
                 (filter (fn [x] (not (false? x))))
                 (count ))))

  (is (= 0  (->> (list false false)
                 (filter true?)
                 (count)))))
(defn filter [pred coll]
  (lazy-seq
   (if (seqable? coll)
     (let [[f & r] coll]
       (if (pred f)
         (cons f (filter pred r))
         (filter pred r))))))

repeatedly

(deftest repeatedly-test
  (is (= 1 (first (repeatedly 3 (fn [] 1)))))
  (is (= 3 (count (repeatedly 3 (fn [] 1)))))

  (is (= 3 (count (lazy-seq-cache (repeatedly 3 (fn [] 1))))))

  (is (= 2 (->> (repeatedly 3 (fn [] 1))
                (map inc)
                first)))

  (is (= 2 (->> (repeatedly (fn [] 1))
                (take 3)
                (map inc)
                reverse
                first)))

  (let [xs (lazy-seq-cache (repeatedly #(rand)))]
    (is (= (take 5 xs) (take 5 xs)))))
(defn repeatedly
  ([f]   (lazy-seq (cons (f) (repeatedly f))))
  ([n f] (take n (repeatedly f))))

partition

(deftest partition-test
  (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)))))
(defn partition
  ([n coll]
   (partition n n coll))
  ([n step coll]
   (lazy-seq
    (if (seqable? 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 (seqable? 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.

(deftest every?-test
  (is (= false (every? false? (list true false))))
  (is (= true  (every? false? (list false false)))))
(defn every? [pred coll]
  "for_each(i, coll){
     if (!run(pred, i))
      return cached::false_o;
   }
   return cached::true_o;")

interleave

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

(deftest interleave-test
  (is (= (list 1 3 2 4) (interleave (list 1 2) (list 3 4))))
  (is (= (list 1 3)     (interleave (list 1 2) (list 3)))))
(defn interleave
  ([s1 s2]
   (lazy-seq
    (when (and (seqable? s1)
               (seqable? s2))
      (cons (first s1) (cons (first s2)
                             (interleave (rest s1) (rest s2))))))))

flatten

Takes any nested combination of sequential things and returns their contents as a single, flat sequence. (flatten nil) returns an empty sequence.

(deftest flatten-test
  (is (= (list 1 2 3 4 5) (flatten (list 1 2 (list 3) 4 5)))))
(defn flatten [s]
  (lazy-seq
   (if (seqable? s)
     (if (seqable? (first s))
       (concat (flatten (first s)) (flatten (rest s)))
       (cons (first s) (flatten (rest s)))))))

Math

(deftest number-test
  (is (= 0.5       1/2))
  (is (= 0.33333   1/3))
  (is (= 3501      0xDAD))
  (is (= 2748      0xABC)))

zero?

(deftest zero?-test
  (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)))))
(defn zero? [x]
  (= x 0))

pos?

(deftest pos?-test
  (is (= true  (pos? 1)))
  (is (= true  (pos? 0.2)))
  (is (= false (pos? 0))))
(defn pos? [x]
  (> x 0))

neg?

(deftest neg?-test
  (is (= false (neg? 1)))
  (is (= true  (neg? -1))))
(defn neg? [x]
  (< x 0))

+

Returns the sum of nums. (+ ) returns 0.

(deftest add-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))))
(defn + [& args]
  "real_t value(0.0);

   for_each(i, args)
    value = value + number::to<real_t>(i);

   __result = obj<number>(value);")

-

Subtracts nums and returns the result.

(deftest sub-test
  (is (= -1         (- 1)))
  (is (= 0          (- 4 2 2)))
  (is (= 0          (- 4 2 2.0))))
(defn - [& args]
  "__result = rt::first(args);
   real_t value = number::to<real_t>(__result);
   size_t count = 1;

   for_each(i, rt::rest(args)){
    value = (value - number::to<real_t>(i));
    count++;
   }

   if (count == 1)
    value = value * real_t(-1.0);

   __result = obj<number>(value);")

*

Returns the product of nums. (* ) returns 1.

(deftest mul-test
  (is (= 1          (* )))
  (is (= 8          (* 2 2 2)))
  (is (= 8          (* 2.0 2 2))))
(defn * [& args]
  "real_t value(1.0);

   for_each(i, args)
    value = (value * number::to<real_t>(i));

   __result = obj<number>(value);")

/

If no denominators are supplied, returns 1 / numerator, else returns numerator divided by all of the denominators.

(deftest div-test
  (is (= 1          (/ 1)))
  (is (= 0.5        (/ 2)))
  (is (= 1          (/ 4 2 2)))
  (is (= 1          (/ 4 2 2.0))))
(defn / [& args]
  "__result = rt::first(args);
   real_t value = number::to<real_t>(__result);
   size_t count = 1;

   for_each(i, rt::rest(args)){
    value = (value / number::to<real_t>(i));
    count++;
   }

   if (count == 1)
    value = real_t(1.0) / value;

   __result = obj<number>(value);")

inc

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

dec

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

min / max

(deftest min-max-test
  (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))))

Returns the least of the nums.

(defn min [& args]
  "__result = rt::first(args);
   for_each(i, rt::rest(args))
    if (number::to<real_t>(__result) > number::to<real_t>(i))
     __result = i;")

Returns the greatest of the nums.

(defn max [& args]
  "__result = rt::first(args);
   for_each(i, rt::rest(args))
    if (number::to<real_t>(__result) < number::to<real_t>(i))
     __result = i;")

rem

(defn rem [^number_t num ^number_t div]
  "return obj<number>((num % div));")

mod

(deftest mod-test
  (is (= 0          (mod 2 2)))
  (is (= 0          (mod 4 2)))
  (is (= 1          (mod 5 2)))
  (is (= 1          (mod 8 7))))
(defn mod [num div] 
  (let [m (rem num div)] 
    (if (or (zero? m) (= (pos? num) (pos? div)))
      m 
      (+ m div))))

floor

(deftest floor-test
  (is (= 1          (floor 1.1)))
  (is (= 1          (floor 1.5)))
  (is (= 1          (floor 1.9))))
(defn floor [^number_t x] "return obj<number>(x);")

interp

One-dimensional linear interpolation.

(deftest interp-test
  (is (= 100  (interp 10 0 10 0 100)))
  (is (=  80  (interp  8 0 10 0 100)))
  (is (=  70  (interp  7 0 10 0 100)))
  (is (=  50  (interp  5 0 10 0 100)))
  (is (=  20  (interp  2 0 10 0 100)))
  (is (=   0  (interp  0 0 10 0 100))))
(defn interp [^real_t x
              ^real_t in-min ^real_t in-max
              ^real_t out-min ^real_t out-max]
  "return obj<number>((x - in_min) * (out_max - out_min) / (in_max - in_min) + out_min);")

clip

Clip (limit) the values in number.

(deftest clip-test
  (is (=   5 (clip   10   0  5)))
  (is (=  10 (clip   10   0 20)))
  (is (=   0 (clip   10 -10  0)))
  (is (= -10 (clip -100 -10  0))))
(defn clip [^number_t x ^number_t min ^number_t max]
  "return obj<number>(rt::max(rt::min(max, x), min));")

bit-and

(deftest bit-and-test
  (is (= 0          (bit-and  4 3)))
  (is (= 0          (bit-and  0 1))))
(defn bit-and [^number_t x ^number_t y] "return obj<number>((x & y));")

bit-not

(deftest bit-not-test
  (is (= -5         (bit-not  4)))
  (is (= -1         (bit-not  0))))
(defn bit-not [^number_t x] "return obj<number>(~x);")

bit-or

(deftest bit-or-test
  (is (= 7          (bit-or   4 3)))
  (is (= 1          (bit-or   0 1))))
(defn bit-or [^number_t x ^number_t y] "return obj<number>((x | y ));")

bit-xor

(deftest bit-xor-test
  (is (= 0          (bit-xor  4 4)))
  (is (= 1          (bit-xor  1 0))))
(defn bit-xor [^number_t x ^number_t y] "return obj<number>((x ^ y ));")

bit-shift-left

(deftest bit-shift-left-test
  (is (= 8          (bit-shift-left 4 1)))
  (is (= 16         (bit-shift-left 4 2))))
(defn bit-shift-left [^number_t x ^number_t n] "return obj<number>((x << n ));")

bit-shift-right

(deftest bit-shift-right-test
  (is (= 2          (bit-shift-right 4 1)))
  (is (= 1          (bit-shift-right 4 2))))
(defn bit-shift-right [^number_t x ^number_t n] "return obj<number>((x >> n ));")

bit-extract

From x extract k bits starting from position p.

(deftest bit-extract-test
  (is (= 1          (bit-extract 1781 0 2)))
  (is (= 2          (bit-extract 1781 1 2)))
  (is (= 245        (bit-extract 1781 0 8)))
  (is (= 15         (bit-extract 1781 4 4)))
  (is (= 111        (bit-extract 1781 4 8)))
  (is (= 20         (bit-extract 500  0 5)))
  (is (= 15         (bit-extract 500  5 6))))
(defn bit-extract [^number_t x ^number_t p ^number_t k]
  "__result = obj<number>((x >> p) & ((1 << k) - 1));")

bit-override

Override len bits in dst starting from pos using bits from src.

(deftest bit-override-test
  (is (= 0xAC3A     (bit-override 0xAAAA 0x0C30 4 8)))
  (is (= 0xBBCC     (bit-override 0xBBBB 0xAACC 0 8)))
  (is (= 0xBACB     (bit-override 0xBBBB 0xAACC 4 8)))
  (is (= 0xBBBB     (bit-override 0xAAAA 0xBBBB 0 16))))
(defn bit-override [^number_t dst ^number_t src ^number_t pos ^number_t len]
  "number_t mask = (((number_t)1 << len) - 1) << pos;
   number_t num = (dst & ~mask) | (src & mask);
   return obj<number>(num);")

encode/decode-int16

(deftest encode-decode-int16-test
  (is (= 0          (decode-int16 (encode-int16 0))))
  (is (= 512        (decode-int16 (encode-int16 512))))
  (is (= 1024       (decode-int16 (encode-int16 1024))))
  (is (= 2048       (decode-int16 (encode-int16 2048))))
  (is (= 32000      (decode-int16 (encode-int16 32000)))))

Split a number into bytes.

(defn encode-int16 [n] 
  "int16_t val = number::to<int16_t>(n);
   byte *p = (byte*)&val;
   for (int i = (sizeof(int16_t) -1); i >= 0; i--)
     __result = rt::cons(obj<number>((number_t)p[i]),__result);")

Combine a list of bytes to a number.

(defn decode-int16 [s]
  "int16_t val = 0;
   byte *p = (byte*)&val; 

   size_t index = 0;
   for_each(i, s){
     p[index] = number::to<byte>(i);
     index++;
   }

   return obj<number>(val);")

encode/decode-float

(deftest encode-decode-float-test
  (is (= 0          (decode-float (encode-float 0))))
  (is (= 512        (decode-float (encode-float 512))))
  (is (= 1024       (decode-float (encode-float 1024))))
  (is (= 2048       (decode-float (encode-float 2048))))
  (is (= 32000      (decode-float (encode-float 32000))))
  (is (= 512        (decode-float (list 0 0 0 68 42)))))
(defn encode-float [n] 
  "static_assert(sizeof(float) == 4 * sizeof(byte), \"\");
   float val = number::to<float>(n);
   byte *p = (byte*)&val;
   for (int i = (sizeof(float) -1); i >= 0; i--)
     __result = rt::cons(obj<number>(p[i]),__result);")

Combine a list of bytes to a number.

(defn decode-float [s]
  "union {
    float f;
    byte b[4];
   } u;
   static_assert(sizeof(float) == 4 * sizeof(byte), \"\");

   size_t index = 0;
   for_each(i, s){
     if (index > 3)
      break;
     u.b[index] = number::to<byte>(i);
     index++;
   }

   return obj<number>(u.f);")

sqrt

Square root.

(deftest sqrt-test
  (is (= 32         (sqrt 1024)))
  (is (= 2          (sqrt 4))))
(defn sqrt [^real_t s]
  "return obj<number>(::sqrt(s));")

pow

Returns base raised to the power exponent:

(deftest pow-test
  (is (= 8          (pow 2 3)))
  (is (= 16         (pow 2 4))))
(defn pow [^real_t b ^real_t e]
  "return obj<number>(::pow(b, e));")

cos

Returns the cosine of an angle of x radians.

(deftest cos-test
  (is (= 1          (cos 0)))
  (is (= -0.99999   (cos 3.145))))
(defn cos [^real_t s]
  "return obj<number>(::cos(s));")

sin

Returns the sine of an angle of x radians.

(deftest sin-test
  (is (= 0          (sin 0)))
  (is (= -0.00340   (sin 3.145))))
(defn sin [^real_t s]
  "return obj<number>(::sin(s));")

asin

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

(defn asin [^real_t x]
  "return obj<number>(::asin(x));")

atan2

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

(deftest aton2-test
  (is (= 0.98279    (atan2 45 30))))
(defn atan2 [^real_t x ^real_t y]
  "return obj<number>(::atan2(x,y));")

log / log10

(deftest log-test
  (is (= 2.30258    (log 10)))
  (is (= 2          (log10 100))))

Returns the natural logarithm of x.

(defn log [^real_t x]
  "return obj<number>(::log(x));")

Returns the natural logarithm of x.

(defn log10 [^real_t x]
  "return obj<number>(::log10(x));")

to-degrees/radians

(deftest to-degrees-radians-test
  (is (= 180.19522  (to-degrees 3.145)))
  (is (= 3.14159    (to-radians 180))))

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

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

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

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

rand

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

(deftest random-test
  (is (= true       (not (nil? (rand)))))
  (is (= true       (not (nil? (rand 15))))))
(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)))

Matrices

(require '[ferret.matrix :as m])

(def pi 3.1415)

(defn rot [turns]
  (let [a (* 2 pi turns)]
    (matrix
     [[   (cos a)  (sin a)]
      [(- (sin a)) (cos a)]])))

(->> (matrix [[3] [4]])
     (m/mmul (rot 1/8))
     (m/seq))

(assert (= (->> (matrix [[3] [4]])
                (m/mmul (rot 1/8))
                (m/seq))
           (list 4.9497 0.7072)))

row-count

Returns the number of rows in a matrix.

(defn row-count [^matrix u]
  "return obj<number>(matrix::row_count(u));")

column-count

Returns the number of columns in a matrix.

(defn column-count [^matrix u]
  "return obj<number>(matrix::column_count(u));")

zeros

Constructs a new zero-filled numerical matrix with the given dimensions.

(defn zeros [^size_t r, ^size_t c]
  "return obj<matrix_t>(matrix::zeros(r, c));")

ones

Constructs a new zero-filled numerical matrix with the given dimensions.

(defn ones [^size_t r, ^size_t c]
  "return obj<matrix_t>(matrix::ones(r,c));")

full

Fills a matrix with a single scalar value.

(defn full [^size_t r, ^size_t c, ^real_t v]
  "return obj<matrix_t>(matrix::ones(r,c,v));")

eye

Identity matrix. Returns an n-by-n identity matrix with ones on the main diagonal and zeros elsewhere.

(defn eye [^size_t n]
  "return obj<matrix_t>(matrix::eye(n));")

add

Performs element-wise addition on matrices.

(defn add [^matrix u ^matrix v]
  "return obj<matrix_t>(u + v);")

sub

Performs element-wise subtraction on matrices.

(defn sub [^matrix u ^matrix v]
  "return obj<matrix_t>(u - v);")

mul

Performs element-wise multipication with scalar on matrices.

(defn mul [^matrix u ^real_t s]
  "return obj<matrix_t>(u * s);")

mmul

Performs matrix multiplication on matrices.

(defn mmul [^matrix u ^matrix v]
  "return obj<matrix_t>(u * v);")

equals

Returns true if both matrices are numerically equal.

(defn equals [^matrix u ^matrix v]
  "if (u == v)
       return cached::true_o;
   else
       return cached::false_o;")

normalise

Normalises a matrix (scales to unit length). Returns a new normalised matrix.

(defn normalise [^matrix u]
  "return obj<matrix_t>(matrix::normalise(u));")

norm

Calcualtes the Euclidean norm of matrix.

(defn norm [^matrix u]
  "return obj<number>(matrix::norm_euclidean(u));")

mset!

Mutates a scalar value in a matrix at the specified position.

(defn mset! [^matrix u ^size_t r ^size_t c ^real_t v]
  "u(r, c, v);")

mget

Gets a scalar value from a matrix at the specified position.

(defn mget [^matrix u ^size_t r ^size_t c]
  "return obj<number>(u(r, c));")

cout

Pretty-prints a matrix to std::cout.

(defn cout [^matrix u]
  "std::cout << u;")

seq

Converts matrix to a lazy-seq.

(defn seq [u]
  "return obj<array_seq<real_t, number>>(u);")

Timing

millis

Return current time in milliseconds,

(deftest millis-test
  (let [now (millis)]
    (sleep 150)
    (is (>= (- (millis) now) 100))))
(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 [^number_t t]
  (on "defined FERRET_STD_LIB"
      "auto duration = ::std::chrono::microseconds(t);
       ::std::this_thread::sleep_for(duration);")
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::delayMicroseconds(t);"))

elapsed-micros

Port of Teensy elapsedMicros API,

(defobject elapsed_micros "elapsed_micros_o.h")

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

(defn elapsed-micros? [t ^real_t n]
  "if (t.cast<elapsed_micros>()->is_elapsed(n))
     return cached::true_o;
   return cached::false_o;")

(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 {
  mutex lock;
  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

 public:

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

  void reset() {
    lock_guard guard(lock);
    us = now();
  }

  type_t type() const { return type_id<elapsed_micros>; }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const {
    rt::print("micros#");
    rt::print(elapsed());
  }
#endif

  inline real_t elapsed() const { return (real_t)(now() - us); }
  inline bool is_elapsed(real_t t) const { return (elapsed() >= t); }
};
#endif

benchmark

Benchmark a function. Run function f n times and print execution statistics.

(benchmark #(reduce + (range 1000)) 10000)
(defn benchmark
  ([f]
   (benchmark f 100))
  ([f ^number_t n]
   "elapsed_micros timer;

    run(f);
    real_t elapsed = timer.elapsed() / real_t(1000.0);

    real_t min = elapsed;
    real_t max = elapsed;
    real_t sum = real_t(0.0);
    real_t sum_sq = real_t(0.0);

    for(number_t i =0; i < n; i++){
      timer.reset();
      run(f);
      real_t elapsed = timer.elapsed() / real_t(1000.0);

      #if defined(FERRET_BENCHMARK_VERBOSE)
         rt::println(elapsed);
      #endif

      sum += elapsed;
      sum_sq += (elapsed * elapsed);
      if (elapsed < min)
        min = elapsed;
      if (elapsed > max)
        max = elapsed;
      }

      real_t mean = (real_t)(sum / n);
      real_t stdev = (real_t)sqrt((sum_sq / n) - (mean * mean));

      rt::print(\"\\t mean: \");
      rt::println(mean);

      rt::print(\"\\tstdev: \");
      rt::println(stdev);

      rt::print(\"\\t  min: \");
      rt::println(min);

      rt::print(\"\\t  max: \");
      rt::println(max);

      rt::print(\"\\trange: \");
      rt::println((max - min));"))

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 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))))
(defobject fn_throttler_o "fn_throttler_o.h")

(defn new-fn-throttler [f ^real_t rate ^bolean block]
  "return obj<fn_throttler>(f, rate, block);")

(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)]
    `(new-fn-throttler ~f ~rate ~(= policy :blocking))))
#if !defined(FERRET_SAFE_MODE)
class fn_throttler : public lambda_i {
  var fn;
  elapsed_micros timer;
  real_t rate;
  bool blocking;

#if defined(FERRET_HARDWARE_ARDUINO)
  inline void _wait(real_t t) const{
    ::delayMicroseconds((number_t)t);
  }
#elif defined(FERRET_STD_LIB)
  inline void _wait(real_t t) const{
    auto duration = ::std::chrono::microseconds((number_t)t);
    ::std::this_thread::sleep_for(duration);
  }
#endif

  var exec(ref args){
    if (blocking)
      _wait(rate - timer.elapsed());

    if (timer.is_elapsed(rate)){
      timer.reset();
      return rt::apply(fn, args);
    }

    return nil();
  }

public:

  explicit fn_throttler(var f, real_t r, bool b) : fn(f), rate(r), blocking (b) { }

  var invoke(ref args) const final {
    return var((object*)this).cast<fn_throttler>()->exec(args);
  }
};
#endif

String

string?

Return true if s is a string.

(defn string? [s]
  "if (s.is_type(type_id<string>))
     return cached::true_o;
   return cached::false_o;")

ston

Parses the Ferret string str, interpreting its content as a number and returns its value as a Ferret number.

(deftest ston-test
  (is (=  1234.1234 (ston  "1234.1234")))
  (is (= -1234.1234 (ston "-1234.1234")))
  (is (=  1234.1234 (ston  "1 2 3 4. 1 2 3 4 "))))
(defn ston [str]
  "var seq = str;
   real_t factor = 1;
   real_t value = 0;

   if (number::to<byte>(rt::first(seq)) == '-'){
     seq = rt::rest(seq);
     factor = -1;
   }

   bool point_passed = false;
   for_each(i, seq){
     byte ch = number::to<byte>(i);

     if (ch == '.'){
       point_passed = true;
       continue;
     }

     number_t d = ch - '0';
     if (d >= 0 && d <= 9){
       if (point_passed)
         factor /= real_t(10.0);
       value = value * real_t(10.0) + real_t(d);
     }
   }

   return obj<number>(value * factor);")

ntos

Converts a Ferret number to a Ferret string,

(deftest ntos-test
  (is (=  (ntos -12.34)      (new-string "-12.3400")))
  (is (=  (ntos  12.001)     (new-string "12.0010")))
  (is (=  (ntos  154.132341) (new-string "154.1323"))))
(defn ntos [^real_t f]
  "number_t n = (number_t)f;
   number_t sign;

   if ((sign = n) < 0){
      n = -n;
      f = -f;
   }

   var s;

   f = (f - n) + 10;
   for (int i = real_precision; i >= 1; i--){
      number_t ch = ((number_t)(f * ::pow(10, i)) % 10) + '0';
      s = rt::cons(obj<number>(ch), s);
   }

   s = rt::cons(obj<number>('.'), s);

   do {
     s = rt::cons(obj<number>(n % 10 + '0'), s);
    } while ((n /= 10) > 0);

   if (sign < 0)
     s = rt::cons(obj<number>('-'), s);

   return obj<string>(s);")

str-tok

Returns a lazy-seq of tokens in str separated by delimeter.

(assert (= (str-tok "- This, a sample string." " ,.-")
           (list "This" "a" "sample" "string")))
(defnative str-tok [str delimeter]
  (on "defined FERRET_RUNTIME_H"
      ("string.h")
      "var packed_delimeter = string::pack(delimeter);
       var packed_str = string::pack(str);

       class seq : public lambda_i {
         var s;
         var d;
       public:
         explicit seq(ref str = nil(), ref del = nil()) : s(str), d(del) { }
         var invoke(ref) const final {
           char* token = strtok(NULL, string::c_str(d));
           if (token != nullptr)
             return obj<lazy_sequence>(obj<string>(token),obj<seq>(s, d));
           return nil();
         }
       };

       char* token = strtok(string::c_str(packed_str), 
                            string::c_str(packed_delimeter)); 

       if (token != nullptr)
         return obj<lazy_sequence>(obj<string>(token),
                                   obj<seq>(packed_str, packed_delimeter));

       return nil();"))

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

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

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.

(require '[ferret.matrix :as m])

(deftest doto-test
    (let [mat (m/zeros 2 2)]
      (doto mat
        (m/mset! 0 0 1)
        (m/mset! 0 1 1)
        (m/mset! 1 0 1)
        (m/mset! 1 1 1))
      (is (= (list 1 1 1 1) (m/seq mat)))))
(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)))

comment

Ignores body, yields nil.

(defmacro comment
  [& body])

I/O

print

Prints the object(s) to STD_OUT.

(defnative print [& more]
  (on "!defined(FERRET_DISABLE_STD_OUT)"
      "if (more.is_nil())
         return nil();
       ref f = rt::first(more);
       f.stream_console();
       ref r = rt::rest(more);
       for_each(it, r){
        rt::print(' ');
        it.stream_console();
       }
       return nil();"))

println

Same as print followed by (newline).

(defn println [& more]
  (apply print more)
  (cxx "rt::print((char)0xA);"))

get-char

read-line

Reads the next line from default I/O stream.

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

slurp

(defnative slurp [^c_str f]
  (on "defined FERRET_STD_LIB"
      ("fstream")
      "std::ifstream ifs(f, 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);

       var data = obj<array_seq<byte, number>>(size_t(file_size));
       var storage = (data.cast<array_seq<byte, number>>()->storage);
       auto& arr = value<array<byte>>::to_reference(storage).data;

       ifs.read((char*)arr, file_size);

       return obj<string>(data);"))

sh

(defnative sh [^c_str cmd]
  (on "defined FERRET_STD_LIB"
      ("memory")
      "::std::shared_ptr<FILE> pipe(popen(cmd, \"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 "Machine Types")
  (println "\t*void:\t\t\t" (cxx "return obj<number>(sizeof(void*));"))
  (println "\treal_t:\t\t\t" (cxx "return obj<number>(sizeof(real_t));"))
  (println "\tnumber_t:\t\t" (cxx "return obj<number>(sizeof(number_t));"))
  (println "Object Types")
  (println "\tvar:\t\t\t" (cxx "return obj<number>(sizeof(var));"))
  (println "\tobject:\t\t\t" (cxx "return obj<number>(sizeof(object));"))
  (println "\tnumber:\t\t\t" (cxx "return obj<number>(sizeof(number));"))
  (println "\tkeyword:\t\t" (cxx "return obj<number>(sizeof(keyword));"))
  (println "\tboolean:\t\t" (cxx "return obj<number>(sizeof(boolean));"))
  (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 "\tatom:\t\t\t" (cxx "return obj<number>(sizeof(atomic));"))
  (println "\td_list:\t\t\t" (cxx "return obj<number>(sizeof(d_list));"))
  (println "\tpointer:\t\t" (cxx "return obj<number>(sizeof(pointer));"))
  (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>));"))
  (println "\tdelayed:\t\t" (cxx "return obj<number>(sizeof(delayed));"))
  (println "\tstring:\t\t\t" (cxx "return obj<number>(sizeof(string));"))
  (println "Interface Types")
  (println "\tseekable_i:\t\t" (cxx "return obj<number>(sizeof(seekable_i));"))
  (println "\tlambda_i:\t\t" (cxx "return obj<number>(sizeof(lambda_i));"))
  (println "\tderef_i:\t\t" (cxx "return obj<number>(sizeof(deref_i));")))

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 []
  "::exit(0);")

system-abort

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

system-halt

(defn system-halt [code]
  (forever (sleep 1000)))

file

ferret.io.file includes functions for creating and manipulating files in a portable manner.

(require '[ferret.io.file :as f])

(assert (true?  (f/exists "project.clj")))
(assert (false? (f/exists "dummy_file.clj")))

(assert (true?  (f/mkdir "src/dummy_directory")))
(assert (true?  (seqable? (f/seq "src/dummy_directory"))))
(assert (false? (f/mkdir "src")))

(assert (= (list ) (f/open-dir "src/dummy_directory")))
(assert (nil?      (f/open-dir "project.clj")))


(assert (true?  (f/rmdir "src/dummy_directory")))
(defnative open-dir [^c_str directory]
  (on "defined FERRET_STD_LIB"
      ("dirent.h"
       "string.h")
      "DIR *d;
       struct dirent *dir;
       d = opendir(directory);
       if (d) {
         __result = rt::list();
         while ((dir = readdir(d)) != NULL) {
           if (!strcmp(dir->d_name, \".\") || !strcmp(dir->d_name, \"..\")){
             continue;
           }
           __result = rt::cons(obj<string>(dir->d_name), __result);
         }
         closedir(d);
        }
       return __result;"))

(defnative mkdir [^c_str dir]
  (on "defined FERRET_STD_LIB"
      ("sys/stat.h"
       "sys/types.h")
      "int result = mkdir(dir, 0755);
       if (result == 0)
         return cached::true_o;
       return cached::false_o;"))

(defnative rmdir [^c_str dir]
  (on "defined FERRET_STD_LIB"
      ("unistd.h")
      "int result = rmdir(dir);
       if (result == 0)
         return cached::true_o;
       return cached::false_o;"))

(defnative exists [^c_str file]
  (on "defined FERRET_STD_LIB"
      ("unistd.h")
      "if (access( file, F_OK ) != -1)
        return cached::true_o;
       return cached::false_o;"))

(defnative remove [^c_str file]
  (on "defined FERRET_STD_LIB"
      "int result = remove(file);
       if (result == 0)
         return cached::true_o;
       return cached::false_o;"))

(defn seq-flat [s]
  (lazy-seq
   (if (seqable? s)
     (let [[head & tail] s]
       (if (not (string? head))
         (concat (seq-flat head) (seq-flat tail))
         (cons head (seq-flat tail)))))))

(defn seq-walk [dir]
  (map (fn [f]
         (let [file (new-string dir "/" f)]
           (if (open-dir file)
             (new-lazy-seq file #(seq-walk file))
             file)))
       (open-dir dir)))

(defn seq [dir]
  (seq-flat
   (seq-walk dir)))

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.io.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 "io/net/multicast_o.h")

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

(defn pending? [con]
  "if (con.cast<multicast_socket>()->have_pending_data())
     return cached::true_o;
   return cached::false_o;")

(defn send [con data]
  "datagram_t buffer(max_data_gram_size);
   size_t idx = 0; 

   for_each(b, data)
    buffer[idx++] = (byte)number::to<number_t>(b);

   if (con.cast<multicast_socket>()->send(buffer,idx))
      return cached::true_o;
    return cached::false_o;")

(defn byte [data ^size_t curr]
  "datagram_t& buffer = value<datagram_t>::to_reference(data);
   return obj<number>(buffer[curr]);")

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

(defn read [conn]
  "return conn.cast<multicast_socket>()->recv();")

(defn recv [conn]
  (data-seq (read conn)))
const size_t max_data_gram_size = 65507;
typedef ferret::array<ferret::byte> datagram_t;

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

  class udp{
    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, datagram_t & recv_buf);

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

  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, datagram_t & recv_buf){
    src.addr_len = sizeof(src.addr);
    ssize_t len = recvfrom(fd, recv_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;
  }
}

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

public:

  type_t type() const final { return type_id<multicast_socket>; }

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const final {
    rt::print("multicast_socket<");
    rt::print(ip);
    rt::print(' ');
    rt::print(port);
    rt::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, size_t size) {
    lock_guard guard(lock);
    multicast_aux::address dest_addr(ip.c_str(), port);
    return net.send(data.data, size, dest_addr);
  }

  var recv(){
    lock_guard guard(lock);
    multicast_aux::address src_addr(ip.c_str(), port);

    var buffer = obj<value<datagram_t>>(max_data_gram_size);
    number_t read = (number_t)net.recv(src_addr, value<datagram_t>::to_reference(buffer));

    return rt::list(obj<number>(read), buffer);
  }
};

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

(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 [^c_str port speed v-min v-time]
  "struct termios toptions;
   int fd;

   fd = open(port, 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 [^number_t port ^byte data]
  "byte b[1] = {data};
   write(port, b, 1);")

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

(defn read [^number_t port]
  "char b[1] = {0};
   ssize_t bytes_read = read(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,

(defn ^volatile led-off [] :off)
(defn ^volatile led-on  [] :on)

(def light-switch
  (fsm
   (led-off (fn [] true) led-on)
   (led-on  (fn [] true) led-off)))

(def inf-loop
  (let [setup  (fn [] :setup)
        exec   (fn [] :exec)]
    (fsm
     (setup  exec))))

(deftest fsm-test
  (is (= :off (light-switch)))
  (is (= :on  (light-switch)))
  (is (= :off (light-switch)))
  (is (= :on  (light-switch)))

  (is (= :setup (inf-loop)))
  (is (= :exec  (inf-loop)))
  (is (= :exec  (inf-loop)))
  (is (= :exec  (inf-loop))))

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

class fsm final : public lambda_i {
  mutex lock;
  var state;
  var transitions;
public:

  inline fsm(ref s, ref t) : state(s), transitions(t){ }

  inline var invoke(ref) const final {
    return var((object*)this).cast<fsm>()->yield();
  }

  var yield() {
    lock_guard guard(lock);
    var value;

    if (state.is_type(type_id<lambda_i>))
      value = run(state);
    else
      value = state;

    var next = transitions.cast<lambda_i>()->invoke(rt::list(state));

    if (next.is_nil())
      next = state;

    state = next;
    return value;
  }

};
(defobject fsm "fsm_o.h")

(defn new-fsm [state transitions]
  "return obj<fsm>(state, transitions)")

(defmacro fsm [& transitions]
  (let [fsm-state (gensym)
        switch    (->> (reduce
                        (fn [h v]
                          (let [[state & conds] v
                                at-state `(= ~state ~fsm-state)
                                jmp (if (= (count conds) 1)
                                      (first conds)
                                      (->> (reduce
                                            (fn [h v]
                                              (let [[check state] v]
                                                (conj h `(~check) state)))
                                            ['cond] (partition 2 conds))
                                           (apply list)))]
                            (conj h at-state jmp)))
                        ['cond] transitions)
                       (apply list))]
    `(new-fsm
      ~(-> transitions first first)
      (fn [~fsm-state] ~switch))))

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.

(deftest pid-controller-test
  (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 [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)))))

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 "pid_controller_o.h")
template <typename T>
class pid_controller : public lambda_i {
  mutex lock;
  mutable T setpoint;
  mutable T prev_error;
  mutable T total_error;
  mutable T error;
  mutable T result;
  mutable T input;

  T p;
  T i;
  T d;
  T maximum_output;
  T minimum_output;
  T maximum_input;
  T minimum_input;
  bool continuous;
  var setpoint_fn;

  void set_setpoint(ref p) {
    lock_guard guard(lock);
    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 step(ref in) {
    lock_guard guard(lock);
    input = number::to<T>(in);

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

    // If continuous is set to true allow wrap around
    if (continuous) {
      if (rt::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);
  }

public:
  pid_controller(T kp, T ki, T kd,
                 T inMin, T inMax, T outMin, T outMax,
                 bool cont,
                 ref sp):
    p(kp),
    i(ki),
    d(kd),
    maximum_output(outMax),
    minimum_output(outMin),
    maximum_input(inMax),
    minimum_input(inMin),
    continuous(cont){

    if (sp.is_type(type_id<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;
  }

  var invoke(ref args) const final {
    if (!setpoint_fn.is_nil())
      var((object*)this).cast<pid_controller<T>>()
        ->set_setpoint(run(setpoint_fn));

    return var((object*)this).cast<pid_controller<T>>()
      ->step(rt::first(args));
  }
};
(defn new-pid-controller [^real_t kp ^real_t ki ^real_t kd
                          ^real_t i-min ^real_t i-max
                          ^real_t o-min ^real_t o-max
                          ^bool_t 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.

(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)))))
(defobject moving_average_filter "moving_average_filter_o.h")

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

  var step(T data) {
    lock_guard guard(lock);
    avrg = ((alpha * data) + ((1. - alpha) * avrg));
    return obj<number>(avrg);
  }

public:

  explicit moving_average_filter(T a) : alpha(a), avrg(0) { }

  var invoke(ref args) const final {
    return var((object*)this).cast<moving_average_filter<T>>()
      ->step(number::to<T>(rt::first(args)));
  }
};

Arduino

pin-mode

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

(defmacro pin-mode [pin mode]
  (let [mode    (-> mode name .toUpperCase)
        isr-pin (gensym)]
    `(do
       (def ~isr-pin ~pin)
       (cxx
        ~(str "::pinMode(number::to<int>(" isr-pin ") , " mode ");")))))

digital-write

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

(defnative digital-write [^number_t pin ^number_t val]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::digitalWrite(pin, val);"))

digital-read

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

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

analog-write

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

(defnative analog-write [^number_t pin ^number_t val]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::analogWrite(pin,val);"))

analog-read

Reads the value from the specified analog pin.

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

analog-write-resolution

Sets the resolution of the analog-write

(defnative analog-write-resolution [^number_t bit]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::analogWriteResolution(bit);"))

analog-read-resolution

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

(defnative analog-read-resolution [^number_t bit]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::analogReadResolution(bit);"))

bounce

Bounce object can be used to reliably read push buttons or mechanical sensors which have contacts that "chatter" or "bounce".

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

(def button (gpio/new-bounce 7 250))

(while true
  (when (pos? (button))
    (println "Pressed!"))
  (sleep 250))
(defobject bounce "arduino/bounce_o.h")

(defn new-bounce [^number_t x ^number_t t-debounce]
  "return obj<bounce>(x, t_debounce);")
class bounce final : public lambda_i {
  mutex lock;
  void (bounce::* fsm_state)();
  byte state;
  byte last_state;
  unsigned long t_debounce;
  unsigned long t_last_debounce;
  byte pin;

  void debounce(){
    int reading = digitalRead(pin);

    // reset the debouncing timer
    if (reading != last_state){
      t_last_debounce = millis();
      last_state = reading;
    }

    if ((::millis() - t_last_debounce) > t_debounce){
      if (reading == LOW)
        fsm_state = &bounce::off;
      else
        fsm_state = &bounce::on;
    }
  }

  void init(){
    pinMode(pin, INPUT);
    fsm_state = &bounce::debounce;
  }

  void on(){
    state = 1;
    fsm_state = &bounce::debounce;
  }

  void off(){
    state = 0;
    fsm_state = &bounce::debounce;
  }

  var step(){
    lock_guard guard(lock);
    (this->*fsm_state)();
    return obj<number>(state);
  }

 public:

  explicit bounce(number_t p, number_t t_db) :
    fsm_state(&bounce::init),
    state(0),
    last_state(0),
    t_debounce(t_db),
    t_last_debounce(millis()),
    pin(p)
    {}

  var invoke(ref args) const final {
    return var((object*)this).cast<bounce>()->step();
  }
};

random

(defnative random-seed [^number_t pin]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "randomSeed(analogRead(pin));"))

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

tone/noTone

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

(defnative tone [^number_t pin ^number_t freq]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::tone(pin, freq);"))

(defnative no-tone [^number_t pin]
  (on "defined FERRET_HARDWARE_ARDUINO"
      "::noTone(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(number::to<int>(" isr-pin ") , INPUT_PULLUP);\n"
              "auto isr_pin = digitalPinToInterrupt(number::to<int>(" 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 [^number_t p]
  "detachInterrupt(digitalPinToInterrupt(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 [^number_t val]
  "return obj<number>(SPI.transfer(val));")

Wire

This library allows you to communicate with I2C / TWI devices. See documentation for more information.

(defnative wire-begin []
  (on "defined FERRET_HARDWARE_ARDUINO"
      ("Wire.h")
      "Wire.begin();"))

(defn with-wire-aux [^number_t addr f]
  "Wire.beginTransmission(addr);
   __result = run(f);
   Wire.endTransmission();")

(defmacro with-wire [addr & body]
  `(with-wire-aux ~addr (fn [] ~@body)))

(defn wire-write [^number_t val]
  "Wire.write(val);")

(defn wire-read []
  "return obj<number>(Wire.read());")

(defn wire-request-from [^number_t addr ^number_t bytes]
  "Wire.requestFrom(addr, bytes);")

(defn wire-available []
  "__result = obj<number>(Wire.available());")

Watchdog Timer

A watchdog timer is an electronic timer that is used to detect and recover from program malfunctions. During normal operation, the program regularly resets the watchdog timer to prevent it from elapsing, or "timing out".

AVR
(require '[ferret.arduino.avr :as avr])

;; initialize 
(avr/wdt-enable 1000)

(while true
  ;; do stuff
  (avr/wdt-reset))
(defmacro wdt-enable [timer]
  (let [timer (condp = timer
                15   "WDTO_15MS"
                30   "WDTO_30MS"
                60   "WDTO_60MS"
                120  "WDTO_120MS"
                250  "WDTO_250MS"
                500  "WDTO_500MS"
                1000 "WDTO_1S"
                2000 "WDTO_2S"
                4000 "WDTO_4S"
                8000 "WDTO_8S")]
    `(cxx ~(str "wdt_enable(" timer ")"))))

(defnative wdt-reset []
  (on "defined __AVR_ARCH__"
      ("avr/wdt.h")
      "wdt_reset();"))

ESP32

Bindings for Arduino core for ESP32 WiFi chip.

(native-header "WiFi.h"
               "HTTPClient.h")

(defn wifi-connect [^c_str ssid ^c_str password]
  "WiFi.begin(ssid, password);
   while (WiFi.status() != WL_CONNECTED)
     delay(100);")

(defn http-get
  ([url]
   (http-get url {}))
  ([^c_str u opts]
   "HTTPClient http;
    String url(u);

    // check :query-params
    if (var params = run(opts, obj<keyword>(1313))){
       url += \"?\";
       for_each(param, params){
          auto key = string::to<String>(rt::first(param));
          auto val = string::to<String>(rt::first(rt::rest(param)));
          url += key + \"=\"+ val + \"&\";
       }
    }

    http.begin(url);
    auto http_status = http.GET();

    var data;
    if(http_status == HTTP_CODE_OK)
      data = obj<string>(http.getString().c_str());

    http.end();
    return rt::list(obj<number>(http_status), data);"))

(defn http-post
  ([url]
   (http-post url {}))
  ([^c_str url opts]
   "HTTPClient http;
    http.begin(url);

    //check :headers
    if (var headers = run(opts, obj<keyword>(790))){
       for_each(header, headers){
          auto key = string::to<String>(rt::first(header));
          auto val = string::to<String>(rt::first(rt::rest(header)));
          http.addHeader(key,val);
       }
    }

    auto http_status = http.POST(string::to<String>(run(opts, obj<keyword>(488))));

    var data;
    if(http_status == HTTP_CODE_OK || http_status == HTTP_CODE_CREATED)
      data = obj<string>(http.getString().c_str());

    http.end();
    return rt::list(obj<number>(http_status), data);"))

Testing

assert

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

(defn aborted? [return-code]
  (= 134 return-code))

(deftest test-unit-test
  (is (aborted? (check-form '((assert (= 2 1))))))
  (is (zero?    (check-form '((assert (= 2 1))) {:release true}))))
(defn assert-aux [f cb]
  (when (not (f))
    (cb)))

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

deftest

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

(defn aborted? [return-code]
  (= 134 return-code))

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

  (is (zero?    (check-form '((deftest some-test
                                (is (= 6 (apply + (list 1 2 3)))))
                              (run-all-tests))))))
(defn is-aux-expect [ex-fb form-fn form-str]
  (let [expect (ex-fb)
        got  (form-fn)]
    (when (not=  expect got)
      (println "err" form-str "\n exp" expect "\n got" got)
      (system-abort))))

(defmacro is [form]
  (cond (= (first form) '=)
        (let [[_ expected form] form]
          `(is-aux-expect
            (fn [] ~expected) (fn [] ~form)
            ~(-> form pr-str (clojure.string/escape {\\ "\\\\"}))))
        :default `(~'assert ~form)))

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

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 7.0
  • Arduino 1.8.7

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
  • -ggdb

Static code analysis (cppcheck) options,

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

Valgrind options,

  • –quiet
  • –leak-check=full
  • –error-exitcode=1
  • –track-origins=yes

Roadmap

Compiler

  • fn
    • Pre/Post conditions for functions.
      • By default print error and abort.
      • Let user define a callback function.
    • Documentation String
  • 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 compiler.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