add lexer for the Extempore programming language/environment

for more info, see

http://extempore.moso.com.au
https://github.com/digego/extempore

4 files changed, 1309 insertions, 2 deletions

diff --git a/AUTHORS b/AUTHORS
index 9318d438..4e20febb 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -174,6 +174,7 @@ Other contributors, listed alphabetically, are:
 * James Strachan -- Kotlin lexer
 * Tom Stuart -- Treetop lexer
 * Colin Sullivan -- SuperCollider lexer
+* Ben Swift -- Extempore lexer
 * Edoardo Tenani -- Arduino lexer
 * Tiberius Teng -- default style overhaul
 * Jeremy Thurgood -- Erlang, Squid config lexers
diff --git a/pygments/lexers/_mapping.py b/pygments/lexers/_mapping.py
index 39d5e85a..ba0f3e70 100644
--- a/pygments/lexers/_mapping.py
+++ b/pygments/lexers/_mapping.py
@@ -17,8 +17,8 @@ from __future__ import print_function
 
 LEXERS = {
     'ABAPLexer': ('pygments.lexers.business', 'ABAP', ('abap',), ('*.abap',), ('text/x-abap',)),
-    'AbnfLexer': ('pygments.lexers.grammar_notation', 'ABNF', ('abnf',), ('*.abnf',), ('text/x-abnf',)),
     'APLLexer': ('pygments.lexers.apl', 'APL', ('apl',), ('*.apl',), ()),
+    'AbnfLexer': ('pygments.lexers.grammar_notation', 'ABNF', ('abnf',), ('*.abnf',), ('text/x-abnf',)),
     'ActionScript3Lexer': ('pygments.lexers.actionscript', 'ActionScript 3', ('as3', 'actionscript3'), ('*.as',), ('application/x-actionscript3', 'text/x-actionscript3', 'text/actionscript3')),
     'ActionScriptLexer': ('pygments.lexers.actionscript', 'ActionScript', ('as', 'actionscript'), ('*.as',), ('application/x-actionscript', 'text/x-actionscript', 'text/actionscript')),
     'AdaLexer': ('pygments.lexers.pascal', 'Ada', ('ada', 'ada95', 'ada2005'), ('*.adb', '*.ads', '*.ada'), ('text/x-ada',)),
@@ -412,6 +412,7 @@ LEXERS = {
     'XmlSmartyLexer': ('pygments.lexers.templates', 'XML+Smarty', ('xml+smarty',), (), ('application/xml+smarty',)),
     'XsltLexer': ('pygments.lexers.html', 'XSLT', ('xslt',), ('*.xsl', '*.xslt', '*.xpl'), ('application/xsl+xml', 'application/xslt+xml')),
     'XtendLexer': ('pygments.lexers.jvm', 'Xtend', ('xtend',), ('*.xtend',), ('text/x-xtend',)),
+    'XtlangLexer': ('pygments.lexers.lisp', 'xtlang', ('extempore',), ('*.xtm',), ()),
     'YamlJinjaLexer': ('pygments.lexers.templates', 'YAML+Jinja', ('yaml+jinja', 'salt', 'sls'), ('*.sls',), ('text/x-yaml+jinja', 'text/x-sls')),
     'YamlLexer': ('pygments.lexers.data', 'YAML', ('yaml',), ('*.yaml', '*.yml'), ('text/x-yaml',)),
     'ZephirLexer': ('pygments.lexers.php', 'Zephir', ('zephir',), ('*.zep',), ()),
diff --git a/pygments/lexers/lisp.py b/pygments/lexers/lisp.py
index bd59d2b6..273af5a9 100644
--- a/pygments/lexers/lisp.py
+++ b/pygments/lexers/lisp.py
@@ -18,7 +18,8 @@ from pygments.token import Text, Comment, Operator, Keyword, Name, String, \
 from pygments.lexers.python import PythonLexer
 
 __all__ = ['SchemeLexer', 'CommonLispLexer', 'HyLexer', 'RacketLexer',
-           'NewLispLexer', 'EmacsLispLexer', 'ShenLexer', 'CPSALexer']
+           'NewLispLexer', 'EmacsLispLexer', 'ShenLexer', 'CPSALexer',
+           'XtlangLexer']
 
 
 class SchemeLexer(RegexLexer):
@@ -2363,3 +2364,206 @@ class CPSALexer(SchemeLexer):
             (r'(\[|\])', Punctuation),
         ],
     }
+
+class XtlangLexer(RegexLexer):
+    """An xtlang lexer for the Extempore programming environment
+
+    http://extempore.moso.com.au
+
+    This is a mixture of Scheme and xtlang, really. Keyword lists are
+    taken from the Extempore Emacs mode
+    (https://github.com/extemporelang/extempore-emacs-mode)
+
+    """
+    name = 'xtlang'
+    aliases = ['extempore']
+    filenames = ['*.xtm']
+    mimetypes = []
+
+    common_keywords = (
+        'lambda', 'define', 'if', 'else', 'cond', 'and',
+        'or', 'let', 'begin', 'set!', 'map', 'for-each'
+    )
+    scheme_keywords = (
+        'do', 'delay', 'quasiquote', 'unquote', 'unquote-splicing', 'eval',
+        'case', 'let*', 'letrec', 'quote', 'let*', 'letrec'
+    )
+    xtlang_bind_keywords = (
+        'bind-func', 'bind-val', 'bind-lib', 'bind-type', 'bind-alias',
+        'bind-poly', 'bind-dylib', 'bind-lib-func', 'bind-lib-val'
+    )
+    xtlang_keywords = (
+        'letz', 'memzone', 'cast', 'convert', 'dotimes', 'doloop'
+    )
+    common_functions = (
+        '*', '+', '-', '/', '<', '<=', '=', '>', '>=', '%', 'abs', 'acos',
+        'angle', 'append', 'apply', 'asin', 'assoc', 'assq', 'assv',
+        'atan', 'boolean?', 'caaaar', 'caaadr', 'caaar', 'caadar',
+        'caaddr', 'caadr', 'caar', 'cadaar', 'cadadr', 'cadar',
+        'caddar', 'cadddr', 'caddr', 'cadr', 'car', 'cdaaar',
+        'cdaadr', 'cdaar', 'cdadar', 'cdaddr', 'cdadr', 'cdar',
+        'cddaar', 'cddadr', 'cddar', 'cdddar', 'cddddr', 'cdddr',
+        'cddr', 'cdr', 'ceiling', 'cons', 'cos', 'floor', 'length',
+        'list', 'log', 'max', 'member', 'min', 'modulo', 'not',
+        'reverse', 'round', 'sin', 'sqrt', 'substring', 'tan',
+        'println', 'random', 'null?', 'callback', 'now'
+    )
+    scheme_functions = (
+        'call-with-current-continuation', 'call-with-input-file',
+        'call-with-output-file', 'call-with-values', 'call/cc',
+        'char->integer', 'char-alphabetic?', 'char-ci<=?', 'char-ci<?',
+        'char-ci=?', 'char-ci>=?', 'char-ci>?', 'char-downcase',
+        'char-lower-case?', 'char-numeric?', 'char-ready?',
+        'char-upcase', 'char-upper-case?', 'char-whitespace?',
+        'char<=?', 'char<?', 'char=?', 'char>=?', 'char>?', 'char?',
+        'close-input-port', 'close-output-port', 'complex?',
+        'current-input-port', 'current-output-port', 'denominator',
+        'display', 'dynamic-wind', 'eof-object?', 'eq?', 'equal?',
+        'eqv?', 'even?', 'exact->inexact', 'exact?', 'exp', 'expt',
+        'force', 'gcd', 'imag-part', 'inexact->exact', 'inexact?',
+        'input-port?', 'integer->char', 'integer?',
+        'interaction-environment', 'lcm', 'list->string',
+        'list->vector', 'list-ref', 'list-tail', 'list?', 'load',
+        'magnitude', 'make-polar', 'make-rectangular', 'make-string',
+        'make-vector', 'memq', 'memv', 'negative?', 'newline',
+        'null-environment', 'number->string', 'number?',
+        'numerator', 'odd?', 'open-input-file', 'open-output-file',
+        'output-port?', 'pair?', 'peek-char', 'port?', 'positive?',
+        'procedure?', 'quotient', 'rational?', 'rationalize', 'read',
+        'read-char', 'real-part', 'real?',
+        'remainder', 'scheme-report-environment', 'set-car!', 'set-cdr!',
+        'string', 'string->list', 'string->number', 'string->symbol',
+        'string-append', 'string-ci<=?', 'string-ci<?', 'string-ci=?',
+        'string-ci>=?', 'string-ci>?', 'string-copy', 'string-fill!',
+        'string-length', 'string-ref', 'string-set!', 'string<=?',
+        'string<?', 'string=?', 'string>=?', 'string>?', 'string?',
+        'symbol->string', 'symbol?', 'transcript-off', 'transcript-on',
+        'truncate', 'values', 'vector', 'vector->list', 'vector-fill!',
+        'vector-length', 'vector?',
+        'with-input-from-file', 'with-output-to-file', 'write',
+        'write-char', 'zero?'
+    )
+    xtlang_functions = (
+        'printf', 'toString', 'afill!', 'pfill!', 'tfill!', 'tbind', 'vfill!',
+        'array-fill!', 'pointer-fill!', 'tuple-fill!', 'vector-fill!', 'free',
+        'array', 'tuple', 'list', '~', 'cset!', 'cref', '&', 'bor',
+        'ang-names', '<<', '>>', 'nil', 'printf', 'sprintf', 'null', 'now',
+        'pset!', 'pref-ptr', 'vset!', 'vref', 'aset!', 'aref', 'aref-ptr',
+        'tset!', 'tref', 'tref-ptr', 'salloc', 'halloc', 'zalloc', 'alloc',
+        'schedule', 'exp', 'log', 'sin', 'cos', 'tan', 'asin', 'acos', 'atan',
+        'sqrt', 'expt', 'floor', 'ceiling', 'truncate', 'round',
+        'llvm_printf', 'push_zone', 'pop_zone', 'memzone', 'callback',
+        'llvm_sprintf', 'make-array', 'array-set!', 'array-ref',
+        'array-ref-ptr', 'pointer-set!', 'pointer-ref', 'pointer-ref-ptr',
+        'stack-alloc', 'heap-alloc', 'zone-alloc', 'make-tuple', 'tuple-set!',
+        'tuple-ref', 'tuple-ref-ptr', 'closure-set!', 'closure-ref', 'pref',
+        'pdref', 'impc_null', 'bitcast', 'void', 'ifret', 'ret->', 'clrun->',
+        'make-env-zone', 'make-env', '<>', 'dtof', 'ftod', 'i1tof',
+        'i1tod', 'i1toi8', 'i1toi32', 'i1toi64', 'i8tof', 'i8tod',
+        'i8toi1', 'i8toi32', 'i8toi64', 'i32tof', 'i32tod', 'i32toi1',
+        'i32toi8', 'i32toi64', 'i64tof', 'i64tod', 'i64toi1',
+        'i64toi8', 'i64toi32',
+    )
+
+    # valid names for Scheme identifiers (names cannot consist fully
+    # of numbers, but this should be good enough for now)
+    valid_scheme_name = r'[\w!$%&*+,/:<=>?@^~|-]+'
+
+    # valid characters in xtlang names & types
+    valid_xtlang_name = r'[\w._!-]+'
+    valid_xtlang_type = r'[]{}[\w_<>,*/|!-]+'
+
+    tokens = {
+        # keep track of when we're exiting the xtlang form
+        'xtlang': [
+            (r'\(', Punctuation, '#push'),
+            (r'\)', Punctuation, '#pop'),
+
+            (r'(?<=bind-func\s)' + valid_xtlang_name, Name.Function),
+            (r'(?<=bind-val\s)' + valid_xtlang_name, Name.Function),
+            (r'(?<=bind-type\s)' + valid_xtlang_name, Name.Function),
+            (r'(?<=bind-alias\s)' + valid_xtlang_name, Name.Function),
+            (r'(?<=bind-poly\s)' + valid_xtlang_name, Name.Function),
+            (r'(?<=bind-lib\s)' + valid_xtlang_name, Name.Function),
+            (r'(?<=bind-dylib\s)' + valid_xtlang_name, Name.Function),
+            (r'(?<=bind-lib-func\s)' + valid_xtlang_name, Name.Function),
+            (r'(?<=bind-lib-val\s)' + valid_xtlang_name, Name.Function),
+
+            # type annotations
+            (r':' + valid_xtlang_type, Keyword.Type),
+
+            # types
+            (r'(<' + valid_xtlang_type + r'>|\|' + valid_xtlang_type + r'\||/' + valid_xtlang_type + r'/|' + valid_xtlang_type + r'\*)\**',
+             Keyword.Type),
+
+            # keywords
+            (words(xtlang_keywords, prefix=r'(?<=\()'), Keyword),
+
+            # builtins
+            (words(xtlang_functions, prefix=r'(?<=\()'), Name.Function),
+
+            include('common'),
+
+            # variables
+            (valid_xtlang_name, Name.Variable),
+        ],
+        'scheme': [
+            # quoted symbols
+            (r"'" + valid_scheme_name, String.Symbol),
+
+            # char literals
+            (r"#\\([()/'\"._!§$%& ?=+-]|[a-zA-Z0-9]+)", String.Char),
+
+            # special operators
+            (r"('|#|`|,@|,|\.)", Operator),
+
+            # keywords
+            (words(scheme_keywords, prefix=r'(?<=\()'), Keyword),
+
+            # builtins
+            (words(scheme_functions, prefix=r'(?<=\()'), Name.Function),
+
+            include('common'),
+
+            # variables
+            (valid_scheme_name, Name.Variable),
+        ],
+        # common to both xtlang and Scheme
+        'common': [
+            # comments
+            (r';.*$', Comment.Single),
+
+            # whitespaces - usually not relevant
+            (r'\s+', Text),
+
+            # numbers
+            (r'-?\d+\.\d+', Number.Float),
+            (r'-?\d+', Number.Integer),
+
+            # binary/oct/hex literals
+            (r'(#b|#o|#x)[\d.]+', Number),
+
+            # strings
+            (r'"(\\\\|\\"|[^"])*"', String),
+
+            # true/false constants
+            (r'(#t|#f)', Name.Constant),
+
+            # keywords
+            (words(common_keywords, prefix=r'(?<=\()'), Keyword),
+
+            # builtins
+            (words(common_functions, prefix=r'(?<=\()'), Name.Function),
+
+            # the famous parentheses!
+            (r'(\(|\))', Punctuation),
+        ],
+        'root': [
+            # go into xtlang mode
+            (words(xtlang_bind_keywords, prefix=r'(?<=\()', suffix=r'\b'), Keyword, 'xtlang'),
+
+            include('scheme')
+        ],
+    }
+
+    # TODO stash the current changes, see how "+" was done before. also, look at the diff!
diff --git a/tests/examplefiles/example.xtm b/tests/examplefiles/example.xtm
new file mode 100644
index 00000000..927117da
--- /dev/null
+++ b/tests/examplefiles/example.xtm
@@ -0,0 +1,1101 @@
+;;; example.xtm -- Extempore code examples 
+
+;; Author: Ben Swift, Andrew Sorensen
+;; Keywords: extempore
+
+;;; Commentary:
+
+
+
+;;; Code:
+
+;; bit twiddling
+
+(xtmtest '(bind-func test_bit_twiddle_1
+            (lambda ()
+              (bitwise-and 65535 255 15 1)))
+
+         (test_bit_twiddle_1) 1)
+
+(xtmtest '(bind-func test_bit_twiddle_2
+            (lambda ()
+              (bitwise-not -1)))
+
+         (test_bit_twiddle_2) 0)
+
+(xtmtest '(bind-func test_bit_twiddle_3
+            (lambda ()
+              (bitwise-not 0)))
+
+         (test_bit_twiddle_3) -1)
+
+(xtmtest '(bind-func test_bit_twiddle_4
+            (lambda ()
+              (bitwise-shift-right 65535 8)
+              (bitwise-shift-right 65535 4 4)))
+
+         (test_bit_twiddle_4) 255)
+
+(xtmtest '(bind-func test_bit_twiddle_5
+            (lambda ()
+              (bitwise-shift-left (bitwise-shift-right 65535 8) 4 4)))
+
+         (test_bit_twiddle_5) 65280)
+
+(xtmtest '(bind-func test_bit_twiddle_6
+            (lambda ()
+              (bitwise-and (bitwise-or (bitwise-eor 21844 65534) (bitwise-eor 43690 65534)) 1)))
+
+         (test_bit_twiddle_6) 0)
+
+;; integer literals default to 64 bit integers
+(xtmtest '(bind-func int-literal-test
+            (lambda (a)
+              (* a 5)))
+
+         (int-literal-test 6) 30)
+
+;; float literals default to doubles
+(xtmtest '(bind-func float-literal-test
+            (lambda (a)
+              (* a 5.0)))
+
+         (float-literal-test 6.0) 30.0)
+
+;; you are free to recompile an existing closure
+(xtmtest '(bind-func int-literal-test
+            (lambda (a)
+              (/ a 5)))
+
+         (int-literal-test 30))
+
+(xtmtest '(bind-func closure-test1
+            (let ((power 0))
+              (lambda (x)
+                (set! power (+ power 1)) ;; set! for closure mutation as per scheme
+                (* x power))))
+
+         (closure-test1 2))
+
+(xtmtest '(bind-func closure-returns-closure-test
+            (lambda ()
+              (lambda (x)
+                (* x 3))))
+
+         (closure-returns-closure-test))
+
+(xtmtest '(bind-func incrementer-test1
+            (lambda (i:i64)
+              (lambda (incr)
+                (set! i (+ i incr))
+                i)))
+
+         (incrementer-test1 0))
+
+(define myf (incrementer-test1 0))
+
+;; so we need to type f properly
+(xtmtest '(bind-func incrementer-test2
+            (lambda (f:[i64,i64]* x)
+              (f x)))
+         (incrementer-test2 myf 1) 1)
+
+;; and we can call my-in-maker-wrapper
+;; to appy myf
+(xtmtest-result (incrementer-test2 myf 1) 2)
+(xtmtest-result (incrementer-test2 myf 1) 3)
+(xtmtest-result (incrementer-test2 myf 1) 4)
+
+;; of course the wrapper is only required if you
+;; need interaction with the scheme world.
+;; otherwise you just call my-inc-maker directly
+
+;; this avoids the wrapper completely
+(xtmtest '(bind-func incrementer-test3
+            (let ((f (incrementer-test1 0)))
+              (lambda ()
+                (f 1))))
+
+         (incrementer-test3) 1)
+
+(xtmtest-result (incrementer-test3) 2)
+(xtmtest-result (incrementer-test3) 3)
+
+;; hopefully you're getting the idea.
+;; note that once we've compiled something
+;; we can then use it any of our new
+;; function definitions.
+
+;; do a little 16bit test
+(xtmtest '(bind-func bitsize-sixteen
+            (lambda (a:i16)
+              (dtoi16 (* (i16tod a) 5.0))))
+
+         (bitsize-sixteen 5) 25)
+
+;; while loop test
+
+(xtmtest '(bind-func test_while_loop_1
+            (lambda ()
+              (let ((count 0))
+                (while (< count 5)
+                  (printf "count = %lld\n" count)
+                  (set! count (+ count 1)))
+                count)))
+
+         (test_while_loop_1) 5)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Closures can be recursive
+;;
+
+(xtmtest '(bind-func recursive-closure-test
+            (lambda (a)
+              (if (< a 1)
+                  (printf "done\n")
+                  (begin (printf "a: %lld\n" a)
+                         (recursive-closure-test (- a 1))))))
+
+         (recursive-closure-test 3))
+
+;; check TAIL OPTIMIZATION
+;; if there is no tail call optimiation
+;; in place then this should blow the
+;; stack and crash the test
+
+;; CANNOT RUN THIS TEST ON WINDOWS (i.e. no salloc)!
+(if (not (equal? (sys:platform) "Windows"))
+    (xtmtest '(bind-func tail_opt_test
+                (lambda (n:i64)
+                  (let ((a:float* (salloc 8000)))
+                    (if (= n 0)
+                        (printf "tail opt test passed!\n")
+                        (tail_opt_test (- n 1))))))
+
+             (tail_opt_test 200)))
+    
+(println 'A 'segfault 'here 'incidates 'that 'tail-call-optimizations 'are 'not 'working!)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; some anon lambda tests
+;;
+
+(xtmtest '(bind-func infer_lambdas_test
+            (lambda ()
+              (let ((a 5)
+                    (b (lambda (x) (* x x)))
+                    (c (lambda (y) (* y y))))          
+                (c (b a)))))
+
+         (infer_lambdas_test))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; a simple tuple example
+;;
+;; tuple types are represented as <type,type,type>*
+;;
+
+;; make and return a simple tuple
+(xtmtest '(bind-func tuple-test1
+            (lambda ()
+              (let ((t:<i64,double,i32>* (alloc)))
+                t)))
+
+         (tuple-test1))
+
+;; logview shows [<i64,double,i32>*]*
+;; i.e. a closure that takes no arguments
+;; and returns the tuple <i64,double,i32>*
+
+
+;; here's another tuple example
+;; note that my-test-7's return type is inferred
+;; by the tuple-reference index
+;; (i.e. i64 being tuple index 0)
+(xtmtest '(bind-func tuple-test2
+            (lambda ()
+              (let ((a:<i64,double>* (alloc)) ; returns pointer to type <i64,double>
+                    (b 37)
+                    (c 6.4))
+                (tuple-set! a 0 b) ;; set i64 to 64
+                (tset! a 1 c) ;; set double to 6.4 - tset! is an alias for tuple-set!
+                (printf "tuple:1 %lld::%f\n" (tuple-ref a 0) (tref a 1))
+                ;; we can fill a tuple in a single call by using tfill!
+                (tfill! a 77 77.7)
+                (printf "tuple:2 %lld::%f\n" (tuple-ref a 0) (tuple-ref a 1))
+                (tuple-ref a 0))))
+
+         (tuple-test2) 77)
+
+;; return first element which is i64
+;; should be 64 as we return the
+;; first element of the tuple
+;; (println (my-test-7)) ; 77
+
+
+;; tbind binds variables to values
+;; based on tuple structure
+;; _ (underscore) means don't attempt
+;; to match against this position in
+;; the tuple (i.e. skip)
+(xtmtest '(bind-func tuple-bind-test
+            (lambda ()
+              (let ((t1:<i32,float,<i32,float>*,double>* (alloc))
+                    (t2:<i32,float>* (alloc))
+                    (a 0) (b:float 0.0) (c 0.0))
+                (tfill! t2 3 3.3)
+                (tfill! t1 1 2.0 t2 4.0)
+                (tbind t1 a b _ c)
+                c)))
+
+         (tuple-bind-test) 4.0)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; some array code with *casting*
+;; this function returns void
+(xtmtest '(bind-func array-test1
+            (lambda ()
+              (let ((v1:|5,float|* (alloc))
+                    (v2:|5,float|* (alloc))
+                    (i 0)
+                    (k 0))
+                (dotimes (i 5)
+                  ;; random returns double so "truncate" to float
+                  ;; which is what v expects
+                  (array-set! v1 i (dtof (random))))
+                ;; we can use the afill! function to fill an array
+                (afill! v2 1.1 2.2 3.3 4.4 5.5)
+                (dotimes (k 5)
+                  ;; unfortunately printf doesn't like floats
+                  ;; so back to double for us :(
+                  (printf "val: %lld::%f::%f\n" k
+                          (ftod (array-ref v1 k))
+                          (ftod (aref v2 k)))))))
+
+         (array-test1))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; some crazy array code with
+;; closures and arrays
+;; try to figure out what this all does
+;;
+;; this example uses the array type
+;; the pretty print for this type is
+;; |num,type| num elements of type
+;; |5,i64| is an array of 5 x i64
+;;
+;; An array is not a pointer type
+;; i.e. |5,i64| cannot be bitcast to i64*
+;;
+;; However an array can be a pointer
+;; i.e. |5,i64|* can be bitcast to i64*
+;; i.e. |5,i64|** to i64** etc..
+;;
+;; make-array returns a pointer to an array
+;; i.e. (make-array 5 i64) returns type |5,i64|*
+;;
+;; aref (array-ref) and aset! (array-set!)
+;; can operate with either pointers to arrays or
+;; standard pointers.
+;;
+;; in other words aref and aset! are happy
+;; to work with either i64* or |5,i64|*
+
+(bind-func array-test2
+   (lambda (v:|5,i64|*)
+      (let ((f (lambda (x)
+		  (* (array-ref v 2) x))))
+	f)))
+
+(bind-func array-test3
+  (lambda (v:|5,[i64,i64]*|*)
+    (let ((ff (aref v 0))) ; aref alias for array-ref
+      (ff 5))))
+
+(xtmtest '(bind-func array-test4
+            (lambda ()
+              (let ((v:|5,[i64,i64]*|* (alloc)) ;; make an array of closures!
+                    (vv:|5,i64|* (alloc)))
+                (array-set! vv 2 3)
+                (aset! v 0 (array-test2 vv)) ;; aset! alias for array-set!
+                (array-test3 v))))
+
+         ;; try to guess the answer before you call this!!
+         (array-test4))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; some conditionals
+
+(xtmtest '(bind-func cond-test1
+            (lambda (x:i64 y)
+              (if (> x y)
+                  x
+                  y)))
+
+         (cond-test1 12 13))
+
+;; returns boolean true
+(xtmtest '(bind-func cond-test2
+            (lambda (x:i64)
+              (cond ((= x 1) (printf "A\n"))
+                    ((= x 2) (printf "B\n"))
+                    ((= x 3) (printf "C\n"))
+                    ((= x 4) (printf "D\n"))
+                    (else (printf "E\n")))
+              #t))
+
+         (cond-test2 1))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; making a linear envelop generator
+;; for signal processing and alike
+
+(bind-func envelope-segments
+  (lambda (points:double* num-of-points:i64)
+    (let ((lines:[double,double]** (zone-alloc num-of-points))
+	  (k 0))
+      (dotimes (k num-of-points)
+	(let* ((idx (* k 2))
+	       (x1 (pointer-ref points (+ idx 0)))
+	       (y1 (pointer-ref points (+ idx 1)))
+	       (x2 (pointer-ref points (+ idx 2)))
+	       (y2 (pointer-ref points (+ idx 3)))
+	       (m (if (= 0.0 (- x2 x1)) 0.0 (/ (- y2 y1) (- x2 x1))))
+	       (c (- y2 (* m x2)))
+	       (l (lambda (time) (+ (* m time) c))))
+	  (pointer-set! lines k l)))
+      lines)))
+
+(bind-func make-envelope
+   (lambda (points:double* num-of-points)
+      (let ((klines:[double,double]** (envelope-segments points num-of-points))
+	    (line-length num-of-points))
+	 (lambda (time)
+	    (let ((res -1.0)
+		  (k:i64 0))
+	       (dotimes (k num-of-points)
+		  (let ((line (pointer-ref klines k))
+			(time-point (pointer-ref points (* k 2))))
+		     (if (or (= time time-point)
+			     (< time-point time))
+			 (set! res (line time)))))
+	       res)))))
+
+;; make a convenience wrapper
+(xtmtest '(bind-func env-wrap
+            (let* ((points 3)
+                   (data:double* (zone-alloc (* points 2))))
+              (pointer-set! data 0 0.0) ;; point data
+              (pset! data 1 0.0)
+              (pset! data 2 2.0)
+              (pset! data 3 1.0)
+              (pset! data 4 4.0)
+              (pset! data 5 0.0)
+              (let ((f (make-envelope data points)))
+                (lambda (time:double)
+                  (f time)))))
+         (env-wrap 0.0) 0.0)
+
+(xtmtest-result (env-wrap 1.0) 0.5)
+(xtmtest-result (env-wrap 2.0) 1.0)
+(xtmtest-result (env-wrap 2.5) 0.75)
+(xtmtest-result (env-wrap 4.0) 0.0)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; direct access to a closures environment
+;;
+;; it is possible to directly access a closures
+;; environment in order to read or modify data
+;; at runtime.
+;;
+;; You do this using a dot operator
+;; To access an environment slot you use
+;; closure.slot:type
+;; So for example
+;; (f.a:i32)
+;; would return the 32bit integer symbol 'a'
+;; from the closure 'f'
+;;
+;; To set an environment slot you just
+;; add a value of the correct type
+;; for example
+;; (f.a:i32 565)
+;; would set 'a' in 'f' to 565
+;;
+;; let's create a closure that capture's 'a'
+
+
+(xtmtest '(bind-func dot-access-test1
+            (let ((a:i32 6))
+              (lambda ()
+                (printf "a:%d\n" a)
+                a)))
+         (dot-access-test1))
+
+;; now let's create a new function
+;; that calls my-test14 twice
+;; once normally
+;; then we directly set the closures 'a' binding
+;; then call again
+;;
+(xtmtest '(bind-func dot-access-test2
+            (lambda (x:i32)
+              (dot-access-test1)
+              (dot-access-test1.a:i32 x)
+              (dot-access-test1)))
+
+         (dot-access-test2 9))
+
+;; of course this works just as well for
+;; non-global closures
+(xtmtest '(bind-func dot-access-test3
+            (lambda (a:i32)
+              (let ((f (lambda ()
+                         (* 3 a))))
+                f)))
+         (dot-access-test3 1))
+
+(xtmtest '(bind-func dot-access-test4
+            (lambda ()
+              (let ((f (dot-access-test3 5)))
+                (f.a:i32 7)
+                (f))))
+
+         (dot-access-test4)
+         21)
+
+;; and you can get and set closures also!
+(xtmtest '(bind-func dot-access-test5
+            (lambda ()
+              (let ((f (lambda (x:i64) x)))
+                (lambda (z)
+                  (f z)))))
+
+         (dot-access-test5))
+
+(xtmtest '(bind-func dot-access-test6
+            (lambda ()
+              (let ((t1 (dot-access-test5))
+                    (t2 (dot-access-test5)))
+                ;; identity of 5
+                (printf "%lld:%lld\n" (t1 5) (t2 5))
+                (t1.f:[i64,i64]* (lambda (x:i64) (* x x)))
+                ;; square of 5
+                (printf "%lld:%lld\n" (t1 5) (t2 5))
+                ;; cube of 5
+                (t2.f:[i64,i64]* (lambda (y:i64) (* y y y)))
+                (printf "%lld:%lld\n" (t1 5) (t2 5))
+                void)))
+
+         (dot-access-test6)) ;; 5:5 > 25:5 > 25:125
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; named types
+
+;; it can sometimes be helpful to allocate
+;; a predefined tuple type on the stack
+;; you can do this using allocate
+(bind-type vec3 <double,double,double>)
+
+;; String printing!
+(bind-func vec3_print:[void,vec3*]*
+  (lambda (x)
+    (printf "<%d,%d,%d>" (tref x 0) (tref x 1) (tref x 2))
+    void))
+
+(bind-poly print vec3_print)
+
+;; note that point is deallocated at the
+;; end of the function call.  You can
+;; stack allocate (stack-alloc)
+;; any valid type  (i64 for example)
+(xtmtest '(bind-func salloc-test
+            (lambda ()
+              (let ((point:vec3* (stack-alloc)))
+                (tset! point 0 0.0)
+                (tset! point 1 -1.0)
+                (tset! point 2 1.0)
+                1)))
+
+         (salloc-test)) ;; 1
+
+;; all named types have 2 default constructors
+;; name (zone alloation) + name_h (heap allocation)
+;; and a default print poly
+(xtmtest '(bind-func data-constructor-test
+            (lambda ()
+              (let ((v1 (vec3 1.0 2.0 3.0))
+                    (v2 (vec3_h 4.0 5.0 6.0)))
+                (println v1 v2)
+                ;; halloced vec3 needs freeing
+                (free v2)
+                void)))
+
+         (data-constructor-test))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; aref-ptr and tref-ptr
+;;
+
+;; aref-ptr and tref-ptr return a pointer to an element
+;; just as aref and tref return elements aref-ptr and
+;; tref-ptr return a pointer to those elements.
+
+;; This allows you to do things like create an array
+;; with an offset
+(xtmtest '(bind-func aref-ptr-test
+            (lambda ()
+              (let ((arr:|32,i64|* (alloc))
+                    (arroff (aref-ptr arr 16))
+                    (i 0)
+                    (k 0))
+                ;; load arr
+                (dotimes (i 32) (aset! arr i i))
+                (dotimes (k 16)
+                  (printf "index: %lld\tarr: %lld\tarroff: %lld\n"
+                          k (aref arr k) (pref arroff k))))))
+
+         (aref-ptr-test))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; arrays
+;; Extempore lang supports arrays as for first class
+;; aggregate types (in other words as distinct from
+;; a pointer).
+;;
+;; an array is made up of a size and a type
+;; |32,i64| is an array of 32 elements of type i64
+;;
+
+(bind-type tuple-with-array <double,|32,|4,i32||,float>)
+
+(xtmtest '(bind-func array-test5
+            (lambda ()
+              (let ((tup:tuple-with-array* (stack-alloc))
+                    (t2:|32,i64|* (stack-alloc)))
+                (aset! t2 0 9)
+                (tset! tup 2 5.5)
+                (aset! (aref-ptr (tref-ptr tup 1) 0) 0 0)
+                (aset! (aref-ptr (tref-ptr tup 1) 0) 1 1)
+                (aset! (aref-ptr (tref-ptr tup 1) 0) 2 2)
+                (printf "val: %lld %lld %f\n"
+                        (aref (aref-ptr (tref-ptr tup 1) 0) 1)
+                        (aref t2 0) (ftod (tref tup 2)))
+                (aref (aref-ptr (tref-ptr tup 1) 0) 1))))
+
+         (array-test5) 1) ;; val: 1 9 5.5
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Global Variables
+;;
+;; You can allocate global variables using bind-val
+;;
+
+(bind-val g_var_a i32 5)
+
+;; increment g_var_a by inc
+;; and return new value of g_var_a
+(xtmtest '(bind-func global_var_test1
+            (lambda (incr)
+              (set! g_var_a (+ g_var_a incr))
+              g_var_a))
+
+         (global_var_test1 3) 8) ;; 8
+
+;; you can bind any primitive type
+(bind-val g_var_b double 5.5)
+(bind-val g_var_c i1 0)
+
+(xtmtest '(bind-func global_var_test1b
+            (lambda ()
+              (* g_var_b (if g_var_c 1.0 4.0))))
+
+         (global_var_test1b) 22.0)
+
+;; global strings
+
+(bind-val g_cstring i8* "Jiblet.")
+
+(xtmtest '(bind-func test_g_cstring
+            (lambda ()
+              (let ((i 0))
+                (dotimes (i 7)
+                  (printf "g_cstring[%lld] = %c\n" i (pref g_cstring i)))
+                (printf "\nSpells... %s\n" g_cstring))))
+
+         (test_g_cstring))
+
+(xtmtest '(bind-func test_g_cstring1
+            (lambda ()
+              (let ((test_cstring "Niblot.")
+                    (i 0)
+                    (total 0))
+                (dotimes (i 7)
+                  (let ((c1 (pref g_cstring i))
+                        (c2 (pref test_cstring i)))
+                    (printf "checking %c against %c\n" c1 c2)
+                    (if (= c1 c2)
+                        (set! total (+ total 1)))))
+                total)))
+
+         (test_g_cstring1) 5)
+
+
+
+
+
+;; for tuples, arrays and vectors, bind-val only takes *two*
+;; arguments. The tuple/array/vector will be initialised to zero.
+
+(bind-val g_tuple1 <i64,i64>)
+(bind-val g_tuple2 <double,double>)
+
+(xtmtest '(bind-func test_g_tuple
+            (lambda ()
+              (tfill! g_tuple1 1 4)
+              (tfill! g_tuple2 4.0 1.0)
+              (and (= (tref g_tuple1 0) (dtoi64 (tref g_tuple2 1)))
+                   (= (dtoi64 (tref g_tuple2 0)) (tref g_tuple1 1)))))
+
+         (test_g_tuple) 1)
+
+;; same thing with arrays
+
+(bind-val g_array1 |10,double|)
+(bind-val g_array2 |10,i64|)
+
+;; if we just loop over and print the values in each array
+
+(xtmtest '(bind-func test_g_array11
+            (lambda ()
+              (let ((i 0))
+                (dotimes (i 10)
+                  (printf "garray_1[%lld] = %f   garray_2[%lld] = %lld\n"
+                          i (aref g_array1 i) i (aref g_array2 i))))))
+
+         (test_g_array11) 1)
+
+;; but if we loop over and set some values into the arrays
+
+(xtmtest '(bind-func test_g_array2
+            (lambda ()
+              (let ((i 0))
+                (dotimes (i 10)
+                  (aset! g_array1 i (i64tod i))
+                  (aset! g_array2 i i)
+                  (printf "garray_1[%lld] = %f   garray_2[%lld] = %lld\n"
+                          i (aref g_array1 i) i (aref g_array2 i)))
+                (= (dtoi64 (aref g_array1 5))
+                   (aref g_array2 5)))))
+
+         (test_g_array2) 1)
+
+;; just to test, let's try a large array
+
+(bind-val g_array3 |100000000,i64|)
+
+(xtmtest '(bind-func test_g_array3
+            (lambda ()
+              (let ((i 0))
+                (dotimes (i 100000000)
+                  (aset! g_array3 i i))
+                (= (pref g_array3 87654321)
+                   87654321))))
+
+         (test_g_array3) 1)
+
+;; if you want to bind a global pointer, then the third 'value'
+;; argument is the size of the memory to allocate (in elements, not in bytes)
+
+(bind-val g_ptr0 double* 10)
+
+(xtmtest '(bind-func test_g_ptr0
+            (lambda ()
+              (let ((total 0.0)
+                    (i 0))
+                (dotimes (i 10)
+                  (pset! g_ptr0 i (i64tod i))
+                  (set! total (+ total (pref g_ptr0 i))))
+                total)))
+
+         (test_g_ptr0) 45.0)
+
+(bind-val g_ptr1 |4,i32|* 2)
+(bind-val g_ptr2 <i64,double>* 4)
+
+(xtmtest '(bind-func test_g_ptr1
+            (lambda ()
+              (afill! g_ptr1 11 66 35 81)
+              (tset! g_ptr2 1 35.0)
+              (printf "%f :: %d\n" (tref g_ptr2 1) (aref g_ptr1 2))
+              (aref g_ptr1 3)))
+
+         (test_g_ptr1) 81) ;; should also print 35.000000 :: 35
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Callbacks
+
+(xtmtest '(bind-func callback-test
+            (lambda (time:i64 count:i64)
+              (printf "time: %lld:%lld\n" time count)
+              (callback (+ time 1000) callback-test (+ time 22050) (+ count 1))))
+
+         (callback-test (now) 0))
+
+;; compiling this will stop the callbacks
+;;
+;; of course we need to keep the type
+;; signature the same [void,i64,i64]*
+;;
+(xtmtest '(bind-func callback-test
+            (lambda (time:i64 count:i64)
+              #t))
+
+         (callback-test))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; some memzone tests
+
+(xtmtest '(bind-func memzone-test1
+            (lambda ()
+              (let ((b:|5,double|* (zalloc)))
+                (aset! b 0
+                       (memzone 1024
+                         (let ((a:|10,double|* (zalloc)))
+                           (aset! a 0 3.5)
+                           (aref a 0))))
+                (let ((c:|9,i32|* (zalloc)))
+                  (aset! c 0 99)
+                  (aref b 0)))))
+
+         (memzone-test1) 3.5)
+
+(xtmtest '(bind-func memzone-test2
+            (lambda ()
+              (memzone 1024
+                (let ((k:|15,double|* (zalloc))
+                      (f (lambda (fa:|15,double|*)
+                           (memzone 1024
+                             (let ((a:|10,double|* (zalloc))
+                                   (i 0))
+                               (dotimes (i 10)
+                                 (aset! a i (* (aref fa i) (random))))
+                               a)))))
+                  (f k)))))
+
+         (memzone-test2))
+
+(xtmtest '(bind-func memzone-test3
+            (lambda ()
+              (let ((v (memzone-test2))
+                    (i 0))
+                (dotimes (i 10) (printf "%lld:%f\n" i (aref v i))))))
+
+         (memzone-test3)) ;; should print all 0.0's
+
+(xtmtest '(bind-func memzone-test4
+            (lambda ()
+              (memzone 1024 (* 44100 10)
+                       (let ((a:|5,double|* (alloc)))
+                         (aset! a 0 5.5)
+                         (aref a 0)))))
+
+         (memzone-test4) 5.50000)
+
+;;
+;; Large allocation of memory on BUILD (i.e. when the closure is created)
+;; requires an optional argument (i.e. an amount of memory to allocate
+;; specifically for closure creation)
+;;
+;; This memory is automatically free'd whenever you recompile the closure
+;; (it will be destroyed and replaced by a new allocation of the
+;;  same amount or whatever new amount you have allocated for closure
+;;  compilation)
+;;
+(xtmtest '(bind-func closure-zalloc-test 1000000
+            (let ((k:|100000,double|* (zalloc)))
+              (lambda ()
+                (aset! k 0 1.0)
+                (aref k 0))))
+
+         (closure-zalloc-test 1000000))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Ad-Hoc Polymorphism
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; extempore supports ad-hoc polymorphism
+;; at some stage in the future this will
+;; be implicit - but for the moment
+;; it is explicitly defined using bind-poly
+
+;; ad-hoc polymorphism allows you to provide
+;; different specialisations depending on
+;; type.  In other words, a single 'name'
+;; can be bound to multiple function
+;; implementations each with a uniqute
+;; type.
+
+
+;; poly variables can be for functions of
+;; mixed argument lengths
+;;
+;; so for example:
+(bind-func poly-test4
+  (lambda (a:i8*)
+    (printf "%s\n" a)))
+
+(bind-func poly-test5
+  (lambda (a:i8* b:i8*)
+    (printf "%s %s\n" a b)))
+
+(bind-func poly-test6
+  (lambda (a:i8* b:i8* c:i8*)
+    (printf "%s %s %s\n" a b c)))
+
+;; bind these three functions to poly 'print'
+(bind-poly testprint poly-test4)
+(bind-poly testprint poly-test5)
+(bind-poly testprint poly-test6)
+
+(xtmtest '(bind-func poly-test7
+            (lambda ()
+              (testprint "extempore's")
+              (testprint "extempore's" "polymorphism")
+              (testprint "extempore's" "polymorphism" "rocks")))
+
+         (poly-test7))
+
+;; polys can Also specialize
+;; on the return type
+(bind-func poly-test8
+  (lambda (a:double)
+    (* a a)))
+
+(bind-func poly-test9
+  (lambda (a:double)
+    (dtoi64 (* a a))))
+
+(bind-poly sqrd poly-test8)
+(bind-poly sqrd poly-test9)
+
+;; specialize on [i64,double]*
+;;
+(xtmtest '(bind-func poly-test10:[i64,double]*
+            (lambda (a)
+              (+ 1 (sqrd a))))
+         (poly-test10 5.0))
+
+;; specialize on [double,doube]*
+(xtmtest '(bind-func poly-test11:[double,double]*
+            (lambda (a)
+              (+ 1.0 (sqrd a))))
+
+         (poly-test11 5.0))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; a little test for zone cleanup
+;;
+(bind-func MyLittleCleanupTest
+  (lambda ()
+    (let ((tmp2:i8* (alloc 8)))
+      (cleanup (println "Clean up before leaving zone!"))
+      tmp2)))
+
+(xtmtest '(bind-func cleanup-test
+            (lambda ()
+              (letz ((tmp:i8* (alloc 8))
+                     (t2 (MyLittleCleanupTest)))
+                (begin
+                  (println "In Zone ...")
+                  1))
+              (println "Out of zone ...")
+              void))
+
+         (cleanup-test))
+
+;;;;;;;;;;;;;;;;;;
+;; vector types
+
+;; (bind-func vector-test1
+;;   (lambda ()
+;;     (let ((v1:/4,float/* (alloc))
+;; 	  (v2:/4,float/* (alloc))
+;; 	  (v3:/4,float/* (alloc)))
+;;       (vfill! v1 4.0 3.0 2.0 1.0)
+;;       (vfill! v2 1.0 2.0 3.0 4.0)
+;;       (vfill! v3 5.0 5.0 5.0 5.0)
+;;       (let ((v4 (* v1 v2))
+;; 	    (v5 (> v3 v4))) ;; unforunately vector conditionals don't work!
+;; 	(printf "mul:%f:%f:%f:%f\n" (ftod (vref v4 0)) (ftod (vref v4 1)) (ftod (vref v4 2)) (ftod (vref v4 3)))
+;; 	(printf "cmp:%d:%d:%d:%d\n" (i1toi32 (vref v5 0)) (i1toi32 (vref v5 1)) (i1toi32 (vref v5 2)) (i1toi32 (vref v5 3)))
+;; 	void))))
+
+;; (test-xtfunc (vector-test1))
+
+(bind-func vector-test2
+  (lambda ()
+    (let ((v1:/4,float/* (alloc))
+	  (v2:/4,float/* (alloc)))
+      (vfill! v1 1.0 2.0 4.0 8.0)
+      (vfill! v2 2.0 2.5 2.25 2.125)
+      (* v1 v2))))
+
+(xtmtest '(bind-func vector-test3
+            (lambda ()
+              (let ((a (vector-test2)))
+                (printf "%f:%f:%f:%f\n"
+                        (ftod (vref a 0))
+                        (ftod (vref a 1))
+                        (ftod (vref a 2))
+                        (ftod (vref a 3)))
+                void)))
+
+         (vector-test3))
+
+;; vectorised sine func
+(bind-func vsinf4
+  (let ((p:/4,float/* (alloc))
+        (b:/4,float/* (alloc))
+        (c:/4,float/* (alloc))
+        (f1:/4,float/* (alloc))
+        (f2:/4,float/* (alloc))
+        (i:i32 0)
+        (p_ 0.225)
+        (b_ (dtof (/ 4.0 3.1415)))
+        (c_ (dtof (/ -4.0 (* 3.1415 3.1415)))))
+    (dotimes (i 4) (vset! p i p_) (vset! b i b_) (vset! c i c_))
+    (lambda (x:/4,float/)
+      ;; no SIMD for abs yet!
+      (dotimes (i 4) (vset! f1 i (fabs (vref x i))))
+      (let ((y (+ (* b x) (* c x f1))))
+        ;; no SIMD for abs yet!
+        (dotimes (i 4) (vset! f2 i (fabs (vref y i))))
+        (+ (* p (- (* y f2) y)) y)))))
+
+(bind-func vcosf4
+  (let ((p:/4,float/* (alloc))
+	(b:/4,float/* (alloc))
+	(c:/4,float/* (alloc))
+	(d:/4,float/* (alloc))
+	(f1:/4,float/* (alloc))
+	(f2:/4,float/* (alloc))
+	(i:i32 0)
+	(p_ 0.225)
+	(d_ (dtof (/ 3.1415 2.0)))
+	(b_ (dtof (/ 4.0 3.1415)))
+	(c_ (dtof (/ -4.0 (* 3.1415 3.1415)))))
+    (dotimes (i 4)
+      (vset! p i p_) (vset! b i b_) (vset! c i c_) (vset! d i d_))
+    (lambda (x:/4,float/)
+      ;; offset x for cos
+      (set! x (+ x d))
+      ;; no SIMD for abs yet!
+      (dotimes (i 4) (vset! f1 i (fabs (vref x i))))
+      (let ((y (+ (* b x) (* c x f1))))
+	;; no SIMD for abs yet!
+	(dotimes (i 4) (vset! f2 i (fabs (vref y i))))
+	(+ (* p (- (* y f2) y)) y)))))
+
+
+(xtmtest '(bind-func vector-test4
+            (lambda ()
+              (let ((a:/4,float/* (alloc)))
+                (vfill! a 0.1 0.2 0.3 0.4)
+                (let ((b (vsinf4 (pref a 0)))
+                      (c (vcosf4 (pref a 0))))
+                  (printf "precision inaccuracy is expected:\n")
+                  (printf " sinf:\t%f,%f,%f,%f\n"
+                          (ftod (sin 0.1:f))
+                          (ftod (sin 0.2:f))
+                          (ftod (sin 0.3:f))
+                          (ftod (sin 0.4:f)))
+                  (printf "vsinf:\t%f,%f,%f,%f\n"
+                          (ftod (vref b 0))
+                          (ftod (vref b 1))
+                          (ftod (vref b 2))
+                          (ftod (vref b 3)))
+                  (printf " cosf:\t%f,%f,%f,%f\n"
+                          (ftod (cos 0.1:f))
+                          (ftod (cos 0.2:f))
+                          (ftod (cos 0.3:f))
+                          (ftod (cos 0.4:f)))
+                  (printf "vcosf:\t%f,%f,%f,%f\n"
+                          (ftod (vref c 0))
+                          (ftod (vref c 1))
+                          (ftod (vref c 2))
+                          (ftod (vref c 3)))
+                  void))))
+
+         (vector-test4))
+
+;; test the call-as-xtlang macro
+
+;; make sure it'll handle multiple body forms
+(xtmtest-result (call-as-xtlang (println 1) (println 2) 5)
+                5)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; test globalvar as closure
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(bind-func testinc
+  (lambda (incr:i64)
+    (lambda (x:i64)
+      (+ x incr))))
+
+(bind-val GlobalInc [i64,i64]* (testinc 2))
+
+(xtmtest '(bind-func ginc
+            (lambda ()
+              (GlobalInc 5)))
+         (ginc) 7)
+                       
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syntax highlighting tests ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; these don't return any values, they're visual tests---do they look
+;; right?
+
+(bind-func hl_test1a:[i32,double,|4,i32|**]* 4000
+  "docstring"
+  (lambda (a b)
+    (printf "done\n")))
+
+(bind-func hl_test1b:[i32]*
+  (lambda ()
+    (let ((i:i32 6))
+      (printf "done\n"))))
+
+(bind-val hl_test2 <i32,i32>)
+(bind-val hl_test3 |4,i8|)
+(bind-val hl_test4 double* 10)
+(bind-val hl_test5 i8* "teststr")
+
+(bind-type hl_test_type <i64>)
+
+(println '(bind-lib testlib testfn [i32,i32]*))
+
+;; (and 4 5)
+;; (bind-val hl_test4 double* 10)
+;; (bind-type hl_test_type <i64> "docstring")
+;; (bind-lib testlib testfn [i32,i32]*)