mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-05 00:40:48 -08:00
- Add support for accelerators
- Add "About" dialog - Provides small load info and required dependencies
This commit is contained in:
goffioul
parent
8e041f10b9
commit
ec527008aa
3 changed files with 103 additions and 14 deletions
|
|
@ -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.
|
||||
|
||||
")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue