klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

ffi-win32.k (2547B)

      1 ;;
      2 ;; Windows API FFI example
      3 ;; See ffi.k for general info.
      4 ;;
      5 ;; usage:
      6 ;;  1) compile and install libffi 3.0.10
      7 ;;  2) set PATH correctly so libffi-5.dll can be found
      8 ;;  3) compile klisp: make mingw USE_LIBFFI=1
      9 ;;  4) run test script: ....\src> klisp examples/ffi-win32.k
     10 ;;
     11 
     12 ($define! kernel32 (ffi-load-library "kernel32"))
     13 ($define! abi "FFI_STDCALL")
     14 
     15 ($define! DWORD "uint32")
     16 ($define! BOOL "sint")
     17 
     18 ($define! dword-void (ffi-make-call-interface abi DWORD ()))
     19 ($define! u64-void (ffi-make-call-interface abi "uint64" ()))
     20 
     21 ($define! GetLastError (ffi-make-applicative kernel32 "GetLastError" dword-void))
     22 ($define! GetTickCount (ffi-make-applicative kernel32 "GetTickCount" dword-void))
     23 ($define! GetTickCount64 (ffi-make-applicative kernel32 "GetTickCount64" u64-void))
     24 
     25 (display "Testing GetTickCount(), GetTickCount64() ... ")
     26 (write (list (GetTickCount) (GetTickCount64)))
     27 (newline)
     28 
     29 ($define! (DWORD-size DWORD-alignment DWORD-ref DWORD-set!)
     30   (ffi-type-suite DWORD))
     31 
     32 ($define! (charptr-size charptr-alignment charptr-ref charptr-set!)
     33   (ffi-type-suite "string"))
     34 
     35 ($define! blob->list
     36   ($lambda (blob index len)
     37     ($if (>? len 0)
     38       (cons
     39         (blob-u8-ref blob index)
     40         (blob->list blob (+ 1 index) (- len 1)))
     41       ())))
     42 
     43 ($define! blob->string
     44   ($lambda (blob offset len)
     45     (list->string (map integer->char (blob->list blob offset len)))))
     46 
     47 ($define! advapi32 (ffi-load-library "advapi32"))
     48 
     49 ($define! GetUserName
     50   ($let
     51     ( (win32-GetUserName (ffi-make-applicative advapi32 "GetUserNameA"
     52          (ffi-make-call-interface abi BOOL (list "pointer" "pointer"))))
     53       ((DWORD-size DWORD-alignment DWORD-ref DWORD-set!)
     54         (ffi-type-suite DWORD)))
     55     ($lambda ()
     56       ($let ((buffer (make-blob 256)) (lenbuf (make-blob 4)))
     57         (DWORD-set! lenbuf (blob-length buffer))
     58         (win32-GetUserName buffer lenbuf)
     59 	(blob->string buffer 0 (- (DWORD-ref lenbuf) 1))))))
     60 
     61 (display "Testing GetUserName()...")
     62 (write (GetUserName))
     63 (newline)
     64 
     65 ($define! user32 (ffi-load-library "user32"))
     66 
     67 ($define! HWND "pointer")
     68 ($define! UINT "uint32")
     69 ($define! MB_OK 0)
     70 
     71 ($define! MessageBox
     72   ($let
     73     ( (win32-MessageBox (ffi-make-applicative user32 "MessageBoxA"
     74         (ffi-make-call-interface abi "sint" (list HWND "string" "string" UINT)))))
     75     ($lambda (text caption)	
     76       (win32-MessageBox () text caption MB_OK))))
     77 
     78 (display "Testing MessageBox()...")
     79 (MessageBox "FFI test" "klisp")
     80 (display "done.")
     81 (newline)