1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
;; @module win32demo.lsp
;; @description Event loop demo
;; @author Cyril Slobin
;; @location http://slobin.pp.ru/newlisp/win32demo.lsp
;; @version $Id: win32demo.lsp,v 1.4 2010/06/10 02:14:08 slobin Exp $
; see also: http://slobin.livejournal.com/339071.html ; added by LM
(println "win32demo")
(define (import-list library flist)
(dolist (fname flist) (import library (string fname))))
(define-macro (@setq %var %value)
(set %var (eval %value))
(println %var " " (eval %var)))
(import-list "kernel32" '(GetModuleHandleA GetConsoleWindow))
(import-list "user32" '(PostQuitMessage DefWindowProcA))
(import-list "user32" '(LoadCursorA RegisterClassA CreateWindowExA))
(import-list "user32" '(ShowWindow UpdateWindow))
(import-list "user32" '(GetMessageA TranslateMessage DispatchMessageA))
(setq WM_CREATE 1 WM_DESTROY 2 WM_CHAR 0x102 WM_LBUTTONDOWN 0x201)
(setq IDC_ARROW 0x7F00 CS_VREDRAW 1 CS_HREDRAW 2 COLOR_WINDOW 5)
(setq WS_OVERLAPPEDWINDOW 0xCF0000 HWND_MESSAGE -3 SW_SHOWDEFAULT 10)
(@setq hinstance (GetModuleHandleA 0))
(@setq hconsole (GetConsoleWindow))
(@setq cursor (LoadCursorA 0 IDC_ARROW))
(define (window-callback-function hwnd message wparam lparam)
(cond
((= message WM_CREATE) (println "created") 0)
((= message WM_LBUTTONDOWN) (println "click!") 0)
((= message WM_CHAR) (println (format "char %c" wparam)) 0)
((= message WM_DESTROY) (println "destroyed") (PostQuitMessage 0) 0)
(true (DefWindowProcA hwnd message wparam lparam))))
(setq wndproc (callback 0 'window-callback-function))
(setq classname "newlisp class")
(setq wc (pack (dup "ld" 10)
(| CS_HREDRAW CS_VREDRAW) ; style
wndproc ; lpfnWndProc
0 ; cbClsExtra
0 ; cbWndExtra
hinstance ; hInstance
0 ; hIcon
cursor ; hCursor
(+ COLOR_WINDOW 1) ; hbrBackground
0 ; lpszMenuName
classname ; lpszClassName
))
(@setq hwc (RegisterClassA wc))
(@setq hwnd (CreateWindowExA
0 ; dwExStyle
"newlisp class" ; lpClassName
"newlisp window" ; lpWindowName
WS_OVERLAPPEDWINDOW ; dwStyle
80 60 640 480 ; x y w h
0 ; hwndParent
0 ; hMenu
hinstance ; hInstance
0 ; hParam
))
; hconsole and HWND_MESSAGE are other useful values for hwndParent
(ShowWindow hwnd SW_SHOWDEFAULT)
(UpdateWindow hwnd)
(setq msg (pack "n28"))
; when using an IME window for input set hwnd to 0, to receive all messages
; in the thread, not only from the window in hwnd (added in 10.7.3)
;(until (member (GetMessageA msg hwnd 0 0) '(0 -1))
(until (member (GetMessageA msg 0 0 0) '(0 -1))
(TranslateMessage msg)
(DispatchMessageA msg))
(println "the end")
(exit)
|
