## 7.2 An Example

As an example, we take two simple extensions: an implementation of red-black trees and a simple ``functor''-like syntax that encapsulates the operations on the rb-tree data-type. The files for an extension should reside in a separate directory, so in the case of our simple functor-implementations we have the following directory-structure:

    functor.scm
    functor/
      utils.scm

Here we put the macro-definition for `define-functor` in a separate file, this simplifies the use in compiled code. The code follows:

    ;;; functor.scm

    (require 'srfi-1)
    (require-for-syntax 'match)

    (define-macro (define-functor name imports . body)
      (let ([exports
             (filter-map
              (match-lambda
                [('define (name . llist) . body) name]
                [('define name val) name]
                [_ #f] )
              body) ] )
        `(define (,name ,@imports)
           ,@body
           (values ,@exports) ) ) )

and

    ;;; functor/utils.scm

    (define (instantiate-functor f . imports)
      (apply f imports) )

One more thing is needed: a setup specification that contains information about the files and settings of the extension. In this case we have:

    ;;; functor.setup

    (chicken-setup (command-line-arguments)
      (functor ((syntax)
                (require-at-runtime (functor utils)) )
        (utils ()) ) )

Now we create an extension package:

    % csi -setup functor -wrap
    wrapping extension `functor' ...
    functor.setup
    functor.scm
    functor/
    functor/utils.scm

This will create the compressed archive `functor.egg`.

A user of this package can now use `csi` in combination with the `-setup` option to extract the contents from the archive, to build its components and install it in his Chicken system for easy use.

    % ls
    functor.egg
    % csi -setup functor -build
    extracting files from extension `functor' ...
    functor.setup
    functor.scm
    functor/
    functor/utils.scm
    building extension `functor' ...
    backing up registry...
    adding entry for `/home/felix/chicken/lib/functor.setup' ...
    compiling: csc -s ./functor/utils.scm -o ./functor/utils.so -O1
    removing temporary extension `/home/felix/chicken/lib/functor.setup' ...
    restoring registry

Note that `functor.scm` is not compiled, because it is explicitly marked as `syntax`, which means it is only meant to be used at compile-time, in source-form.

The extension is now installed and ready for use.

    % csi -quiet
    >>> (require-for-syntax 'functor)
    ; loading /home/felix/chicken/lib/functor.scm ...
    ; loading /home/felix/chicken/lib/functor/utils.so ...
    >>> (define-functor adder (+)
          (define (make-adder init)
            (lambda (x)
              (set! init (+ init x))
              init) ) )
    >>> (define ma (instantiate-functor adder +))
    >>> (define a1 (ma 99))
    >>> (a1 1)
    100
    >>> (a1 22)
    122
    >>>

The extension for red/black trees is created in much the same way:

    ;;; rbtree.scm
    ;
    ; taken directly from Chris Okasaki's ``Purely functional Data Structures''

    (require-for-syntax 'match)
    (require-for-syntax 'functor)

    (define-functor rb-tree (rb<?)

      (define (member? x t)
        (match t
          [() #f]
          [(_ a y b)
           (cond [(rb<? x y) (member? x a)]
                 [(rb<? y x) (member? x b)]
                 [else #t] ) ] ))

      (define balance
        (match-lambda
          [(or ('black ('red ('red a x b) y c) z d)
               ('black ('red a x ('red b y c)) z d)
               ('black a x ('red ('red b y c) z d))
               ('black a x ('red b y ('red c z d))) )
           `(red (black ,a ,x ,b) ,y (black ,c ,z ,d)) ]
          [body body] ) )

      (define (insert x s)
        (define ins
          (match-lambda
            [() `(red () ,x ())]
            [(and s (color a y b))
             (cond [(rb<? x y) (balance (list color (ins a) y b))]
                   [(rb<? y x) (balance (list color a y (ins b)))]
                   [else s] ) ] ) )
        (match (ins s)
          [(_ a y b) `(black ,a ,y ,b)] ) ) )

The setup-specification looks like this. Since we only have a single file, we don't need to put it in a separate directory:

    (chicken-setup (command-line-arguments)
      (rb-tree ((options "-O2")
                (file "rbtree.scm")
                (require-for-syntax functor match) ) ) )

Note the properties used: `(options "-O2")` overrides the default compiler-options (`"-O1"`) and we use a different name for the source file 26. This extension requires the `define-functor` extension, we have to use `require-for-syntax` to make sure that the macro is included at compile-time.

The wrapping, unwrapping, building and installation works identical to the previously given example. Here is some code that uses both extensions:

    % cat testrb.scm
    (require 'rb-tree 'srfi-1 'extras)
    (require '(functor utils))

    (define-values (num-rb-member? num-rb-balance num-rb-insert)
      (instantiate-functor rb-tree <) )

    (randomize)
    (print "building list...")
    (define vals (list-tabulate 10000 (lambda (_) (random 100000))))

    (print "building rb-tree...")
    (define t1 '())
    (for-each (lambda (n) (set! t1 (num-rb-insert n t1))) vals)

    (print "building hash-table...")
    (define ht (make-hash-table))
    (for-each (lambda (n) (hash-table-set! ht n #t)) vals)

    (print "linear list:")
    (time (every (lambda (n) (memq n vals)) vals))

    (print "hash-table:")
    (time (every (lambda (n) (hash-table-ref ht n)) vals))

    (print "rb:")
    (time (every (lambda (n) (num-rb-member? n t1)) vals))
    % csc testrb.scm -O2
    % testrb
    building list...
    building rb-tree...
    building hash-table...
    linear list:
        1.74 seconds elapsed
           0 seconds in GC
           0 mutations
         161 minor GCs
           0 major GCs
    hash-table:
        0.03 seconds elapsed
           0 seconds in GC
           0 mutations
         779 minor GCs
           0 major GCs
    rb:
        0.27 seconds elapsed
        0.02 seconds in GC
           0 mutations
        4684 minor GCs
           0 major GCs

26 just for the heck of it