diff --git a/contrib/win32/compile-and-run.lsp b/contrib/win32/compile-and-run.lsp index 66bf14a0b..6fa2b40ca 100644 --- a/contrib/win32/compile-and-run.lsp +++ b/contrib/win32/compile-and-run.lsp @@ -14,5 +14,10 @@ (let ((c::*ld-format* (concatenate 'string c::*ld-format* " user32.lib kernel32.lib gdi32.lib comdlg32.lib"))) (compile-file "win32.lisp" :c-file t)) -(load "txtedit.lsp") +(load "txtedit.lisp") +(format t " + +** Run (WIN32::TXTEDIT [FILENAME]) to launch the application example. + +") diff --git a/contrib/win32/txtedit.lisp b/contrib/win32/txtedit.lisp index 6982991d3..c6ae292bd 100644 --- a/contrib/win32/txtedit.lisp +++ b/contrib/win32/txtedit.lisp @@ -10,6 +10,8 @@ ;;; SAMPLE TEXT EDITOR APPLICATION USING THE WIN32 API ;;; +(require "WIN32" "win32") + (in-package "WIN32") (defvar *txtedit-class-registered* nil) @@ -25,26 +27,68 @@ (defparameter +IDM_SAVE+ 102) (defparameter +IDM_SAVEAS+ 103) (defparameter +IDM_NEW+ 104) +(defparameter +IDM_CUT+ 105) +(defparameter +IDM_COPY+ 106) +(defparameter +IDM_PASTE+ 107) +(defparameter +IDM_UNDO+ 108) +(defparameter +IDM_SELECTALL+ 109) +(defparameter +IDM_ABOUT+ 110) (defparameter +EDITCTL_ID+ 1000) +(defparameter *txtedit-about-text* +"Text Editor for ECL. + +This application serves as a demonstrator +for the WIN32 FFI interface of ECL. + +Copyright (C), Michael Goffioul, 2005.") + (defun create-menus () ;(return *NULL*) (let ((bar (createmenu)) (file_pop (createpopupmenu)) - (edit_pop (createpopupmenu))) + (edit_pop (createpopupmenu)) + (help_pop (createpopupmenu))) ;; File menu - (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "File") - (appendmenu file_pop *MF_STRING* +IDM_NEW+ "New") - (appendmenu file_pop *MF_STRING* +IDM_OPEN+ "Open...") + (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "&File") + (appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New Ctrl+N") + (appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open... Ctrl+O") (appendmenu file_pop *MF_SEPARATOR* 0 "") - (appendmenu file_pop *MF_STRING* +IDM_SAVE+ "Save") - (appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save As...") + (appendmenu file_pop *MF_STRING* +IDM_SAVE+ "&Save Ctrl+S") + (appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save &As...") (appendmenu file_pop *MF_SEPARATOR* 0 "") - (appendmenu file_pop *MF_STRING* +IDM_QUIT+ "Exit") + (appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q") ;; Edit menu - (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "Edit") + (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "&Edit") + (appendmenu edit_pop *MF_STRING* +IDM_UNDO+ "&Undo Ctrl+Z") + (appendmenu edit_pop *MF_SEPARATOR* 0 "") + (appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut Ctrl+X") + (appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C") + (appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V") + (appendmenu edit_pop *MF_SEPARATOR* 0 "") + (appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A") + ;; Help menu + (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam help_pop) "&Help") + (appendmenu help_pop *MF_STRING* +IDM_ABOUT+ "&About...") bar)) +(defun create-accels () + (macrolet ((add-accel (key ID accTable pos) + `(with-foreign-object (a 'ACCEL) + (setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*)) + (setf (get-slot-value a 'ACCEL 'key) (char-code ,key)) + (setf (get-slot-value a 'ACCEL 'cmd) ,ID) + (setf (deref-array ,accTable '(* ACCEL) ,pos) a)))) + (let ((accTable (allocate-foreign-object 'ACCEL 5))) + (add-accel #\Q +IDM_QUIT+ accTable 0) + (add-accel #\N +IDM_NEW+ accTable 1) + (add-accel #\O +IDM_OPEN+ accTable 2) + (add-accel #\S +IDM_SAVE+ accTable 3) + (add-accel #\A +IDM_SELECTALL+ accTable 4) + (prog1 + (createacceleratortable accTable 5) + (free-foreign-object accTable))))) + (defun is-default-title (hwnd) (string= (string-right-trim "*" (getwindowtext hwnd)) *txtedit-default-title*)) @@ -145,6 +189,19 @@ ((= ctrl-ID +IDM_NEW+) (setwindowtext *txtedit-edit* "") (setwindowtext hwnd *txtedit-default-title*)) + ((= ctrl-ID +IDM_CUT+) + (sendmessage *txtedit-edit* *WM_CUT* 0 0)) + ((= ctrl-ID +IDM_COPY+) + (sendmessage *txtedit-edit* *WM_COPY* 0 0)) + ((= ctrl-ID +IDM_PASTE+) + (sendmessage *txtedit-edit* *WM_PASTE* 0 0)) + ((= ctrl-ID +IDM_UNDO+) + (unless (= (sendmessage *txtedit-edit* *EM_CANUNDO* 0 0) 0) + (sendmessage *txtedit-edit* *EM_UNDO* 0 0))) + ((= ctrl-ID +IDM_SELECTALL+) + (sendmessage *txtedit-edit* *EM_SETSEL* 0 -1)) + ((= ctrl-ID +IDM_ABOUT+) + (messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*))) (t ))) 0) @@ -173,11 +230,13 @@ *WS_OVERLAPPEDWINDOW* *CW_USEDEFAULT* *CW_USEDEFAULT* *txtedit-width* *txtedit-height* - *NULL* (create-menus) *NULL* fname-str))) + *NULL* (create-menus) *NULL* fname-str)) + (accTable (create-accels))) (showwindow w *SW_SHOWNORMAL*) (updatewindow w) - (event-loop) + (event-loop :accelTable accTable :accelMain w) (setq *txtedit-edit* *NULL*) + (destroyacceleratortable accTable) (unless (null-pointer-p fname-str) (free-foreign-object fname-str)) (unregister-txtedit-class) diff --git a/contrib/win32/win32.lisp b/contrib/win32/win32.lisp index cb16a77b5..c6f50f0b7 100644 --- a/contrib/win32/win32.lisp +++ b/contrib/win32/win32.lisp @@ -35,14 +35,18 @@ (define-win-constant *WM_CLOSE* "WM_CLOSE") (define-win-constant *WM_COMMAND* "WM_COMMAND") +(define-win-constant *WM_COPY* "WM_COPY") (define-win-constant *WM_CREATE* "WM_CREATE") +(define-win-constant *WM_CUT* "WM_CUT") (define-win-constant *WM_DESTROY* "WM_DESTROY") (define-win-constant *WM_GETFONT* "WM_GETFONT") (define-win-constant *WM_GETMINMAXINFO* "WM_GETMINMAXINFO") +(define-win-constant *WM_PASTE* "WM_PASTE") (define-win-constant *WM_QUIT* "WM_QUIT") (define-win-constant *WM_SETFOCUS* "WM_SETFOCUS") (define-win-constant *WM_SETFONT* "WM_SETFONT") (define-win-constant *WM_SIZE* "WM_SIZE") +(define-win-constant *WM_UNDO* "WM_UNDO") (define-win-constant *WS_BORDER* "WS_BORDER") (define-win-constant *WS_CHILD* "WS_CHILD") @@ -73,6 +77,9 @@ (define-win-constant *ES_LEFT* "ES_LEFT") (define-win-constant *ES_MULTILINE* "ES_MULTILINE") +(define-win-constant *EM_CANUNDO* "EM_CANUNDO") +(define-win-constant *EM_SETSEL* "EM_SETSEL") +(define-win-constant *EM_UNDO* "EM_UNDO") (define-win-constant *EN_CHANGE* "EN_CHANGE") (define-win-constant *SW_SHOWNORMAL* "SW_SHOWNORMAL") @@ -115,6 +122,14 @@ (define-win-constant *OFN_PATHMUSTEXIST* "OFN_PATHMUSTEXIST") (define-win-constant *OFN_READONLY* "OFN_READONLY") +(define-win-constant *FVIRTKEY* "FVIRTKEY") +(define-win-constant *FNOINVERT* "FNOINVERT") +(define-win-constant *FSHIFT* "FSHIFT") +(define-win-constant *FCONTROL* "FCONTROL") +(define-win-constant *FALT* "FALT") + +(define-win-constant *VK_F1* "VK_F1") + (defconstant *NULL* (make-null-pointer :pointer-void)) ;; Windows structures @@ -187,6 +202,7 @@ (nMaxFileTitle :unsigned-int) (lpstrInitialDir LPCSTR) (lpstrTitle LPCSTR) (Flags :unsigned-int) (nFileOffset :unsigned-short) (nFileExtension :unsigned-short) (lpstrDefExt LPCSTR) (lCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR) (pvReserved :pointer-void) (dwReserved :unsigned-int) (FlagsEx :unsigned-int)) +(def-struct ACCEL (fVirt :byte) (key :unsigned-short) (cmd :unsigned-short)) ;; Windows functions @@ -298,16 +314,23 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara (def-function ("CreateMenu" createmenu) nil :returning HANDLE) (def-function ("CreatePopupMenu" createpopupmenu) nil :returning HANDLE) (def-function ("AppendMenu" appendmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (uIDNewItem :unsigned-int) (lpNewItem LPCSTR)) :returning :int) +(def-function ("CreateAcceleratorTable" createacceleratortable) ((lpaccl (* ACCEL)) (cEntries :int)) :returning HANDLE) +(def-function ("TranslateAccelerator" translateaccelerator) ((hWnd HANDLE) (hAccTable HANDLE) (lpMsg (* MSG))) :returning :int) +(def-function ("DestroyAcceleratorTable" destroyacceleratortable) ((hAccTable HANDLE)) :returning :int) -(defun event-loop () +(defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*)) (with-foreign-object (msg 'MSG) (loop for bRet = (getmessage msg *NULL* 0 0) when (= bRet 0) return bRet if (= bRet -1) do (error "GetMessage failed!!!") else - do (translatemessage msg) - and do (dispatchmessage msg)))) + do (or (and (not (null-pointer-p accelTable)) + (not (null-pointer-p accelMain)) + (/= (translateaccelerator accelMain accelTable msg) 0)) + (progn + (translatemessage msg) + (dispatchmessage msg)))))) (defun y-or-no-p (&optional control &rest args) (let ((s (coerce (apply #'format nil control args) 'simple-string))) @@ -333,6 +356,8 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara (unless (= (funcall dlgfn ofn) 0) (pathname (string-trim (string #\Null) fn))))))) +(provide "WIN32") + ;;; Test code (defconstant *HELLO_ID* 100)