Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Added ffi-utils.sld.

            1  +	
            2  +(library (ffi-utils)
            3  +	 (export define-enumeration* define-function define-flags make-flags flags flags-name flags-alist flags-indexer flags-ref-maker flags-decode-maker)
            4  +	 (import (chezscheme))
            5  +
            6  +	 
            7  + ;; Uses make-enumeration to define an enum with the following:
            8  + ;; function (name x) -> index
            9  + ;; function (name-ref index) -> symbol
           10  + ;; variable name-enum  -> #>enum-set>
           11  + ;; usage: (define-enumeration* NAME (tag1 tag2 tag3 ...))
           12  +
           13  + (define-syntax define-enumeration*
           14  +   (lambda (x)
           15  +     (define gen-id
           16  +       (lambda (template-id . args)
           17  +	 (datum->syntax
           18  +	  template-id
           19  +	  (string->symbol
           20  +	   (apply
           21  +	    string-append
           22  +	    (map (lambda (x)
           23  +		   (if (string? x) x (symbol->string (syntax->datum x))))
           24  +		 args))))))
           25  +     (syntax-case x ()
           26  +       [(_ name (l ...))
           27  +	(with-syntax ([base-name (gen-id #'name "" #'name)]
           28  +		      [enum-name (gen-id #'name #'name "-enum")]
           29  +		      [ref-name (gen-id #'name #'name "-ref")])
           30  +		     #'(begin
           31  +			 (define enum-name (make-enumeration '(l ...)))
           32  +			 (define base-name
           33  +			   (lambda (x)
           34  +			     (let ([r ((enum-set-indexer enum-name) x)])
           35  +			       (if r
           36  +				   r
           37  +				   (assertion-violation 'enum-name
           38  +							"symbol not found"
           39  +							x)))))
           40  +			 (define ref-name
           41  +			   (lambda (index)
           42  +			     (list-ref (enum-set->list enum-name) index)))))])))
           43  +
           44  +;; TODO: WRITE SOME AUTOMATED TYPE CHECKS/CONVERSIONS
           45  +
           46  + (define-syntax define-function
           47  +   (lambda (x)
           48  +     (syntax-case x ()
           49  +       ; WITH NAME+TYPE ARGUMENTS , this is nice because you can catch the argument name if some error happens
           50  +       ; In any case it is handy to have the argument names also in the scheme declarations for quick reference.
           51  +       ; We could also ignore them in expansion time
           52  +       [(_ name ((arg-name arg-type) ...) ret)
           53  +	#'(define (name arg-name ...)
           54  +	      (foreign-procedure (symbol->string name) (arg-type ...) ret))]
           55  +
           56  +       ; WITH ONLY ARGUMENT TYPES
           57  +       [(_ name (args ...) ret)
           58  +	#'(define name
           59  +	    (foreign-procedure (symbol->string 'name) (args ...) ret))])))
           60  +
           61  +
           62  +;DEFINE FLAGS:
           63  +;USAGE: (define-flags flags-name (name value) ...)
           64  +; name will be escaped
           65  +; value will be evaluated
           66  +; the following functions will be defined:
           67  +; <flags-name>-flags  -> record describing the flags
           68  +; <flags-name>      -> takes a list of flags and returns a number that correspond 
           69  +;                       to the bitwise or of the corresponding values
           70  +; <flags-name>-ref  -> takes a number as argument and returns the flag name
           71  +; <flags-name>-decode -> takes a number and returns a list of flags that match to create that value
           72  +; you can use also (flags-alist <flags-name>-flags) to get the alist of flags
           73  +; and (flags-name <flags-name>-flags) to get the name
           74  +
           75  +;EXAMPLE: (define-flag colors (red 1) (blue 2) (green 4))
           76  +;> color-flags -> #[#{flags ew79exa0q5qi23j9k1faa8-51} color ((red . 1) (blue . 2) (green . 4))]
           77  +;> (color 'blue) -> 2
           78  +;> (color 'red 'blue) -> 3
           79  +;> (color 'black) -> Exception in color: symbol not found with irritant (black)
           80  +;> (color-ref 1) -> red
           81  +;> (color-ref 5) -> #f
           82  +;> (color-decode 3) -> (red blue)
           83  +;> (color-decode 16) -> ()
           84  +;> (color-decode 6) -> (blue green) !!! ATTENTION
           85  +;> (flags-alist color-flags) -> ((red . 1) (blue . 2) (green . 4))
           86  +;> (flags-name color-flags) -> color
           87  +
           88  +;; TODO, what to do for value 0?
           89  +
           90  + (define-syntax define-flags
           91  +   (lambda (x)
           92  +     (define gen-id
           93  +       (lambda (template-id . args)
           94  +	 (datum->syntax
           95  +	  template-id
           96  +	  (string->symbol
           97  +	   (apply
           98  +	    string-append
           99  +	    (map (lambda (x)
          100  +		   (if (string? x) x (symbol->string (syntax->datum x))))
          101  +		 args))))))
          102  +     (syntax-case x ()
          103  +       [(_ name (k  v) ...)
          104  +	(with-syntax ([base-name (gen-id #'name "" #'name)]
          105  +		      [flags-name (gen-id #'name #'name "-flags")]
          106  +		      [ref-name (gen-id #'name #'name "-ref")]
          107  +		      [decode-name (gen-id #'name #'name "-decode")])
          108  +		     #'(begin
          109  +			 (define flags-name (make-flags 'name (list (cons 'k v) ...)))
          110  +			 (define base-name (flags-indexer flags-name))
          111  +			 (define ref-name (flags-ref-maker flags-name))
          112  +			 (define decode-name (flags-decode-maker flags-name))))])))
          113  +
          114  + (define-record flags (name alist))
          115  + 
          116  + (define (flags-indexer  flags)
          117  +   (lambda (name . more-names)
          118  +     (let ([names (append (list name) more-names)])
          119  +       (let loop ([f names] [result 0])
          120  +	 (if (null? f) result
          121  +	   (let ([r (assq (car f) (flags-alist flags))])
          122  +	     ;(printf "r: ~d flags: ~d f: ~d\n" r flags f)
          123  +	     (if (not r) (assertion-violation (flags-name flags) "symbol not found" f)
          124  +		 (loop (cdr f) (logor result (cdr r))))))))))
          125  +
          126  + (define (flags-ref-maker flags)
          127  +   (lambda (index)
          128  +     (let ([p (find (lambda (x) (equal? index (cdr x))) (flags-alist flags))])
          129  +       (if p (car p) p))))
          130  +
          131  +;; FIXME: WHAT TO DO IF VALUES OVERLAP?
          132  +;; AT THE MOMENT RESULT MAYBE NOT WHAT EXPECTED
          133  + (define (flags-decode-maker flags)
          134  +   (lambda (mask)
          135  +     (if (not (number? mask)) (assertion-violation (flags-name flags) "decode: mask must be an integer" mask))
          136  +     (let loop ([l (flags-alist flags)] [result '()])
          137  +       (if (null? l) result
          138  +	   (let ([item (car l)])
          139  +	     (if (zero? (logand (cdr item) mask))
          140  +		 (loop (cdr l) result)
          141  +		 (loop (cdr l) (append result (list (car item))))))))))
          142  + 
          143  + ); library ffi-utils