diff --git a/contrib/win32/lisp-kw.lisp b/contrib/win32/lisp-kw.lisp index 3da3bbfcb8344934b1346f5e3517dc49f8df27dc..08f2dc38da39c57ac1772486e8b95786b68f6070 100644 --- a/contrib/win32/lisp-kw.lisp +++ b/contrib/win32/lisp-kw.lisp @@ -1,6 +1,6 @@ (in-package "WIN32") -(defparameter *txtedit-lisp-kw* +(setq *txtedit-lisp-kw* "* find-method pprint-indent ** find-package pprint-linear *** find-restart pprint-logical-block @@ -339,7 +339,7 @@ *features* *print-miser-width* *terminal-io* *gensym-counter* *print-miser-width* *trace-output*") -(defparameter *txtedit-lisp-kw2* +(setq *txtedit-lisp-kw2* ":abort :from-end :overwrite :adjustable :gensym :predicate :append :host :preserve-whitespace @@ -367,7 +367,7 @@ :escape :output-file :version :external :fill-pointer") -(defparameter *txtedit-decl-forms* +(setq *txtedit-decl-forms* '(defmacro defsetf deftype defun defmethod defgeneric lambda do do* do-all-symbols do-external-symbols do-symbols dotimes let let* flet macrolet labels multiple-value-bind diff --git a/contrib/win32/txtedit.lisp b/contrib/win32/txtedit.lisp index 78537386a785c5905bea304f31462a1693015026..c4a4e0adeb360ef7e9230e3969b9eae9d2011b43 100644 --- a/contrib/win32/txtedit.lisp +++ b/contrib/win32/txtedit.lisp @@ -1,4 +1,5 @@ ;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be) +;;; Copyright (c) 2012, Jean-Claude Beaudoin ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -30,7 +31,7 @@ (defvar *txtedit-findreplace-msg* (registerwindowmessage *FINDMSGSTRING*)) (defstruct txtedit (handle *NULL*) title dirty) -(defvar *txtedit-default-title* "ECL Text Editor") +(defvar *txtedit-default-title* "MKCL Text Editor") (defparameter +IDM_OPEN+ 100) (defparameter +IDM_QUIT+ 101) @@ -55,12 +56,13 @@ (defparameter +TABCTL_ID+ 1001) (defparameter *txtedit-about-text* -"Text Editor for ECL. +"Text Editor for MKCL. This application serves as a demonstrator -for the WIN32 FFI interface of ECL. +for a WIN32 UFFI interface of MKCL. -Copyright (c) 2005, Michael Goffioul.") +Copyright (c) 2005, Michael Goffioul. +Copyright (c) 2012, Jean-Claude Beaudoin, MKCL port.") (defun create-menus () ;(return *NULL*) @@ -125,15 +127,15 @@ Copyright (c) 2005, Michael Goffioul.") (defun update-caption (hwnd) (let ((str (tab-name (current-editor) #'identity nil))) - (setwindowtext hwnd (format nil "~@[~A - ~]~A~C" str *txtedit-default-title* #\Null)))) + (setwindowtext hwnd (cstring (format nil "~@[~A - ~]~A~C" str *txtedit-default-title* #\Null))))) (defun current-editor () (nth *txtedit-current* *txtedit-edit*)) (defun tab-name (editor &optional (fun #'file-namestring) (final-char #\Null)) - (format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]" - (and (txtedit-title editor) (funcall fun (txtedit-title editor))) - (txtedit-dirty editor) final-char)) + (cstring (format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]" + (and (txtedit-title editor) (funcall fun (txtedit-title editor))) + (txtedit-dirty editor) final-char))) (defun update-tab (idx) (let ((editor (nth idx *txtedit-edit*))) @@ -161,8 +163,8 @@ Copyright (c) 2005, Michael Goffioul.") (let ((editor (nth idx *txtedit-edit*))) (if (or (null (txtedit-dirty editor)) (and (set-current-editor idx hwnd) nil) - (let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C" - (txtedit-title editor) #\Null) + (let ((m-result (messagebox hwnd (cstring (format nil "Do you want to save changes?~@[~2%~A~%~]~C" + (txtedit-title editor) #\Null)) "Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*)))) (cond ((= m-result *IDNO*) t) ((= m-result *IDCANCEL*) nil) @@ -181,6 +183,10 @@ Copyright (c) 2005, Michael Goffioul.") (ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int)) +(defvar *txtedit-lisp-kw* nil) +(defvar *txtedit-lisp-kw2* nil) +(defvar *txtedit-decl-forms* nil) + (defun init-scintilla-component (hnd) ;; Set LISP lexer (sendmessage hnd 4001 21 0) @@ -345,7 +351,7 @@ Copyright (c) 2005, Michael Goffioul.") new-editor))) (defun unix2dos (str) - (let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0)) + (let ((new-str (make-array (length str) :element-type 'base-char :adjustable t :fill-pointer 0)) (return-p nil) c) (with-output-to-string (out new-str) @@ -363,7 +369,7 @@ Copyright (c) 2005, Michael Goffioul.") (if pn (with-open-file (f pn) (let* ((len (file-length f)) - (buf (make-string len))) + (buf (make-string len :element-type 'base-char))) (read-sequence buf f) (setwindowtext (txtedit-handle (current-editor)) (unix2dos buf)) (setf (txtedit-dirty (current-editor)) nil) @@ -483,6 +489,7 @@ Copyright (c) 2005, Michael Goffioul.") (2 (let* ((wMenu (make-handle wparam)) (nPos (loword lparam)) (nItems (getmenuitemcount wMenu))) + (declare (ignore nPos)) (dotimes (j (- nItems 2)) (deletemenu wMenu 2 *MF_BYPOSITION*)) (when *txtedit-edit* @@ -502,6 +509,7 @@ Copyright (c) 2005, Michael Goffioul.") (let ((ctrl-ID (loword wparam)) (nmsg (hiword wparam)) (hnd (make-pointer lparam 'HANDLE))) + (declare (ignorable hnd)) (cond ((= ctrl-ID +EDITCTL_ID+) (cond ((= nmsg *EN_CHANGE*) (unless (txtedit-dirty (current-editor)) diff --git a/contrib/win32/win32.lisp b/contrib/win32/win32.lisp index 9794c784577e9109e7a3d0fe94426b7dd98ae141..6d7f5d5f51fd80063fe45773a66fe45e25b265ec 100644 --- a/contrib/win32/win32.lisp +++ b/contrib/win32/win32.lisp @@ -1,4 +1,5 @@ ;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be) +;;; Copyright (c) 2012, Jean-Claude Beaudoin ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -9,6 +10,9 @@ ;;; ;;; FOREIGN FUNCTION INTERFACE TO MICROSOFT WINDOWS API ;;; +;;; This code as it currently stands is adequate for Win32 +;;; but needs to be re-examined for Win64. 2012/12/24 JCB +;;; (defpackage "WIN32" (:use "COMMON-LISP" "FFI") @@ -18,6 +22,7 @@ (clines "#include " + "#include " ;; because MKCL asks for WIN32_LEAN_AND_MEAN "#include " ) @@ -26,12 +31,14 @@ (def-foreign-type HANDLE :pointer-void) (def-foreign-type LPCSTR :cstring) (def-foreign-type WNDPROC :pointer-void) -(def-foreign-type DWORD :unsigned-int) +(def-foreign-type DWORD :unsigned-long) (def-foreign-type WORD :unsigned-short) +(defmacro cstring (arg) `(convert-to-cstring ,arg)) ;; JCB + ;; Windows constants -(defmacro define-win-constant (name value &optional (c-type :int)) +(defmacro define-win-constant (name value #|&optional (c-type :int)|#) `(defconstant ,name ,value)) (define-win-constant *TRUE* 1) @@ -77,9 +84,9 @@ (define-win-constant *WC_TABCONTROL* "SysTabControl32") (define-win-constant *HWND_BOTTOM* (make-pointer 1 'HANDLE)) -(define-win-constant *HWND_NOTOPMOST* (make-pointer -2 'HANDLE)) +(define-win-constant *HWND_NOTOPMOST* (make-pointer (- #-mingw64 #x100000000 #+mingw64 #x10000000000000000 2) 'HANDLE)) ;; JCB (define-win-constant *HWND_TOP* (make-pointer 0 'HANDLE)) -(define-win-constant *HWND_TOPMOST* (make-pointer -1 'HANDLE)) +(define-win-constant *HWND_TOPMOST* (make-pointer (- #-mingw64 #x100000000 #+mingw64 #x10000000000000000 1) 'HANDLE)) ;; JCB (define-win-constant *SWP_DRAWFRAME* #x0020) (define-win-constant *SWP_HIDEWINDOW* #x0080) @@ -151,10 +158,10 @@ (define-win-constant *RDW_ALLCHILDREN* #x0080) (define-win-constant *RDW_NOCHILDREN* #x0040) -(define-win-constant *CW_USEDEFAULT* (- #x80000000)) +(define-win-constant *CW_USEDEFAULT* #x-80000000) -(define-win-constant *IDC_ARROW* 32512) -(define-win-constant *IDI_APPLICATION* 32512) +(define-win-constant *IDC_ARROW* (make-pointer 32512 :pointer-void)) +(define-win-constant *IDI_APPLICATION* (make-pointer 32512 :pointer-void)) (define-win-constant *COLOR_BACKGROUND* 1) (define-win-constant *DEFAULT_GUI_FONT* 17) @@ -272,6 +279,7 @@ (get-slot-value cls 'WNDCLASS 'lpszClassName) (string name)) (register-wndproc (string name) lpfnWndProc) (registerclass cls))) + (def-struct POINT (x :int) (y :int)) @@ -308,18 +316,23 @@ (def-struct SIZE (cx :long) (cy :long)) (def-struct RECT (left :long) (top :long) (right :long) (bottom :long)) (def-struct TITLEBARINFO (cbSize :unsigned-int) (rcTitlebar RECT) (rgstate (:array :unsigned-int 6))) -(def-struct OPENFILENAME (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (lpstrFilter LPCSTR) (lpstrCustomFilter LPCSTR) - (nMaxFilter :unsigned-int) (nFilterIndex :unsigned-int) (lpstrFile LPCSTR) (nMaxFile :unsigned-int) (lpstrFileTitle LPCSTR) - (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 OPENFILENAME + (lStructSize :unsigned-int) (hwndOwner HANDLE) + (hInstance HANDLE) (lpstrFilter LPCSTR) (lpstrCustomFilter LPCSTR) + (nMaxFilter :unsigned-int) (nFilterIndex :unsigned-int) + (lpstrFile LPCSTR) (nMaxFile :unsigned-int) (lpstrFileTitle LPCSTR) + (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)) (def-struct TCITEM (mask :unsigned-int) (dwState :unsigned-int) (dwStateMask :unsigned-int) (pszText :cstring) (cchTextMax :int) (iImage :int) (lParam :long)) (def-struct NMHDR (hwndFrom HANDLE) (idFrom :unsigned-int) (code :unsigned-int)) (def-struct TCHITTESTINFO (pt POINT) (flag :unsigned-int)) (def-struct TPMPARAMS (cbSize :unsigned-int) (rcExclude RECT)) -(def-struct FINDREPLACE (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (Flags DWORD) +(def-struct FINDREPLACE (lStructSize DWORD) (hwndOwner HANDLE) (hInstance HANDLE) (Flags DWORD) (lpstrFindWhat LPCSTR) (lpstrReplaceWith LPCSTR) (wFindWhatLen WORD) (wReplaceWithLen WORD) (lpCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR)) @@ -332,8 +345,13 @@ (rplacd entry wndproc) (push (cons class-or-obj wndproc) *wndproc-db*))) (unless (stringp class-or-obj) +#| (let ((old-proc (make-pointer (getwindowlong class-or-obj *GWL_WNDPROC*) 'HANDLE))) (setwindowlong class-or-obj *GWL_WNDPROC* (make-lparam (callback 'wndproc-proxy))) + old-proc) +|# + (let ((old-proc (make-pointer (pointer-address (getwindowlongptr class-or-obj *GWL_WNDPROC*)) 'HANDLE))) ;; JCB + (setwindowlongptr class-or-obj *GWL_WNDPROC* (callback 'wndproc-proxy)) old-proc))) (defun get-wndproc (obj) (let ((entry (or (assoc obj *wndproc-db* :test #'equal) @@ -342,6 +360,7 @@ (cdr entry)))) (defcallback (wndproc-proxy :stdcall) :int ((hnd :pointer-void) (umsg :unsigned-int) (wparam :unsigned-int) (lparam :int)) (let* ((wndproc (get-wndproc hnd))) + ;;(format t "~&In wndproc-proxy: umsg = ~S.~%" umsg) (finish-output) (unless wndproc (error "Cannot find a registered Windows prodecure for object ~S" hnd)) (funcall wndproc hnd umsg wparam lparam))) @@ -375,17 +394,17 @@ (def-win32-function ("SelectObject" selectobject) ((hdc HANDLE) (hgdiobj HANDLE)) :returning HANDLE :module "gdi32") (def-win32-function ("GetTextExtentPoint32A" gettextextentpoint32) ((hdc HANDLE) (lpString :cstring) (cbString :int) (lpSize (* SIZE))) :returning :int :module "gdi32") (def-win32-function ("LoadCursorA" loadcursor-string) ((hnd HANDLE) (lpCursorName LPCSTR)) :returning HANDLE :module "user32") -(def-win32-function ("LoadCursorA" loadcursor-int) ((hnd HANDLE) (lpCursorName :unsigned-int)) :returning HANDLE :module "user32") +(def-win32-function ("LoadCursorA" loadcursor-raw) ((hnd HANDLE) (lpCursorName :pointer-void)) :returning HANDLE :module "user32") (defun loadcursor (hnd cur-name) (etypecase cur-name - (fixnum (loadcursor-int hnd cur-name)) + (foreign (loadcursor-raw hnd cur-name)) (string (loadcursor-string hnd cur-name)))) (defun default-cursor () (loadcursor *NULL* *IDC_ARROW*)) -(def-win32-function ("LoadIconA" loadicon-int) ((hnd HANDLE) (lpIconName :unsigned-int)) :returning HANDLE :module "user32") +(def-win32-function ("LoadIconA" loadicon-raw) ((hnd HANDLE) (lpIconName :pointer-void)) :returning HANDLE :module "user32") (def-win32-function ("LoadIconA" loadicon-string) ((hnd HANDLE) (lpIconName LPCSTR)) :returning HANDLE :module "user32") (defun loadicon (hnd cur-name) (etypecase cur-name - (fixnum (loadicon-int hnd cur-name)) + (foreign (loadicon-raw hnd cur-name)) (string (loadicon-string hnd cur-name)))) (defun default-icon () (loadicon *NULL* *IDI_APPLICATION*)) (defun default-background () (getstockobject *COLOR_BACKGROUND*)) @@ -399,11 +418,26 @@ (convert-from-foreign-string s :length n)))) (def-win32-function ("RegisterClassA" registerclass) ((lpWndClass (* WNDCLASS))) :returning :int :module "user32") (def-win32-function ("UnregisterClassA" unregisterclass) ((lpClassName :cstring) (hInstance HANDLE)) :returning :int :module "user32") + (def-win32-function ("GetWindowLongA" getwindowlong) ((hWnd HANDLE) (nIndex :int)) :returning :long :module "user32") (def-win32-function ("SetWindowLongA" setwindowlong) ((hWnd HANDLE) (nIndex :int) (dwNewLong :long)) :returning :long :module "user32") -(def-win32-function ("CreateWindowExA" createwindowex) ((dwExStyle :unsigned-int) (lpClassName :cstring) (lpWindowName :cstring) (dwStyle :unsigned-int) - (x :int) (y :int) (nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE) - (lpParam :pointer-void)) +#-mingw64 ;; JCB +;;(def-win32-function ("GetWindowLongA" getwindowlongptr) ((hWnd HANDLE) (nIndex :int)) :returning :pointer-void :module "user32") +(defun getwindowlongptr (hWnd nIndex) (make-pointer (ldb (byte 32 0) (getwindowlong hWnd nIndex)) :pointer-void)) +#-mingw64 ;; JCB +;;(def-win32-function ("SetWindowLongA" setwindowlongptr) ((hWnd HANDLE) (nIndex :int) (dwNewLong :pointer-void)) :returning :pointer-void :module "user32") +(defun setwindowlongptr (hWnd nIndex dwNewLong) + (make-pointer (ldb (byte 32 0) (setwindowlong hWnd nIndex (ldb (byte 32 0) (- (pointer-address dwNewLong) #x100000000)))) :pointer-void)) + +#+mingw64 ;; JCB +(def-win32-function ("GetWindowLongPtrA" getwindowlongptr) ((hWnd HANDLE) (nIndex :int)) :returning :pointer-void :module "user32") +#+mingw64 ;; JCB +(def-win32-function ("SetWindowLongPtrA" setwindowlongptr) ((hWnd HANDLE) (nIndex :int) (dwNewLong :pointer-void)) :returning :pointer-void :module "user32") +(def-win32-function ("CreateWindowExA" createwindowex) ((dwExStyle :unsigned-int) (lpClassName :cstring) + (lpWindowName :cstring) (dwStyle :unsigned-int) + (x :int) (y :int) (nWidth :int) (nHeight :int) + (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE) + (lpParam :pointer-void)) :returning HANDLE :module "user32") (defun createwindow (&rest args) (apply #'createwindowex 0 args)) @@ -487,12 +521,13 @@ (dispatchmessage msg)))))) (defun y-or-no-p (&optional control &rest args) - (let ((s (coerce (apply #'format nil control args) 'simple-string))) - (= (messagebox *NULL* s "ECL Dialog" (logior *MB_YESNO* *MB_ICONQUESTION*)) + (let ((s (coerce (apply #'format nil control args) 'simple-base-string))) ;; JCB + (= (messagebox *NULL* s "MKCL Dialog" (logior *MB_YESNO* *MB_ICONQUESTION*)) *IDYES*))) (defun get-open-filename (&key (owner *NULL*) initial-dir filter (dlgfn #'getopenfilename) (flags 0) &aux (max-fn-size 1024)) + (declare (ignore initial-dir)) (flet ((null-concat (x &optional y &aux (xx (if y x (car x))) (yy (if y y (cdr x)))) (concatenate 'string xx (string #\Null) yy))) (when filter @@ -582,7 +617,7 @@ (let* ((new-w (loword lparam)) (new-h (hiword lparam)) (wb (- new-w 20)) - (hb (/ (- new-h 30) 2))) + (hb (floor (/ (- new-h 30) 2)))) (movewindow hBtn 10 10 wb hb *TRUE*) (movewindow hOk 10 (+ 20 hb) wb hb *TRUE*)) 0) @@ -619,7 +654,7 @@ (let* ((hwnd (createwindowex 0 "MyClass" - "ECL/Win32 test" + "MKCL/Win32 test" *WS_OVERLAPPEDWINDOW* *CW_USEDEFAULT* *CW_USEDEFAULT*