ADDED   ffi-utils.sld
Index: ffi-utils.sld
==================================================================
--- ffi-utils.sld
+++ ffi-utils.sld
@@ -0,0 +1,143 @@
+	
+(library (ffi-utils)
+	 (export define-enumeration* define-function define-flags make-flags flags flags-name flags-alist flags-indexer flags-ref-maker flags-decode-maker)
+	 (import (chezscheme))
+
+	 
+ ;; Uses make-enumeration to define an enum with the following:
+ ;; function (name x) -> index
+ ;; function (name-ref index) -> symbol
+ ;; variable name-enum  -> #>enum-set>
+ ;; usage: (define-enumeration* NAME (tag1 tag2 tag3 ...))
+
+ (define-syntax define-enumeration*
+   (lambda (x)
+     (define gen-id
+       (lambda (template-id . args)
+	 (datum->syntax
+	  template-id
+	  (string->symbol
+	   (apply
+	    string-append
+	    (map (lambda (x)
+		   (if (string? x) x (symbol->string (syntax->datum x))))
+		 args))))))
+     (syntax-case x ()
+       [(_ name (l ...))
+	(with-syntax ([base-name (gen-id #'name "" #'name)]
+		      [enum-name (gen-id #'name #'name "-enum")]
+		      [ref-name (gen-id #'name #'name "-ref")])
+		     #'(begin
+			 (define enum-name (make-enumeration '(l ...)))
+			 (define base-name
+			   (lambda (x)
+			     (let ([r ((enum-set-indexer enum-name) x)])
+			       (if r
+				   r
+				   (assertion-violation 'enum-name
+							"symbol not found"
+							x)))))
+			 (define ref-name
+			   (lambda (index)
+			     (list-ref (enum-set->list enum-name) index)))))])))
+
+;; TODO: WRITE SOME AUTOMATED TYPE CHECKS/CONVERSIONS
+
+ (define-syntax define-function
+   (lambda (x)
+     (syntax-case x ()
+       ; WITH NAME+TYPE ARGUMENTS , this is nice because you can catch the argument name if some error happens
+       ; In any case it is handy to have the argument names also in the scheme declarations for quick reference.
+       ; We could also ignore them in expansion time
+       [(_ name ((arg-name arg-type) ...) ret)
+	#'(define (name arg-name ...)
+	      (foreign-procedure (symbol->string name) (arg-type ...) ret))]
+
+       ; WITH ONLY ARGUMENT TYPES
+       [(_ name (args ...) ret)
+	#'(define name
+	    (foreign-procedure (symbol->string 'name) (args ...) ret))])))
+
+
+;DEFINE FLAGS:
+;USAGE: (define-flags flags-name (name value) ...)
+; name will be escaped
+; value will be evaluated
+; the following functions will be defined:
+; <flags-name>-flags  -> record describing the flags
+; <flags-name>      -> takes a list of flags and returns a number that correspond 
+;                       to the bitwise or of the corresponding values
+; <flags-name>-ref  -> takes a number as argument and returns the flag name
+; <flags-name>-decode -> takes a number and returns a list of flags that match to create that value
+; you can use also (flags-alist <flags-name>-flags) to get the alist of flags
+; and (flags-name <flags-name>-flags) to get the name
+
+;EXAMPLE: (define-flag colors (red 1) (blue 2) (green 4))
+;> color-flags -> #[#{flags ew79exa0q5qi23j9k1faa8-51} color ((red . 1) (blue . 2) (green . 4))]
+;> (color 'blue) -> 2
+;> (color 'red 'blue) -> 3
+;> (color 'black) -> Exception in color: symbol not found with irritant (black)
+;> (color-ref 1) -> red
+;> (color-ref 5) -> #f
+;> (color-decode 3) -> (red blue)
+;> (color-decode 16) -> ()
+;> (color-decode 6) -> (blue green) !!! ATTENTION
+;> (flags-alist color-flags) -> ((red . 1) (blue . 2) (green . 4))
+;> (flags-name color-flags) -> color
+
+;; TODO, what to do for value 0?
+
+ (define-syntax define-flags
+   (lambda (x)
+     (define gen-id
+       (lambda (template-id . args)
+	 (datum->syntax
+	  template-id
+	  (string->symbol
+	   (apply
+	    string-append
+	    (map (lambda (x)
+		   (if (string? x) x (symbol->string (syntax->datum x))))
+		 args))))))
+     (syntax-case x ()
+       [(_ name (k  v) ...)
+	(with-syntax ([base-name (gen-id #'name "" #'name)]
+		      [flags-name (gen-id #'name #'name "-flags")]
+		      [ref-name (gen-id #'name #'name "-ref")]
+		      [decode-name (gen-id #'name #'name "-decode")])
+		     #'(begin
+			 (define flags-name (make-flags 'name (list (cons 'k v) ...)))
+			 (define base-name (flags-indexer flags-name))
+			 (define ref-name (flags-ref-maker flags-name))
+			 (define decode-name (flags-decode-maker flags-name))))])))
+
+ (define-record flags (name alist))
+ 
+ (define (flags-indexer  flags)
+   (lambda (name . more-names)
+     (let ([names (append (list name) more-names)])
+       (let loop ([f names] [result 0])
+	 (if (null? f) result
+	   (let ([r (assq (car f) (flags-alist flags))])
+	     ;(printf "r: ~d flags: ~d f: ~d\n" r flags f)
+	     (if (not r) (assertion-violation (flags-name flags) "symbol not found" f)
+		 (loop (cdr f) (logor result (cdr r))))))))))
+
+ (define (flags-ref-maker flags)
+   (lambda (index)
+     (let ([p (find (lambda (x) (equal? index (cdr x))) (flags-alist flags))])
+       (if p (car p) p))))
+
+;; FIXME: WHAT TO DO IF VALUES OVERLAP?
+;; AT THE MOMENT RESULT MAYBE NOT WHAT EXPECTED
+ (define (flags-decode-maker flags)
+   (lambda (mask)
+     (if (not (number? mask)) (assertion-violation (flags-name flags) "decode: mask must be an integer" mask))
+     (let loop ([l (flags-alist flags)] [result '()])
+       (if (null? l) result
+	   (let ([item (car l)])
+	     (if (zero? (logand (cdr item) mask))
+		 (loop (cdr l) result)
+		 (loop (cdr l) (append result (list (car item))))))))))
+ 
+ ); library ffi-utils