From 1a8185a2da4e5a85d75b2d8e2639b80d5208efca Mon Sep 17 00:00:00 2001 From: goffioul Date: Wed, 19 Oct 2005 09:26:15 +0000 Subject: [PATCH] Re-vamped Win32 FFI example using static and/or dynamic FFI/callbacks. The example can make use of Scintilla component to provide syntax highlightening. --- contrib/win32/README | 26 +- contrib/win32/compile-and-run.lsp | 23 -- contrib/win32/lisp-kw.lisp | 374 ++++++++++++++++++ contrib/win32/txtedit.lisp | 291 ++++++++++++-- contrib/win32/win32.lisp | 603 ++++++++++++++++-------------- 5 files changed, 993 insertions(+), 324 deletions(-) delete mode 100644 contrib/win32/compile-and-run.lsp create mode 100644 contrib/win32/lisp-kw.lisp diff --git a/contrib/win32/README b/contrib/win32/README index e236dc304..f96952958 100644 --- a/contrib/win32/README +++ b/contrib/win32/README @@ -3,15 +3,33 @@ using ECL's implementation of the UFFI specification. This example consists on several files: - * win32.lsp: This is a lisp interface to the Microsoft Windows API + * win32.lisp: This is a lisp interface to the Microsoft Windows API for the graphical user interface. It is not finished but it suffices to demonstrate the most important ingredients you will need in a real-world application. - * txtedit.lsp: A simple text editor written using the previous library. + * txtedit.lisp: A simple text editor written using the previous library. + This text editor can make use of Scintilla component to provides syntax + highlightning (http://www.scintilla.org). To enable it, simply copy the + SciLexer.dll library in this directory (or where the system can find it). + If the component is not present, a simple editor will be used instead. + + * lisp-kw.lisp: A file containing LISP keywords, used for syntax + highlightning with the Scintilla component. - * compile-and-run.lsp: This lisp script builds the Win32 library and - runs the text editor using it. +This example makes use of static or dynamic FFI/callbacks. When win32.lisp +is compiled into a FAS file, the static FFI/callbacks will be used. Otherwise, +dynamic ones will be used (only under supported architectures). + +To compile the Win32 library (not required under architectures where +dynamic FFI/callbacks are supported), use: + + (compile-file "win32.lisp") + +To start the editor, use: + + (load "txtedit") + (win32::edit) This library has been contributed by Michael Goffioul (michael dot goffioul at swing dot be). Feel free to experiment with it and share your experience at diff --git a/contrib/win32/compile-and-run.lsp b/contrib/win32/compile-and-run.lsp deleted file mode 100644 index 6fa2b40ca..000000000 --- a/contrib/win32/compile-and-run.lsp +++ /dev/null @@ -1,23 +0,0 @@ -;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be) -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Library General Public -;;; License as published by the Free Software Foundation; either -;;; version 2 of the License, or (at your option) any later version. -;;; -;;; See file '../../Copyright' for full details. -;;; -;;; COMPILE THE WIN32 EXAMPLES -;;; - -(require :cmp) -(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.lisp") - -(format t " - -** Run (WIN32::TXTEDIT [FILENAME]) to launch the application example. - -") diff --git a/contrib/win32/lisp-kw.lisp b/contrib/win32/lisp-kw.lisp new file mode 100644 index 000000000..3da3bbfcb --- /dev/null +++ b/contrib/win32/lisp-kw.lisp @@ -0,0 +1,374 @@ +(in-package "WIN32") + +(defparameter *txtedit-lisp-kw* +"* find-method pprint-indent + ** find-package pprint-linear + *** find-restart pprint-logical-block + + find-symbol pprint-newline + ++ finish-output pprint-pop + +++ first pprint-tab + - fixnum pprint-tabular + / flet prin1 + // float prin1-to-string + /// float-digits princ + /= float-precision princ-to-string + 1+ float-radix print + 1- float-sign print-not-readable + < floating-point-inexact print-not-readable-object + <= floating-point-invalid-operation print-object + = floating-point-overflow print-unreadable-object + > floating-point-underflow probe-file + >= floatp proclaim + abort floor prog + abs fmakunbound prog* + access force-output prog1 + acons format prog2 + acos formatter progn + acosh fourth program-error + add-method fresh-line progv + adjoin fround provide + adjust-array ftruncate psetf + adjustable-array-p ftype psetq + allocate-instance funcall push + alpha-char-p function pushnew + alphanumericp function-keywords putprop + and function-lambda-expression quote + append functionp random + apply gbitp random-state + applyhook gcd random-state-p + apropos generic-function rassoc + apropos-list gensym rassoc-if + aref gentemp rassoc-if-not + arithmetic-error get ratio + arithmetic-error-operands get-decoded-time rational + arithmetic-error-operation get-dispatch-macro-character rationalize + array get-internal-real-time rationalp + array-dimension get-internal-run-time read + array-dimension-limit get-macro-character read-byte + array-dimensions get-output-stream-string read-char + array-displacement get-properties read-char-no-hang + array-element-type get-setf-expansion read-delimited-list + array-has-fill-pointer-p get-setf-method read-eval-print + array-in-bounds-p get-universal-time read-from-string + array-rank getf read-line + array-rank-limit gethash read-preserving-whitespace + array-row-major-index go read-sequence + array-total-size graphic-char-p reader-error + array-total-size-limit handler-bind readtable + arrayp handler-case readtable-case + ash hash-table readtablep + asin hash-table-count real + asinh hash-table-p realp + assert hash-table-rehash-size realpart + assoc hash-table-rehash-threshold reduce + assoc-if hash-table-size reinitialize-instance + assoc-if-not hash-table-test rem + atan host-namestring remf + atanh identity remhash + atom if remove + base-char if-exists remove-duplicates + base-string ignorable remove-if + bignum ignore remove-if-not + bit ignore-errors remove-method + bit-and imagpart remprop + bit-andc1 import rename-file + bit-andc2 in-package rename-package + bit-eqv in-package replace + bit-ior incf require + bit-nand initialize-instance rest + bit-nor inline restart + bit-not input-stream-p restart-bind + bit-orc1 inspect restart-case + bit-orc2 int-char restart-name + bit-vector integer return + bit-vector-p integer-decode-float return-from + bit-xor integer-length revappend + block integerp reverse + boole interactive-stream-p room + boole-1 intern rotatef + boole-2 internal-time-units-per-second round + boole-and intersection row-major-aref + boole-andc1 invalid-method-error rplaca + boole-andc2 invoke-debugger rplacd + boole-c1 invoke-restart safety + boole-c2 invoke-restart-interactively satisfies + boole-clr isqrt sbit + boole-eqv keyword scale-float + boole-ior keywordp schar + boole-nand labels search + boole-nor lambda second + boole-orc1 lambda-list-keywords sequence + boole-orc2 lambda-parameters-limit serious-condition + boole-set last set + boole-xor lcm set-char-bit + boolean ldb set-difference + both-case-p ldb-test set-dispatch-macro-character + boundp ldiff set-exclusive-or + break least-negative-double-float set-macro-character + broadcast-stream least-negative-long-float set-pprint-dispatch + broadcast-stream-streams least-negative-normalized-double-float set-syntax-from-char + built-in-class least-negative-normalized-long-float setf + butlast least-negative-normalized-short-float setq + byte least-negative-normalized-single-float seventh + byte-position least-negative-short-float shadow + byte-size least-negative-single-float shadowing-import + call-arguments-limit least-positive-double-float shared-initialize + call-method least-positive-long-float shiftf + call-next-method least-positive-normalized-double-float short-float + capitalize least-positive-normalized-long-float short-float-epsilon + car least-positive-normalized-short-float short-float-negative-epsilon + case least-positive-normalized-single-float short-site-name + catch least-positive-short-float signal + ccase least-positive-single-float signed-byte + cdr length signum + ceiling let simle-condition + cell-error let* simple-array + cell-error-name lisp simple-base-string + cerror lisp-implementation-type simple-bit-vector + change-class lisp-implementation-version simple-bit-vector-p + char list simple-condition-format-arguments + char-bit list* simple-condition-format-control + char-bits list-all-packages simple-error + char-bits-limit list-length simple-string + char-code listen simple-string-p + char-code-limit listp simple-type-error + char-control-bit load simple-vector + char-downcase load-logical-pathname-translations simple-vector-p + char-equal load-time-value simple-warning + char-font locally sin + char-font-limit log single-flaot-epsilon + char-greaterp logand single-float + char-hyper-bit logandc1 single-float-epsilon + char-int logandc2 single-float-negative-epsilon + char-lessp logbitp sinh + char-meta-bit logcount sixth + char-name logeqv sleep + char-not-equal logical-pathname slot-boundp + char-not-greaterp logical-pathname-translations slot-exists-p + char-not-lessp logior slot-makunbound + char-super-bit lognand slot-missing + char-upcase lognor slot-unbound + char/= lognot slot-value + char< logorc1 software-type + char<= logorc2 software-version + char= logtest some + char> logxor sort + char>= long-float space + character long-float-epsilon special + characterp long-float-negative-epsilon special-form-p + check-type long-site-name special-operator-p + cis loop speed + class loop-finish sqrt + class-name lower-case-p stable-sort + class-of machine-instance standard + clear-input machine-type standard-char + clear-output machine-version standard-char-p + close macro-function standard-class + clrhash macroexpand standard-generic-function + code-char macroexpand-1 standard-method + coerce macroexpand-l standard-object + commonp macrolet step + compilation-speed make-array storage-condition + compile make-array store-value + compile-file make-broadcast-stream stream + compile-file-pathname make-char stream-element-type + compiled-function make-concatenated-stream stream-error + compiled-function-p make-condition stream-error-stream + compiler-let make-dispatch-macro-character stream-external-format + compiler-macro make-echo-stream streamp + compiler-macro-function make-hash-table streamup + complement make-instance string + complex make-instances-obsolete string-capitalize + complexp make-list string-char + compute-applicable-methods make-load-form string-char-p + compute-restarts make-load-form-saving-slots string-downcase + concatenate make-method string-equal + concatenated-stream make-package string-greaterp + concatenated-stream-streams make-pathname string-left-trim + cond make-random-state string-lessp + condition make-sequence string-not-equal + conjugate make-string string-not-greaterp + cons make-string-input-stream string-not-lessp + consp make-string-output-stream string-right-strim + constantly make-symbol string-right-trim + constantp make-synonym-stream string-stream + continue make-two-way-stream string-trim + control-error makunbound string-upcase + copy-alist map string/= + copy-list map-into string< + copy-pprint-dispatch mapc string<= + copy-readtable mapcan string= + copy-seq mapcar string> + copy-structure mapcon string>= + copy-symbol maphash stringp + copy-tree mapl structure + cos maplist structure-class + cosh mask-field structure-object + count max style-warning + count-if member sublim + count-if-not member-if sublis + ctypecase member-if-not subseq + debug merge subsetp + decf merge-pathname subst + declaim merge-pathnames subst-if + declaration method subst-if-not + declare method-combination substitute + decode-float method-combination-error substitute-if + decode-universal-time method-qualifiers substitute-if-not + defclass min subtypep + defconstant minusp svref + defgeneric mismatch sxhash + define-compiler-macro mod symbol + define-condition most-negative-double-float symbol-function + define-method-combination most-negative-fixnum symbol-macrolet + define-modify-macro most-negative-long-float symbol-name + define-setf-expander most-negative-short-float symbol-package + define-setf-method most-negative-single-float symbol-plist + define-symbol-macro most-positive-double-float symbol-value + defmacro most-positive-fixnum symbolp + defmethod most-positive-long-float synonym-stream + defpackage most-positive-short-float synonym-stream-symbol + defparameter most-positive-single-float sys + defsetf muffle-warning system + defstruct multiple-value-bind t + deftype multiple-value-call tagbody + defun multiple-value-list tailp + defvar multiple-value-prog1 tan + delete multiple-value-seteq tanh + delete-duplicates multiple-value-setq tenth + delete-file multiple-values-limit terpri + delete-if name-char the + delete-if-not namestring third + delete-package nbutlast throw + denominator nconc time + deposit-field next-method-p trace + describe nil translate-logical-pathname + describe-object nintersection translate-pathname + destructuring-bind ninth tree-equal + digit-char no-applicable-method truename + digit-char-p no-next-method truncase + directory not truncate + directory-namestring notany two-way-stream + disassemble notevery two-way-stream-input-stream + division-by-zero notinline two-way-stream-output-stream + do nreconc type + do* nreverse type-error + do-all-symbols nset-difference type-error-datum + do-exeternal-symbols nset-exclusive-or type-error-expected-type + do-external-symbols nstring type-of + do-symbols nstring-capitalize typecase + documentation nstring-downcase typep + dolist nstring-upcase unbound-slot + dotimes nsublis unbound-slot-instance + double-float nsubst unbound-variable + double-float-epsilon nsubst-if undefined-function + double-float-negative-epsilon nsubst-if-not unexport + dpb nsubstitute unintern + dribble nsubstitute-if union + dynamic-extent nsubstitute-if-not unless + ecase nth unread + echo-stream nth-value unread-char + echo-stream-input-stream nthcdr unsigned-byte + echo-stream-output-stream null untrace + ed number unuse-package + eighth numberp unwind-protect + elt numerator update-instance-for-different-class + encode-universal-time nunion update-instance-for-redefined-class + end-of-file oddp upgraded-array-element-type + endp open upgraded-complex-part-type + enough-namestring open-stream-p upper-case-p + ensure-directories-exist optimize use-package + ensure-generic-function or use-value + eq otherwise user + eql output-stream-p user-homedir-pathname + equal package values + equalp package-error values-list + error package-error-package vector + etypecase package-name vector-pop + eval package-nicknames vector-push + eval-when package-shadowing-symbols vector-push-extend + evalhook package-use-list vectorp + evenp package-used-by-list warn + every packagep warning + exp pairlis when + export parse-error wild-pathname-p + expt parse-integer with-accessors + extended-char parse-namestring with-compilation-unit + fboundp pathname with-condition-restarts + fceiling pathname-device with-hash-table-iterator + fdefinition pathname-directory with-input-from-string + ffloor pathname-host with-open-file + fifth pathname-match-p with-open-stream + file-author pathname-name with-output-to-string + file-error pathname-type with-package-iterator + file-error-pathname pathname-version with-simple-restart + file-length pathnamep with-slots + file-namestring peek-char with-standard-io-syntax + file-position phase write + file-stream pi write-byte + file-string-length plusp write-char + file-write-date pop write-line + fill position write-sequence + fill-pointer position-if write-string + find position-if-not write-to-string + find-all-symbols pprint y-or-n-p + find-class pprint-dispatch yes-or-no-p + find-if pprint-exit-if-list-exhausted zerop + find-if-not pprint-fill + + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + + *applyhook* *load-pathname* *print-pprint-dispatch* + *break-on-signals* *load-print* *print-pprint-dispatch* + *break-on-signals* *load-truename* *print-pretty* + *break-on-warnings* *load-verbose* *print-radix* + *compile-file-pathname* *macroexpand-hook* *print-readably* + *compile-file-pathname* *modules* *print-right-margin* + *compile-file-truename* *package* *print-right-margin* + *compile-file-truename* *print-array* *query-io* + *compile-print* *print-base* *random-state* + *compile-verbose* *print-case* *read-base* + *compile-verbose* *print-circle* *read-default-float-format* + *debug-io* *print-escape* *read-eval* + *debugger-hook* *print-gensym* *read-suppress* + *default-pathname-defaults* *print-length* *readtable* + *error-output* *print-level* *standard-input* + *evalhook* *print-lines* *standard-output* + *features* *print-miser-width* *terminal-io* + *gensym-counter* *print-miser-width* *trace-output*") + +(defparameter *txtedit-lisp-kw2* +":abort :from-end :overwrite + :adjustable :gensym :predicate + :append :host :preserve-whitespace + :array :if-does-not-exist :pretty + :base :if-exists :print + :case :include :print-function + :circle :index :probe + :conc-name :inherited :radix + :constructor :initial-contents :read-only + :copier :initial-element :rehash-size + :count :initial-offset :rehash-threshold + :create :initial-value :rename + :default :input :rename-and-delete + :defaults :internal :size + :device :io :start + :direction :junk-allowed :start1 + :directory :key :start2 + :displaced-index-offset :length :stream + :displaced-to :level :supersede + :element-type :name :test + :end :named :test-not + :end1 :new-version :type + :end2 :nicknames :use + :error :output :verbose + :escape :output-file :version + :external :fill-pointer") + +(defparameter *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 + locally)) diff --git a/contrib/win32/txtedit.lisp b/contrib/win32/txtedit.lisp index deca3b383..945690400 100644 --- a/contrib/win32/txtedit.lisp +++ b/contrib/win32/txtedit.lisp @@ -22,7 +22,12 @@ (defvar *txtedit-tab* *NULL*) (defvar *txtedit-tab-proc* *NULL*) (defvar *txtedit-current* nil) -(defvar *txtedit-rich-p* nil) +(defvar *txtedit-edit-class* 0) +(defvar *txtedit-process* nil) +(defvar *txtedit-handle* *NULL*) +(defvar *txtedit-files* nil) +(defvar *txtedit-dlg-handle* *NULL*) +(defvar *txtedit-findreplace-msg* (registerwindowmessage *FINDMSGSTRING*)) (defstruct txtedit (handle *NULL*) title dirty) (defvar *txtedit-default-title* "ECL Text Editor") @@ -41,6 +46,8 @@ (defparameter +IDM_NEXTWINDOW+ 111) (defparameter +IDM_PREVWINDOW+ 112) (defparameter +IDM_CLOSE+ 113) +(defparameter +IDM_MATCH_PAREN+ 114) +(defparameter +IDM_FIND+ 115) (defparameter +IDM_WINDOW_FIRST+ 500) (defparameter +IDM_WINDOW_LAST+ 600) @@ -80,6 +87,8 @@ Copyright (c) 2005, Michael Goffioul.") (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_MATCH_PAREN+ "&Match parenthesis Ctrl+D") + (appendmenu edit_pop *MF_SEPARATOR* 0 "") (appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A") ;; Windows menu (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam win_pop) "&Window") @@ -94,10 +103,11 @@ Copyright (c) 2005, Michael Goffioul.") (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) (if (characterp ,key) (char-code ,key) ,key)) + (setf (get-slot-value a 'ACCEL 'key) ,(if (characterp key) `(char-code ,key) key)) (setf (get-slot-value a 'ACCEL 'cmd) ,ID) (setf (deref-array ,accTable '(* ACCEL) ,pos) a)))) - (let ((accTable (allocate-foreign-object 'ACCEL 8))) + (let* ((accTableSize (if (= *txtedit-edit-class* 2) 10 9)) + (accTable (allocate-foreign-object 'ACCEL accTableSize))) (add-accel #\Q +IDM_QUIT+ accTable 0) (add-accel #\N +IDM_NEW+ accTable 1) (add-accel #\O +IDM_OPEN+ accTable 2) @@ -106,8 +116,11 @@ Copyright (c) 2005, Michael Goffioul.") (add-accel *VK_LEFT* +IDM_PREVWINDOW+ accTable 5) (add-accel *VK_RIGHT* +IDM_NEXTWINDOW+ accTable 6) (add-accel #\W +IDM_CLOSE+ accTable 7) + (add-accel #\F +IDM_FIND+ accTable 8) + (when (= *txtedit-edit-class* 2) + (add-accel #\D +IDM_MATCH_PAREN+ accTable 9)) (prog1 - (createacceleratortable accTable 8) + (createacceleratortable accTable accTableSize) (free-foreign-object accTable))))) (defun update-caption (hwnd) @@ -166,11 +179,151 @@ Copyright (c) 2005, Michael Goffioul.") t) nil))) +(ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int)) + +(defun init-scintilla-component (hnd) + ;; Set LISP lexer + (sendmessage hnd 4001 21 0) + ;(sendmessage hnd 2090 7 0) + ;; Define default style attributes + (with-foreign-string (fn "Courier New") + (sendmessage hnd 2056 32 (make-lparam fn))) + (sendmessage hnd 2050 0 0) + ;; Define comment style + (sendmessage hnd 2051 1 #xDD0000) + (sendmessage hnd 2054 1 0) + (sendmessage hnd 2051 12 #xDD0000) + (sendmessage hnd 2054 12 0) + ;; Define string style + (sendmessage hnd 2051 6 #x0000C8) + ;; Define number style + (sendmessage hnd 2051 2 #x0000C8) + ;; Define operator style + (sendmessage hnd 2051 10 #xC800C8) + ;; Define symbol style + (sendmessage hnd 2051 5 #xC8C800) + ;; Define brace style + (sendmessage hnd 2052 34 #xFFCCCC) + (sendmessage hnd 2051 35 #xFFFFFF) + (sendmessage hnd 2052 35 #x0000CC) + ;; Define keyword style + (sendmessage hnd 2051 3 #x00C8C8) + (sendmessage hnd 2053 3 0) + (sendmessage hnd 2051 4 #x00C800) + (sendmessage hnd 2051 11 #x00C800) + (unless (boundp '*txtedit-lisp-kw*) + (load "lisp-kw.lisp")) + (with-foreign-strings ((kwList *txtedit-lisp-kw*) + (kwList2 *txtedit-lisp-kw2*)) + (sendmessage hnd 4005 0 (make-lparam kwList)) + (sendmessage hnd 4005 1 (make-lparam kwList2))) + ;; Define margins + (sendmessage hnd 2242 1 0) + (with-foreign-string (s "_9999") + (sendmessage hnd 2242 0 (sendmessage hnd 2276 33 (make-lparam s)))) + ;; Define selection style + (sendmessage hnd 2067 1 #xFFFFFF) + ) + +(defun scintilla-indent-position (pos line hnd) + (+ (sendmessage hnd 2127 line 0) + (- pos + (sendmessage hnd 2128 line 0)))) + +(defun scintilla-read-form (pos hnd) + (read-from-string + (with-output-to-string (s) + (loop for k from pos + with style = (sendmessage hnd 2010 pos 0) + for ch = (code-char (sendmessage hnd 2007 k 0)) + for st = (sendmessage hnd 2010 k 0) + if (and (= st style) + (graphic-char-p ch) + (not (eq ch #\Space))) + do (write-char ch s) + else + return nil)) + nil nil)) + +(defun scintilla-declare-form-p (form) + (member form *txtedit-decl-forms*)) + +(defun scintilla-compute-indentation (curPos curLine hnd) + (loop for k from curPos downto 0 + for ch = (code-char (sendmessage hnd 2007 k 0)) + for st = (sendmessage hnd 2010 k 0) + with depth = 0 + with lineIndent = 0 + with lastCharPos = nil + with prevCharPos = nil + when (= st 10) + do (cond ((and (= depth 0) (eq ch #\()) + (if lastCharPos + (let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0))) + lastForm) + (cond ((member lastChar (list #\( #\;)) + (return (scintilla-indent-position lastCharPos curLine hnd))) + ((and (setq lastForm (scintilla-read-form lastCharPos hnd)) + (scintilla-declare-form-p lastForm)) + (return (+ (scintilla-indent-position k curLine hnd) 2))) + ((and prevCharPos (not (eq prevCharPos lastCharPos))) + (return (scintilla-indent-position prevCharPos curLine hnd))) + (t + (return (+ (scintilla-indent-position lastCharPos curLine hnd) 1))))) + (progn + (return (+ (scintilla-indent-position k curLine hnd) 1))))) + ((eq ch #\() (decf depth)) + ((eq ch #\)) (incf depth))) + if (and (graphic-char-p ch) (not (eq ch #\Space))) + do (setq lastCharPos k) + else + do (setq prevCharPos lastCharPos) + when (eq ch #\Newline) + do (decf curLine) and + do (case lineIndent + (0 (incf lineIndent)) + (1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0))))) + finally (return -1))) + +(defun scintilla-char-added (hnd ch) + (cond ((eq ch #\Newline) + (let* ((curPos (sendmessage hnd 2008 0 0)) + (curLine (sendmessage hnd 2166 curPos 0)) + (indent (scintilla-compute-indentation (1- curPos) curLine hnd))) + (when (>= indent 0) + (sendmessage hnd 2126 curLine indent) + (sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0) + ))) + ;((eq ch #\() + ; (let ((curPos (1- (sendmessage hnd 2008 0 0)))) + ; (when (scintilla-valid-brace-p curPos hnd) + ; (with-foreign-string (s ")") + ; (sendmessage hnd 2003 (1+ curPos) (make-lparam s)))))) + (t + ))) + +(defun scintilla-get-matching-braces (hnd &aux curPos) + (when (>= (setq curPos (1- (sendmessage hnd 2008 0 0))) 0) + (let ((ch (code-char (sendmessage hnd 2007 curPos 0)))) + (when (and (or (eq ch #\() (eq ch #\))) + (= (sendmessage hnd 2010 curPos 0) 10)) + (let ((matchPos (sendmessage hnd 2353 curPos 0))) + (return-from scintilla-get-matching-braces (values curPos matchPos)))))) + (values nil nil)) + +(defun scintilla-check-for-brace (hnd) + (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd) + (if curPos + (if (>= matchPos 0) + (sendmessage hnd 2351 curPos matchPos) + (sendmessage hnd 2352 curPos 0)) + (sendmessage hnd 2351 #xFFFFFFFF -1)))) + (defun create-editor (parent &optional (set-current t)) (with-foreign-object (r 'RECT) (getclientrect parent r) (sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r)) - (let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (if *txtedit-rich-p* *RICHEDIT_CLASS* "EDIT") "" + (let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (txtedit-class-name) "" (logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS* *ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*) (get-slot-value r 'RECT 'left) @@ -179,7 +332,9 @@ Copyright (c) 2005, Michael Goffioul.") (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top)) *txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*)))) (sendmessage (txtedit-handle new-editor) *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0) - (and *txtedit-rich-p* (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*)) + (case *txtedit-edit-class* + (1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*)) + (2 (init-scintilla-component (txtedit-handle new-editor)))) (with-foreign-object (tab 'TCITEM) (setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*) (setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor)) @@ -205,15 +360,17 @@ Copyright (c) 2005, Michael Goffioul.") (defun read-file (pn hwnd) (setq pn (probe-file pn)) - (with-open-file (f pn) - (let* ((len (file-length f)) - (buf (make-string len))) - (read-sequence buf f) - (setwindowtext (txtedit-handle (current-editor)) (unix2dos buf)) - (setf (txtedit-dirty (current-editor)) nil) - (setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn))) - (update-caption hwnd) - (update-tab *txtedit-current*)))) + (if pn + (with-open-file (f pn) + (let* ((len (file-length f)) + (buf (make-string len))) + (read-sequence buf f) + (setwindowtext (txtedit-handle (current-editor)) (unix2dos buf)) + (setf (txtedit-dirty (current-editor)) nil) + (setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn))) + (update-caption hwnd) + (update-tab *txtedit-current*))) + (messagebox hwnd "File does not exist." "Error" (logior *MB_OK* *MB_ICONERROR*)))) (defun save-file (pn hwnd) (unless pn @@ -232,12 +389,15 @@ Copyright (c) 2005, Michael Goffioul.") (close-editor idx hwnd))) (defun tab-proc (hwnd umsg wparam lparam) - (cond ((= umsg *WM_COMMAND*) + (cond ((or (= umsg *WM_COMMAND*) + (= umsg *WM_NOTIFY*)) (txtedit-proc (getparent hwnd) umsg wparam lparam)) (t (callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam)))) -(defun txtedit-proc (hwnd umsg wparam lparam) +(defvar *txtedit-level* 0) +(defun txtedit-proc (hwnd umsg wparam lparam &aux (*txtedit-level* (1+ *txtedit-level*))) + ;(format t "txtedit-proc: ~D~%" *txtedit-level*) (cond ((= umsg *WM_DESTROY*) (postquitmessage 0) 0) @@ -248,6 +408,8 @@ Copyright (c) 2005, Michael Goffioul.") (destroywindow hwnd) 0)) ((= umsg *WM_CREATE*) + (when (null-pointer-p (getmodulehandle "comctl32")) + (initcommoncontrols)) (setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* "" (logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0 hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*)) @@ -286,6 +448,13 @@ Copyright (c) 2005, Michael Goffioul.") (set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd)) (t ))) + ((and (= *txtedit-edit-class* 2) + (= code 2001)) + (with-cast-pointer (lparam SCNotification) + (scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch))))) + ((and (= *txtedit-edit-class* 2) + (= code 2007)) + (scintilla-check-for-brace hnd)) (t )))) 0) @@ -383,20 +552,82 @@ Copyright (c) 2005, Michael Goffioul.") (set-current-editor (1- *txtedit-current*) hwnd))) ((= ctrl-ID +IDM_CLOSE+) (close-or-exit *txtedit-current* hwnd)) + ((= ctrl-ID +IDM_MATCH_PAREN+) + (let ((hnd (txtedit-handle (current-editor)))) + (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd) + (when (and curPos (>= matchPos 0)) + (sendmessage hnd 2025 (1+ matchPos) 0))))) + ((= ctrl-ID +IDM_FIND+) + (let* ((fr (allocate-foreign-object 'FINDREPLACE)) + (str (make-string 1024 :initial-element #\Null))) + (zeromemory fr (size-of-foreign-type 'FINDREPLACE)) + (setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE)) + (setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd) + (setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str) + (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024) + (setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*) + (setq *txtedit-dlg-handle* (findtext fr)))) ((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+) (set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd) 0) (t ))) 0) + ((= uMsg (1+ *WM_USER*)) + (print "Open file request received") + (let ((fname (pop *txtedit-files*))) + (when fname + (create-editor hwnd) + (read-file fname hwnd))) + 0) + ((= uMsg *txtedit-findreplace-msg*) + (with-cast-int-pointer (lparam FINDREPLACE) + (let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags)) + (hnd (txtedit-handle (current-editor)))) + (cond ((/= 0 (logand flags *FR_DIALOGTERM*)) + (free-foreign-object lparam) + (setq *txtedit-dlg-handle* *NULL*)) + ((/= 0 (logand flags *FR_FINDNEXT*)) + (let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat)) + pos + (down (/= (logand flags *FR_DOWN*) 0))) + (cond ((= *txtedit-edit-class* 2) + (let ((selStart (sendmessage hnd 2143 0 0)) + (selEnd (sendmessage hnd 2145 0 0))) + (sendmessage hnd 2025 (if down selEnd selStart) 0) + (sendmessage hnd 2366 0 0) + (with-foreign-string (s str) + (if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1) + (sendmessage hnd 2169 0 0) + (progn + (messagebox *txtedit-dlg-handle* "Finished searching the document" + "Find" (logior *MB_OK* *MB_ICONINFORMATION*)) + (sendmessage hnd 2160 selStart selEnd)))))) + ))) + ))) + 0) (t (defwindowproc hwnd umsg wparam lparam)) )) +(defun txtedit-class-name () + (case *txtedit-edit-class* + (0 "EDIT") + (1 *RICHEDIT_CLASS*) + (2 "Scintilla"))) + (defun register-txtedit-class () (unless *txtedit-class-registered* - (when (and *txtedit-rich-p* (null-pointer-p (loadlibrary "riched20.dll"))) - (error "Cannot load WIN32 library: riched20.dll")) + (case *txtedit-edit-class* + (-1 (or (and (not (null-pointer-p (loadlibrary "SciLexer.dll"))) + (setq *txtedit-edit-class* 2)) + (and (not (null-pointer-p (loadlibrary "riched20.dll"))) + (setq *txtedit-edit-class* 1)) + (setq *txtedit-edit-class* 0))) + (1 (and (null-pointer-p (loadlibrary "riched20.dll")) + (error "Cannot load WIN32 library: riched20.dll"))) + (2 (and (null-pointer-p (loadlibrary "SciLexer.dll")) + (error "Cannot load WIN32 library: SciLexer.dll")))) (make-wndclass "SimpleTextEditor" :lpfnWndProc #'txtedit-proc) (setq *txtedit-class-registered* t))) @@ -404,10 +635,12 @@ Copyright (c) 2005, Michael Goffioul.") (defun unregister-txtedit-class () (when *txtedit-class-registered* (unregisterclass "SimpleTextEditor" *NULL*) - (and *txtedit-rich-p* (freelibrary (getmodulehandle "riched20.dll"))) + (case *txtedit-edit-class* + (1 (freelibrary (getmodulehandle "riched20.dll"))) + (2 (freelibrary (getmodulehandle "SciLexer.dll")))) (setq *txtedit-class-registered* nil))) -(defun txtedit (&optional fname &key rich-p &aux (*txtedit-rich-p* rich-p)) +(defun txtedit (&optional fname &key (class -1) &aux (*txtedit-edit-class* class)) (register-txtedit-class) (let* ((fname-str (if fname (convert-to-foreign-string (coerce fname 'simple-string)) @@ -419,12 +652,26 @@ Copyright (c) 2005, Michael Goffioul.") *txtedit-width* *txtedit-height* *NULL* (create-menus) *NULL* fname-str)) (accTable (create-accels))) + (setq *txtedit-handle* w) (showwindow w *SW_SHOWNORMAL*) (updatewindow w) - (event-loop :accelTable accTable :accelMain w) + (event-loop :accelTable accTable :accelMain w :dlgSym '*txtedit-dlg-handle*) (setq *txtedit-edit* nil) + (setq *txtedit-process* nil) + (setq *txtedit-handle* *NULL*) (destroyacceleratortable accTable) (unless (null-pointer-p fname-str) (free-foreign-object fname-str)) (unregister-txtedit-class) nil)) + +(defun edit (&optional fname &key (class -1) (detach-p (member :threads *features*))) + (if (or detach-p *txtedit-process*) + (if (member :threads *features*) + (if *txtedit-process* + (progn + (push fname *txtedit-files*) + (postmessage *txtedit-handle* (1+ *WM_USER*) 0 0)) + #+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class))))) + (error "No multi-threading environment detected.")) + (txtedit fname :class class))) diff --git a/contrib/win32/win32.lisp b/contrib/win32/win32.lisp index 7d0a721c2..09e9d52a0 100644 --- a/contrib/win32/win32.lisp +++ b/contrib/win32/win32.lisp @@ -16,208 +16,232 @@ (in-package "WIN32") -(clines "#define WINVER 0x500") -(clines "#include ") -(clines "#include ") -(clines "#include ") -(clines "#include ") +(clines + "#include " + "#include " + ) ;; Windows types (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 WORD :unsigned-short) ;; Windows constants -(defmacro define-win-constant (name c-name &optional (c-type :int)) - `(defconstant ,name (c-inline () () ,(ffi::%convert-to-ffi-type c-type) ,c-name :one-liner t))) +(defmacro define-win-constant (name value &optional (c-type :int)) + `(defconstant ,name ,value)) -(define-win-constant *TRUE* "TRUE") -(define-win-constant *FALSE* "FALSE") +(define-win-constant *TRUE* 1) +(define-win-constant *FALSE* 0) -(define-win-constant *WM_CLOSE* "WM_CLOSE") -(define-win-constant *WM_COMMAND* "WM_COMMAND") -(define-win-constant *WM_CONTEXTMENU* "WM_CONTEXTMENU") -(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_INITMENU* "WM_INITMENU") -(define-win-constant *WM_INITMENUPOPUP* "WM_INITMENUPOPUP") -(define-win-constant *WM_NCPAINT* "WM_NCPAINT") -(define-win-constant *WM_NOTIFY* "WM_NOTIFY") -(define-win-constant *WM_PAINT* "WM_PAINT") -(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 *WM_CLOSE* #x0010) +(define-win-constant *WM_COMMAND* #x0111) +(define-win-constant *WM_CONTEXTMENU* #x007b) +(define-win-constant *WM_COPY* #x0301) +(define-win-constant *WM_CREATE* #x0001) +(define-win-constant *WM_CUT* #x0300) +(define-win-constant *WM_DESTROY* #x0002) +(define-win-constant *WM_GETFONT* #x0031) +(define-win-constant *WM_GETMINMAXINFO* #x0024) +(define-win-constant *WM_INITMENU* #x0116) +(define-win-constant *WM_INITMENUPOPUP* #x0117) +(define-win-constant *WM_NCPAINT* #x0085) +(define-win-constant *WM_NOTIFY* #x004e) +(define-win-constant *WM_PAINT* #x000f) +(define-win-constant *WM_PASTE* #x0302) +(define-win-constant *WM_QUIT* #x0012) +(define-win-constant *WM_SETFOCUS* #x0007) +(define-win-constant *WM_SETFONT* #x0030) +(define-win-constant *WM_SIZE* #x0005) +(define-win-constant *WM_UNDO* #x0304) +(define-win-constant *WM_USER* #x0400) -(define-win-constant *WS_BORDER* "WS_BORDER") -(define-win-constant *WS_CHILD* "WS_CHILD") -(define-win-constant *WS_CLIPCHILDREN* "WS_CLIPCHILDREN") -(define-win-constant *WS_CLIPSIBLINGS* "WS_CLIPSIBLINGS") -(define-win-constant *WS_DLGFRAME* "WS_DLGFRAME") -(define-win-constant *WS_DISABLED* "WS_DISABLED") -(define-win-constant *WS_HSCROLL* "WS_HSCROLL") -(define-win-constant *WS_OVERLAPPEDWINDOW* "WS_OVERLAPPEDWINDOW") -(define-win-constant *WS_VISIBLE* "WS_VISIBLE") -(define-win-constant *WS_VSCROLL* "WS_VSCROLL") +(define-win-constant *WS_BORDER* #x00800000) +(define-win-constant *WS_CHILD* #x40000000) +(define-win-constant *WS_CLIPCHILDREN* #x02000000) +(define-win-constant *WS_CLIPSIBLINGS* #x04000000) +(define-win-constant *WS_DLGFRAME* #x00400000) +(define-win-constant *WS_DISABLED* #x08000000) +(define-win-constant *WS_HSCROLL* #x00100000) +(define-win-constant *WS_OVERLAPPEDWINDOW* #x00CF0000) +(define-win-constant *WS_VISIBLE* #x10000000) +(define-win-constant *WS_VSCROLL* #x00200000) -(define-win-constant *WS_EX_CLIENTEDGE* "WS_EX_CLIENTEDGE") +(define-win-constant *WS_EX_CLIENTEDGE* #x00000200) -(define-win-constant *RICHEDIT_CLASS* "RICHEDIT_CLASS" LPCSTR) -(define-win-constant *WC_LISTVIEW* "WC_LISTVIEW" LPCSTR) -(define-win-constant *WC_TABCONTROL* "WC_TABCONTROL" LPCSTR) +(define-win-constant *RICHEDIT_CLASS* "RichEdit20A") +(define-win-constant *WC_LISTVIEW* "SysListView32") +(define-win-constant *WC_TABCONTROL* "SysTabControl32") -(define-win-constant *HWND_BOTTOM* "HWND_BOTTOM" HANDLE) -(define-win-constant *HWND_NOTOPMOST* "HWND_NOTOPMOST" HANDLE) -(define-win-constant *HWND_TOP* "HWND_TOP" HANDLE) -(define-win-constant *HWND_TOPMOST* "HWND_TOPMOST" HANDLE) +(define-win-constant *HWND_BOTTOM* (make-pointer 1 'HANDLE)) +(define-win-constant *HWND_NOTOPMOST* (make-pointer -2 'HANDLE)) +(define-win-constant *HWND_TOP* (make-pointer 0 'HANDLE)) +(define-win-constant *HWND_TOPMOST* (make-pointer -1 'HANDLE)) -(define-win-constant *SWP_DRAWFRAME* "SWP_DRAWFRAME") -(define-win-constant *SWP_HIDEWINDOW* "SWP_HIDEWINDOW") -(define-win-constant *SWP_NOMOVE* "SWP_NOMOVE") -(define-win-constant *SWP_NOOWNERZORDER* "SWP_NOOWNERZORDER") -(define-win-constant *SWP_NOREDRAW* "SWP_NOREDRAW") -(define-win-constant *SWP_NOREPOSITION* "SWP_NOREPOSITION") -(define-win-constant *SWP_NOSIZE* "SWP_NOSIZE") -(define-win-constant *SWP_NOZORDER* "SWP_NOZORDER") -(define-win-constant *SWP_SHOWWINDOW* "SWP_NOZORDER") +(define-win-constant *SWP_DRAWFRAME* #x0020) +(define-win-constant *SWP_HIDEWINDOW* #x0080) +(define-win-constant *SWP_NOMOVE* #x0002) +(define-win-constant *SWP_NOOWNERZORDER* #x0200) +(define-win-constant *SWP_NOREDRAW* #x0008) +(define-win-constant *SWP_NOREPOSITION* #x0200) +(define-win-constant *SWP_NOSIZE* #x0001) +(define-win-constant *SWP_NOZORDER* #x0004) +(define-win-constant *SWP_SHOWWINDOW* #x0040) -(define-win-constant *BS_DEFPUSHBUTTON* "BS_DEFPUSHBUTTON") -(define-win-constant *BS_PUSHBUTTON* "BS_PUSHBUTTON") +(define-win-constant *BS_DEFPUSHBUTTON* #x00000000) +(define-win-constant *BS_PUSHBUTTON* #x00000001) -(define-win-constant *BN_CLICKED* "BN_CLICKED") +(define-win-constant *BN_CLICKED* 0) -(define-win-constant *ES_AUTOHSCROLL* "ES_AUTOHSCROLL") -(define-win-constant *ES_AUTOVSCROLL* "ES_AUTOVSCROLL") -(define-win-constant *ES_LEFT* "ES_LEFT") -(define-win-constant *ES_MULTILINE* "ES_MULTILINE") +(define-win-constant *ES_AUTOHSCROLL* #x0080) +(define-win-constant *ES_AUTOVSCROLL* #x0040) +(define-win-constant *ES_LEFT* #x0000) +(define-win-constant *ES_MULTILINE* #x0004) -(define-win-constant *EM_CANUNDO* "EM_CANUNDO") -(define-win-constant *EM_SETEVENTMASK* "EM_SETEVENTMASK") -(define-win-constant *EM_SETSEL* "EM_SETSEL") -(define-win-constant *EM_UNDO* "EM_UNDO") -(define-win-constant *EN_CHANGE* "EN_CHANGE") -(define-win-constant *ENM_CHANGE* "ENM_CHANGE") +(define-win-constant *EM_CANUNDO* #x00c6) +(define-win-constant *EM_SETEVENTMASK* (+ *WM_USER* 69)) +(define-win-constant *EM_SETSEL* #x00b1) +(define-win-constant *EM_UNDO* #x00c7) +(define-win-constant *EN_CHANGE* #x0300) +(define-win-constant *ENM_CHANGE* #x00000001) -(define-win-constant *TCIF_IMAGE* "TCIF_IMAGE") -(define-win-constant *TCIF_PARAM* "TCIF_PARAM") -(define-win-constant *TCIF_RTLREADING* "TCIF_RTLREADING") -(define-win-constant *TCIF_STATE* "TCIF_STATE") -(define-win-constant *TCIF_TEXT* "TCIF_TEXT") +(define-win-constant *TCIF_IMAGE* #x0002) +(define-win-constant *TCIF_PARAM* #x0008) +(define-win-constant *TCIF_RTLREADING* #x0004) +(define-win-constant *TCIF_STATE* #x0010) +(define-win-constant *TCIF_TEXT* #x0001) -(define-win-constant *TCHT_NOWHERE* "TCHT_NOWHERE") -(define-win-constant *TCHT_ONITEM* "TCHT_ONITEM") -(define-win-constant *TCHT_ONITEMICON* "TCHT_ONITEMICON") -(define-win-constant *TCHT_ONITEMLABEL* "TCHT_ONITEMLABEL") +(define-win-constant *TCHT_NOWHERE* #x0001) +(define-win-constant *TCHT_ONITEM* #x0006) +(define-win-constant *TCHT_ONITEMICON* #x0002) +(define-win-constant *TCHT_ONITEMLABEL* #x0004) -(define-win-constant *TCM_ADJUSTRECT* "TCM_ADJUSTRECT") -(define-win-constant *TCM_DELETEITEM* "TCM_DELETEITEM") -(define-win-constant *TCM_GETCURSEL* "TCM_GETCURSEL") -(define-win-constant *TCM_HITTEST* "TCM_HITTEST") -(define-win-constant *TCM_INSERTITEM* "TCM_INSERTITEM") -(define-win-constant *TCM_SETCURSEL* "TCM_SETCURSEL") -(define-win-constant *TCM_SETITEM* "TCM_SETITEM") -(define-win-constant *TCN_SELCHANGE* "TCN_SELCHANGE" :unsigned-int) +(define-win-constant *TCM_FIRST* #x1300) +(define-win-constant *TCN_FIRST* #xfffffdda) +(define-win-constant *TCM_ADJUSTRECT* (+ *TCM_FIRST* 40)) +(define-win-constant *TCM_DELETEITEM* (+ *TCM_FIRST* 8)) +(define-win-constant *TCM_GETCURSEL* (+ *TCM_FIRST* 11)) +(define-win-constant *TCM_HITTEST* (+ *TCM_FIRST* 13)) +(define-win-constant *TCM_INSERTITEM* (+ *TCM_FIRST* 7)) +(define-win-constant *TCM_SETCURSEL* (+ *TCM_FIRST* 12)) +(define-win-constant *TCM_SETITEM* (+ *TCM_FIRST* 6)) +(define-win-constant *TCN_SELCHANGE* (- *TCN_FIRST* 1)) -(define-win-constant *NM_CLICK* "NM_CLICK" :unsigned-int) -(define-win-constant *NM_RCLICK* "NM_RCLICK" :unsigned-int) +(define-win-constant *NM_FIRST* #x100000000) +(define-win-constant *NM_CLICK* (- *NM_FIRST* 1)) +(define-win-constant *NM_RCLICK* (- *NM_FIRST* 5)) -(define-win-constant *SW_HIDE* "SW_HIDE") -(define-win-constant *SW_SHOW* "SW_SHOW") -(define-win-constant *SW_SHOWNORMAL* "SW_SHOWNORMAL") +(define-win-constant *SW_HIDE* 0) +(define-win-constant *SW_SHOW* 5) +(define-win-constant *SW_SHOWNORMAL* 1) -(define-win-constant *RDW_ERASE* "RDW_ERASE") -(define-win-constant *RDW_FRAME* "RDW_FRAME") -(define-win-constant *RDW_INTERNALPAINT* "RDW_INTERNALPAINT") -(define-win-constant *RDW_INVALIDATE* "RDW_INVALIDATE") -(define-win-constant *RDW_NOERASE* "RDW_NOERASE") -(define-win-constant *RDW_NOFRAME* "RDW_NOFRAME") -(define-win-constant *RDW_NOINTERNALPAINT* "RDW_NOINTERNALPAINT") -(define-win-constant *RDW_VALIDATE* "RDW_VALIDATE") -(define-win-constant *RDW_ERASENOW* "RDW_ERASENOW") -(define-win-constant *RDW_UPDATENOW* "RDW_UPDATENOW") -(define-win-constant *RDW_ALLCHILDREN* "RDW_ALLCHILDREN") -(define-win-constant *RDW_NOCHILDREN* "RDW_NOCHILDREN") +(define-win-constant *RDW_ERASE* #x0004) +(define-win-constant *RDW_FRAME* #x0400) +(define-win-constant *RDW_INTERNALPAINT* #x0002) +(define-win-constant *RDW_INVALIDATE* #x0001) +(define-win-constant *RDW_NOERASE* #x0020) +(define-win-constant *RDW_NOFRAME* #x0800) +(define-win-constant *RDW_NOINTERNALPAINT* #x0010) +(define-win-constant *RDW_VALIDATE* #x0008) +(define-win-constant *RDW_ERASENOW* #x0200) +(define-win-constant *RDW_UPDATENOW* #x0100) +(define-win-constant *RDW_ALLCHILDREN* #x0080) +(define-win-constant *RDW_NOCHILDREN* #x0040) -(define-win-constant *CW_USEDEFAULT* "CW_USEDEFAULT") +(define-win-constant *CW_USEDEFAULT* (- #x80000000)) -(define-win-constant *IDC_ARROW* "IDC_ARROW") -(define-win-constant *IDI_APPLICATION* "IDI_APPLICATION") +(define-win-constant *IDC_ARROW* 32512) +(define-win-constant *IDI_APPLICATION* 32512) -(define-win-constant *COLOR_BACKGROUND* "COLOR_BACKGROUND") -(define-win-constant *DEFAULT_GUI_FONT* "DEFAULT_GUI_FONT") -(define-win-constant *OEM_FIXED_FONT* "OEM_FIXED_FONT") -(define-win-constant *SYSTEM_FONT* "SYSTEM_FONT") -(define-win-constant *SYSTEM_FIXED_FONT* "SYSTEM_FIXED_FONT") +(define-win-constant *COLOR_BACKGROUND* 1) +(define-win-constant *DEFAULT_GUI_FONT* 17) +(define-win-constant *OEM_FIXED_FONT* 10) +(define-win-constant *SYSTEM_FONT* 13) +(define-win-constant *SYSTEM_FIXED_FONT* 16) -(define-win-constant *MB_HELP* "MB_HELP") -(define-win-constant *MB_OK* "MB_OK") -(define-win-constant *MB_OKCANCEL* "MB_OKCANCEL") -(define-win-constant *MB_YESNO* "MB_YESNO") -(define-win-constant *MB_YESNOCANCEL* "MB_YESNOCANCEL") -(define-win-constant *MB_ICONEXCLAMATION* "MB_ICONEXCLAMATION") -(define-win-constant *MB_ICONWARNING* "MB_ICONWARNING") -(define-win-constant *MB_ICONINFORMATION* "MB_ICONINFORMATION") -(define-win-constant *MB_ICONQUESTION* "MB_ICONQUESTION") +(define-win-constant *MB_HELP* #x00004000) +(define-win-constant *MB_OK* #x00000000) +(define-win-constant *MB_OKCANCEL* #x00000001) +(define-win-constant *MB_YESNO* #x00000004) +(define-win-constant *MB_YESNOCANCEL* #x00000003) +(define-win-constant *MB_ICONEXCLAMATION* #x00000030) +(define-win-constant *MB_ICONWARNING* #x00000020) +(define-win-constant *MB_ICONERROR* #x00000010) +(define-win-constant *MB_ICONINFORMATION* #x00000040) +(define-win-constant *MB_ICONQUESTION* #x00000020) -(define-win-constant *IDCANCEL* "IDCANCEL") -(define-win-constant *IDNO* "IDNO") -(define-win-constant *IDOK* "IDOK") -(define-win-constant *IDYES* "IDYES") +(define-win-constant *IDCANCEL* 2) +(define-win-constant *IDNO* 7) +(define-win-constant *IDOK* 1) +(define-win-constant *IDYES* 6) -(define-win-constant *MF_BYCOMMAND* "MF_BYCOMMAND") -(define-win-constant *MF_BYPOSITION* "MF_BYPOSITION") -(define-win-constant *MF_CHECKED* "MF_CHECKED") -(define-win-constant *MF_DISABLED* "MF_DISABLED") -(define-win-constant *MF_ENABLED* "MF_ENABLED") -(define-win-constant *MF_GRAYED* "MF_GRAYED") -(define-win-constant *MF_MENUBREAK* "MF_MENUBREAK") -(define-win-constant *MF_POPUP* "MF_POPUP") -(define-win-constant *MF_SEPARATOR* "MF_SEPARATOR") -(define-win-constant *MF_STRING* "MF_STRING") -(define-win-constant *MF_UNCHECKED* "MF_UNCHECKED") +(define-win-constant *MF_BYCOMMAND* #x00000000) +(define-win-constant *MF_BYPOSITION* #x00000400) +(define-win-constant *MF_CHECKED* #x00000008) +(define-win-constant *MF_DISABLED* #x00000002) +(define-win-constant *MF_ENABLED* #x00000000) +(define-win-constant *MF_GRAYED* #x00000001) +(define-win-constant *MF_MENUBREAK* #x00000040) +(define-win-constant *MF_POPUP* #x00000010) +(define-win-constant *MF_SEPARATOR* #x00000800) +(define-win-constant *MF_STRING* #x00000000) +(define-win-constant *MF_UNCHECKED* #x00000000) -(define-win-constant *TPM_CENTERALIGN* "TPM_CENTERALIGN") -(define-win-constant *TPM_LEFTALIGN* "TPM_LEFTALIGN") -(define-win-constant *TPM_RIGHTALIGN* "TPM_RIGHTALIGN") -(define-win-constant *TPM_BOTTOMALIGN* "TPM_BOTTOMALIGN") -(define-win-constant *TPM_TOPALIGN* "TPM_TOPALIGN") -(define-win-constant *TPM_VCENTERALIGN* "TPM_VCENTERALIGN") -(define-win-constant *TPM_NONOTIFY* "TPM_NONOTIFY") -(define-win-constant *TPM_RETURNCMD* "TPM_RETURNCMD") -(define-win-constant *TPM_LEFTBUTTON* "TPM_LEFTBUTTON") -(define-win-constant *TPM_RIGHTBUTTON* "TPM_RIGHTBUTTON") +(define-win-constant *TPM_CENTERALIGN* #x0004) +(define-win-constant *TPM_LEFTALIGN* #x0000) +(define-win-constant *TPM_RIGHTALIGN* #x0008) +(define-win-constant *TPM_BOTTOMALIGN* #x0020) +(define-win-constant *TPM_TOPALIGN* #x0000) +(define-win-constant *TPM_VCENTERALIGN* #x0010) +(define-win-constant *TPM_NONOTIFY* #x0080) +(define-win-constant *TPM_RETURNCMD* #x0100) +(define-win-constant *TPM_LEFTBUTTON* #x0000) +(define-win-constant *TPM_RIGHTBUTTON* #x0002) -(define-win-constant *OFN_FILEMUSTEXIST* "OFN_FILEMUSTEXIST") -(define-win-constant *OFN_OVERWRITEPROMPT* "OFN_OVERWRITEPROMPT") -(define-win-constant *OFN_PATHMUSTEXIST* "OFN_PATHMUSTEXIST") -(define-win-constant *OFN_READONLY* "OFN_READONLY") +(define-win-constant *OFN_FILEMUSTEXIST* #x00001000) +(define-win-constant *OFN_OVERWRITEPROMPT* #x00000002) +(define-win-constant *OFN_PATHMUSTEXIST* #x00000800) +(define-win-constant *OFN_READONLY* #x00000001) -(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 *FVIRTKEY* *TRUE*) +(define-win-constant *FNOINVERT* #x02) +(define-win-constant *FSHIFT* #x04) +(define-win-constant *FCONTROL* #x08) +(define-win-constant *FALT* #x10) -(define-win-constant *VK_F1* "VK_F1") -(define-win-constant *VK_LEFT* "VK_LEFT") -(define-win-constant *VK_RIGHT* "VK_RIGHT") +(define-win-constant *VK_F1* #x70) +(define-win-constant *VK_LEFT* #x25) +(define-win-constant *VK_RIGHT* #x27) -(define-win-constant *GWL_EXSTYLE* "GWL_EXSTYLE") -(define-win-constant *GWL_HINSTANCE* "GWL_HINSTANCE") -(define-win-constant *GWL_HWNDPARENT* "GWL_HWNDPARENT") -(define-win-constant *GWL_ID* "GWL_ID") -(define-win-constant *GWL_STYLE* "GWL_STYLE") -(define-win-constant *GWL_WNDPROC* "GWL_WNDPROC") +(define-win-constant *GWL_EXSTYLE* -20) +(define-win-constant *GWL_HINSTANCE* -6) +(define-win-constant *GWL_HWNDPARENT* -8) +(define-win-constant *GWL_ID* -12) +(define-win-constant *GWL_STYLE* -16) +(define-win-constant *GWL_WNDPROC* -4) -(defconstant *NULL* (make-null-pointer :pointer-void)) +(define-win-constant *FINDMSGSTRING* "commdlg_FindReplace") +(define-win-constant *HELPMSGSTRING* "commdlg_help") + +(define-win-constant *FR_DIALOGTERM* #x00000040) +(define-win-constant *FR_DOWN* #x00000001) +(define-win-constant *FR_FINDNEXT* #x00000008) +(define-win-constant *FR_HIDEUPDOWN* #x00004000) +(define-win-constant *FR_HIDEMATCHCASE* #x00008000) +(define-win-constant *FR_HIDEWHOLEWORD* #x00010000) +(define-win-constant *FR_MATCHCASE* #x00000004) +(define-win-constant *FR_NOMATCHCASE* #x00000800) +(define-win-constant *FR_NOUPDOWN* #x00000400) +(define-win-constant *FR_NOWHOLEWORD* #x00001000) +(define-win-constant *FR_REPLACE* #x00000010) +(define-win-constant *FR_REPLACEALL* #x00000020) +(define-win-constant *FR_SHOWHELP* #x00000080) +(define-win-constant *FR_WHOLEWORD* #x00000002) + +(defconstant *NULL* (make-null-pointer :void)) ;; Windows structures @@ -237,7 +261,7 @@ (lpszMenuName "")) (with-foreign-object (cls 'WNDCLASS) (setf (get-slot-value cls 'WNDCLASS 'style) style - (get-slot-value cls 'WNDCLASS 'lpfnWndProc) *DEFAULT_WNDPROC* + (get-slot-value cls 'WNDCLASS 'lpfnWndProc) (callback 'wndproc-proxy) (get-slot-value cls 'WNDCLASS 'cbClsExtra) cbClsExtra (get-slot-value cls 'WNDCLASS 'cbWndExtra) cbWndExtra (get-slot-value cls 'WNDCLASS 'hInstance) hInstance @@ -295,6 +319,9 @@ (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) + (lpstrFindWhat LPCSTR) (lpstrReplaceWith LPCSTR) (wFindWhatLen WORD) (wReplaceWithLen WORD) + (lpCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR)) ;; Windows functions @@ -306,145 +333,144 @@ (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 *DEFAULT_WNDPROC*)) + (setwindowlong class-or-obj *GWL_WNDPROC* (make-lparam (callback 'wndproc-proxy))) old-proc))) (defun get-wndproc (obj) (let ((entry (or (assoc obj *wndproc-db* :test #'equal) (assoc (getclassname obj) *wndproc-db* :test #'equal)))) (and entry (cdr entry)))) -(eval-when (compile) - (proclaim '(si::c-export-fname win32::wndproc-proxy))) -(defun wndproc-proxy (hnd umsg wparam lparam) +(defcallback (wndproc-proxy :stdcall) :int ((hnd :pointer-void) (umsg :unsigned-int) (wparam :unsigned-int) (lparam :int)) (let* ((wndproc (get-wndproc hnd))) (unless wndproc (error "Cannot find a registered Windows prodecure for object ~S" hnd)) (funcall wndproc hnd umsg wparam lparam))) -(clines " -LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam) -{ - return object_to_fixnum( - win32_wndproc_proxy( - 4, - ecl_make_foreign_data(make_keyword(\"POINTER-VOID\"),0,hwnd), - make_unsigned_integer(uMsg), - make_unsigned_integer(wParam), - make_integer(lParam))); -} -") -(defconstant *DEFAULT_WNDPROC* (c-inline () () :pointer-void "WndProc_proxy" :one-liner t)) -(defun make-ID (id) - (c-inline (id :pointer-void) (:unsigned-int :object) :object "ecl_make_foreign_data(#1,0,((void*)#0))" :one-liner t)) + +(defun make-ID (id) (make-pointer id :pointer-void)) (setf (symbol-function 'make-handle) #'make-ID) -(defun make-wparam (hnd) - (c-inline (hnd) (:pointer-void) :unsigned-int "(WPARAM)#0" :one-liner t)) -(defun make-lparam (hnd) - (c-inline (hnd) (:pointer-void) :unsigned-int "(LPARAM)#0" :one-liner t)) +(defun make-wparam (hnd) (pointer-address hnd)) +(defun make-lparam (hnd) (pointer-address hnd)) (defmacro with-cast-int-pointer ((var type &optional ptr) &body body) (unless ptr (setq ptr var)) `(let ((,var (make-pointer ,ptr ',type))) ,@body)) -(def-function ("ZeroMemory" zeromemory) ((Destination :pointer-void) (Length :unsigned-int)) :returning :void) -(def-function ("LoadLibrary" loadlibrary) ((lpLibFileName LPCSTR)) :returning HANDLE) -(def-function ("FreeLibrary" freelibrary) ((hLibModule HANDLE)) :returning :int) -(def-function ("GetModuleHandle" getmodulehandle) ((lpModuleName LPCSTR)) :returning HANDLE) -(def-function ("GetStockObject" getstockobject) ((fnObject :int)) :returning HANDLE) -(def-function ("GetTextMetrics" gettextmetrics) ((hdc HANDLE) (lptm (* TEXTMETRIC))) :returning :int) -(def-function ("GetDC" getdc) ((hWnd HANDLE)) :returning HANDLE) -(def-function ("ReleaseDC" releasedc) ((hWnd HANDLE) (hdc HANDLE)) :returning :int) -(def-function ("SelectObject" selectobject) ((hdc HANDLE) (hgdiobj HANDLE)) :returning HANDLE) -(def-function ("GetTextExtentPoint32" gettextextentpoint32) ((hdc HANDLE) (lpString :cstring) (cbString :int) (lpSize (* SIZE))) :returning :int) -(def-function ("LoadCursor" loadcursor-string) ((hnd HANDLE) (lpCursorName LPCSTR)) :returning HANDLE) -(def-function ("LoadCursor" loadcursor-int) ((hnd HANDLE) (lpCursorName :unsigned-int)) :returning HANDLE) +(eval-when (:load-toplevel :execute) + (defmacro def-win32-function (name args &key (returning :void) module) + `(def-function ,name ,args :returning ,returning :module ,module :call :stdcall))) +(eval-when (:compile-toplevel) + (defmacro def-win32-function (name args &key (returning :void) module) + `(def-function ,name ,args :returning ,returning))) +(load-foreign-library "kernel32.lib") +(load-foreign-library "comdlg32.lib") +(load-foreign-library "gdi32.lib") +(load-foreign-library "comctl32.lib") + +(def-win32-function ("RtlZeroMemory" zeromemory) ((Destination :pointer-void) (Length :unsigned-int)) :returning :void :module "kernel32") +(def-win32-function ("LoadLibraryA" loadlibrary) ((lpLibFileName LPCSTR)) :returning HANDLE :module "kernel32") +(def-win32-function ("FreeLibrary" freelibrary) ((hLibModule HANDLE)) :returning :int :module "kernel32") +(def-win32-function ("GetModuleHandleA" getmodulehandle) ((lpModuleName LPCSTR)) :returning HANDLE :module "kernel32") +(def-win32-function ("GetStockObject" getstockobject) ((fnObject :int)) :returning HANDLE :module "gdi32") +(def-win32-function ("GetTextMetricsA" gettextmetrics) ((hdc HANDLE) (lptm (* TEXTMETRIC))) :returning :int :module "gdi32") +(def-win32-function ("GetDC" getdc) ((hWnd HANDLE)) :returning HANDLE :module "user32") +(def-win32-function ("ReleaseDC" releasedc) ((hWnd HANDLE) (hdc HANDLE)) :returning :int :module "user32") +(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") (defun loadcursor (hnd cur-name) (etypecase cur-name (fixnum (loadcursor-int hnd cur-name)) (string (loadcursor-string hnd cur-name)))) (defun default-cursor () (loadcursor *NULL* *IDC_ARROW*)) -(def-function ("LoadIcon" loadicon-int) ((hnd HANDLE) (lpIconName :unsigned-int)) :returning HANDLE) -(def-function ("LoadIcon" loadicon-string) ((hnd HANDLE) (lpIconName LPCSTR)) :returning HANDLE) +(def-win32-function ("LoadIconA" loadicon-int) ((hnd HANDLE) (lpIconName :unsigned-int)) :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)) (string (loadicon-string hnd cur-name)))) (defun default-icon () (loadicon *NULL* *IDI_APPLICATION*)) (defun default-background () (getstockobject *COLOR_BACKGROUND*)) -(def-function ("GetClassName" getclassname-i) ((hnd HANDLE) (lpClassName LPCSTR) (maxCount :int)) :returning :int) -(defun getclassname (hnd) - (with-cstring (s (make-string 64)) - (let ((n (getclassname-i hnd s 64))) +(def-win32-function ("GetLastError" getlasterror) () :returning :unsigned-int :module "kernel32") +(def-win32-function ("GetClassNameA" getclassname-i) ((hnd HANDLE) (lpClassName (* :char)) (maxCount :int)) :returning :int :module "user32") +(defun getclassname (hnd &aux (max-length 64)) + (with-foreign-object (s `(:array :char ,max-length)) + (let ((n (getclassname-i hnd s max-length))) (when (= n 0) (error "Unable to get class name for ~A" hnd)) - (subseq s 0 n)))) -(def-function ("RegisterClass" registerclass) ((lpWndClass (* WNDCLASS))) :returning :int) -(def-function ("UnregisterClass" unregisterclass) ((lpClassName :cstring) (hInstance HANDLE)) :returning :int) -(def-function ("GetWindowLong" getwindowlong) ((hWnd HANDLE) (nIndex :int)) :returning :long) -(def-function ("SetWindowLong" setwindowlong) ((hWnd HANDLE) (nIndex :int) (dwNewLong :long)) :returning :long) -(def-function ("CreateWindow" createwindow) ((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) -(def-function ("CreateWindowEx" createwindowex) ((dwExStyle :unsigned-int) (lpClassName :cstring) (lpWindowName :cstring) (dwStyle :unsigned-int) + (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)) - :returning HANDLE) -(def-function ("DestroyWindow" destroywindow) ((hWnd HANDLE)) :returning :int) -(def-function ("ShowWindow" showwindow) ((hWnd HANDLE) (nCmdShow :int)) :returning :int) -(def-function ("UpdateWindow" updatewindow) ((hWnd HANDLE)) :returning :void) -(def-function ("RedrawWindow" redrawwindow) ((hWnd HANDLE) (lprcUpdate (* RECT)) (hrgnUpdate HANDLE) (flags :unsigned-int)) :returning :int) -(def-function ("MoveWindow" movewindow) ((hWnd HANDLE) (x :int) (y :int) (nWidth :int) (nHeight :int) (bRepaint :int)) :returning :int) -(def-function ("SetWindowPos" setwindowpos) ((hWnd HANDLE) (hWndInsertAfter HANDLE) (x :int) - (y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int) -(def-function ("BringWindowToTop" bringwindowtotop) ((hWnd HANDLE)) :returning :int) -(def-function ("GetWindowText" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int) + :returning HANDLE :module "user32") +(defun createwindow (&rest args) + (apply #'createwindowex 0 args)) +(def-win32-function ("DestroyWindow" destroywindow) ((hWnd HANDLE)) :returning :int :module "user32") +(def-win32-function ("ShowWindow" showwindow) ((hWnd HANDLE) (nCmdShow :int)) :returning :int :module "user32") +(def-win32-function ("UpdateWindow" updatewindow) ((hWnd HANDLE)) :returning :void :module "user32") +(def-win32-function ("RedrawWindow" redrawwindow) ((hWnd HANDLE) (lprcUpdate (* RECT)) (hrgnUpdate HANDLE) (flags :unsigned-int)) :returning :int :module "user32") +(def-win32-function ("MoveWindow" movewindow) ((hWnd HANDLE) (x :int) (y :int) (nWidth :int) (nHeight :int) (bRepaint :int)) :returning :int :module "user32") +(def-win32-function ("SetWindowPos" setwindowpos) ((hWnd HANDLE) (hWndInsertAfter HANDLE) (x :int) + (y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int :module "user32") +(def-win32-function ("BringWindowToTop" bringwindowtotop) ((hWnd HANDLE)) :returning :int :module "user32") +(def-win32-function ("GetWindowTextA" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int :module "user32") (defun getwindowtext (hnd) (let ((len (1+ (getwindowtextlength hnd)))) (with-cstring (s (make-string len)) (getwindowtext-i hnd s len) (subseq s 0 (1- len))))) -(def-function ("GetWindowTextLength" getwindowtextlength) ((hWnd HANDLE)) :returning :int) -(def-function ("SetWindowText" setwindowtext) ((hWnd HANDLE) (lpString LPCSTR)) :returning :int) -(def-function ("GetParent" getparent) ((hWnd HANDLE)) :returning HANDLE) -(def-function ("GetClientRect" getclientrect) ((hWnd HANDLE) (lpRect (* RECT))) :returning :int) -(def-function ("GetWindowRect" getwindowrect) ((hWnd HANDLE) (lpRect (* RECT))) :returning :int) -(def-function ("InvalidateRect" invalidaterect) ((hWnd HANDLE) (lpRect (* RECT)) (bErase :int)) :returning :int) -(def-function ("SetRect" setrect) ((lpRect (* RECT)) (xLeft :int) (yTop :int) (xRight :int) (yBottom :int)) :returning :int) -(def-function ("GetTitleBarInfo" gettitlebarinfo) ((hWnd HANDLE) (pti (* TITLEBARINFO))) :returning :int) -(def-function ("SetFocus" setfocus) ((hWnd HANDLE)) :returning HANDLE) -(def-function ("PostQuitMessage" postquitmessage) ((nExitCode :int)) :returning :void) -(def-function ("SendMessage" sendmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int) -(def-function ("PostMessage" postmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int) -(def-function ("DefWindowProc" defwindowproc) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int) -(def-function ("CallWindowProc" callwindowproc) ((wndProc HANDLE) (hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int) -(def-function ("HIWORD" hiword) ((dWord :unsigned-int)) :returning :unsigned-int) -(def-function ("LOWORD" loword) ((dWord :unsigned-int)) :returning :unsigned-int) -(def-function ("GET_X_LPARAM" get-x-lparam) ((lParam :int)) :returning :int) -(def-function ("GET_Y_LPARAM" get-y-lparam) ((lParam :int)) :returning :int) -(def-function ("ScreenToClient" screentoclient) ((hWnd HANDLE) (pt (* POINT))) :returning :int) -(def-function ("MessageBox" messagebox) ((hWnd HANDLE) (lpText LPCSTR) (lpCaption LPCSTR) (uType :unsigned-int)) :returning :int) -(def-function ("GetOpenFileName" getopenfilename) ((lpofn (* OPENFILENAME))) :returning :int) -(def-function ("GetSaveFileName" getsavefilename) ((lpofn (* OPENFILENAME))) :returning :int) -(def-function ("GetMessage" getmessage) ((lpMsg (* MSG)) (hWnd HANDLE) (wMsgFitlerMin :unsigned-int) (wMsgFilterMax :unsigned-int)) :returning :int) -(def-function ("TranslateMessage" translatemessage) ((lpMsg (* MSG))) :returning :int) -(def-function ("DispatchMessage" dispatchmessage) ((lpMsg (* MSG))) :returning :int) -(def-function ("CreateMenu" createmenu) nil :returning HANDLE) -(def-function ("CreatePopupMenu" createpopupmenu) nil :returning HANDLE) -(def-function ("DestroyMenu" destroymenu) ((hMenu HANDLE)) :returning :int) -(def-function ("AppendMenu" appendmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (uIDNewItem :unsigned-int) (lpNewItem LPCSTR)) :returning :int) -(def-function ("GetSubMenu" getsubmenu) ((hMenu HANDLE) (nPos :int)) :returning HANDLE) -(def-function ("DeleteMenu" deletemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int) -(def-function ("RemoveMenu" removemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int) -(def-function ("GetMenuItemCount" getmenuitemcount) ((hMenu HANDLE)) :returning :int) -(def-function ("CheckMenuItem" checkmenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int) -(def-function ("EnableMenuItem" enablemenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int) -(def-function ("TrackPopupMenu" trackpopupmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (x :int) (y :int) - (nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int) -(def-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int) - (hWnd HANDLE) (lptpl (* TPMPARAMS))) :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) +(def-win32-function ("GetWindowTextLengthA" getwindowtextlength) ((hWnd HANDLE)) :returning :int :module "user32") +(def-win32-function ("SetWindowTextA" setwindowtext) ((hWnd HANDLE) (lpString LPCSTR)) :returning :int :module "user32") +(def-win32-function ("GetParent" getparent) ((hWnd HANDLE)) :returning HANDLE :module "user32") +(def-win32-function ("GetClientRect" getclientrect) ((hWnd HANDLE) (lpRect (* RECT))) :returning :int :module "user32") +(def-win32-function ("GetWindowRect" getwindowrect) ((hWnd HANDLE) (lpRect (* RECT))) :returning :int :module "user32") +(def-win32-function ("InvalidateRect" invalidaterect) ((hWnd HANDLE) (lpRect (* RECT)) (bErase :int)) :returning :int :module "user32") +(def-win32-function ("SetRect" setrect) ((lpRect (* RECT)) (xLeft :int) (yTop :int) (xRight :int) (yBottom :int)) :returning :int :module "user32") +;(def-win32-function ("GetTitleBarInfo" gettitlebarinfo) ((hWnd HANDLE) (pti (* TITLEBARINFO))) :returning :int) +(def-win32-function ("SetFocus" setfocus) ((hWnd HANDLE)) :returning HANDLE :module "user32") +(def-win32-function ("PostQuitMessage" postquitmessage) ((nExitCode :int)) :returning :void :module "user32") +(def-win32-function ("SendMessageA" sendmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32") +(def-win32-function ("PostMessageA" postmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32") +(def-win32-function ("RegisterWindowMessageA" registerwindowmessage) ((lpString LPCSTR)) :returning :unsigned-int :module "user32") +(def-win32-function ("IsDialogMessageA" isdialogmessage) ((hDlg HANDLE) (lpMsg (* MSG))) :returning :int :module "user32") +(def-win32-function ("DefWindowProcA" defwindowproc) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32") +(def-win32-function ("CallWindowProcA" callwindowproc) ((wndProc HANDLE) (hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32") +(defun loword (x) (logand x #xffff)) +(defun hiword (x) (logand (floor x 65536) #xffff)) +(defun get-x-lparam (x) (loword x)) +(defun get-y-lparam (x) (hiword x)) +(def-win32-function ("ScreenToClient" screentoclient) ((hWnd HANDLE) (pt (* POINT))) :returning :int :module "user32") +(def-win32-function ("MessageBoxA" messagebox) ((hWnd HANDLE) (lpText LPCSTR) (lpCaption LPCSTR) (uType :unsigned-int)) :returning :int :module "user32") +(def-win32-function ("GetOpenFileNameA" getopenfilename) ((lpofn (* OPENFILENAME))) :returning :int :module "comdlg32") +(def-win32-function ("GetSaveFileNameA" getsavefilename) ((lpofn (* OPENFILENAME))) :returning :int :module "comdlg32") +(def-win32-function ("FindTextA" findtext) ((lpfr (* FINDREPLACE))) :returning HANDLE :module "comdlg32") +(def-win32-function ("ReplaceTextA" replacetext) ((lpfr (* FINDREPLACE))) :returning HANDLE :module "comdlg32") +(def-win32-function ("GetMessageA" getmessage) ((lpMsg (* MSG)) (hWnd HANDLE) (wMsgFitlerMin :unsigned-int) (wMsgFilterMax :unsigned-int)) :returning :int :module "user32") +(def-win32-function ("TranslateMessage" translatemessage) ((lpMsg (* MSG))) :returning :int :module "user32") +(def-win32-function ("DispatchMessageA" dispatchmessage) ((lpMsg (* MSG))) :returning :int :module "user32") +(def-win32-function ("CreateMenu" createmenu) nil :returning HANDLE :module "user32") +(def-win32-function ("CreatePopupMenu" createpopupmenu) nil :returning HANDLE :module "user32") +(def-win32-function ("DestroyMenu" destroymenu) ((hMenu HANDLE)) :returning :int :module "user32") +(def-win32-function ("AppendMenuA" appendmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (uIDNewItem :unsigned-int) (lpNewItem LPCSTR)) :returning :int :module "user32") +(def-win32-function ("GetSubMenu" getsubmenu) ((hMenu HANDLE) (nPos :int)) :returning HANDLE :module "user32") +(def-win32-function ("DeleteMenu" deletemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int :module "user32") +(def-win32-function ("RemoveMenu" removemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int :module "user32") +(def-win32-function ("GetMenuItemCount" getmenuitemcount) ((hMenu HANDLE)) :returning :int :module "user32") +(def-win32-function ("CheckMenuItem" checkmenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32") +(def-win32-function ("EnableMenuItem" enablemenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32") +(def-win32-function ("TrackPopupMenu" trackpopupmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (x :int) (y :int) + (nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32") +(def-win32-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int) + (hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32") +(def-win32-function ("CreateAcceleratorTableA" createacceleratortable) ((lpaccl (* ACCEL)) (cEntries :int)) :returning HANDLE :module "user32") +(def-win32-function ("TranslateAcceleratorA" translateaccelerator) ((hWnd HANDLE) (hAccTable HANDLE) (lpMsg (* MSG))) :returning :int :module "user32") +(def-win32-function ("DestroyAcceleratorTable" destroyacceleratortable) ((hAccTable HANDLE)) :returning :int :module "user32") +(def-win32-function ("InitCommonControls" initcommoncontrols) () :returning :void :module "comctl32") -(defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*)) +(defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*) (dlgSym nil)) (with-foreign-object (msg 'MSG) (loop for bRet = (getmessage msg *NULL* 0 0) when (= bRet 0) return bRet @@ -454,6 +480,9 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara do (or (and (not (null-pointer-p accelTable)) (not (null-pointer-p accelMain)) (/= (translateaccelerator accelMain accelTable msg) 0)) + (and dlgSym + (not (null-pointer-p (symbol-value dlgSym))) + (/= (isdialogmessage (symbol-value dlgSym) msg) 0)) (progn (translatemessage msg) (dispatchmessage msg)))))) @@ -470,7 +499,8 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara (when filter (setq filter (format nil "~A~C~C" (reduce #'null-concat (mapcar #'null-concat filter)) #\Null #\Null))) (with-foreign-object (ofn 'OPENFILENAME) - (with-cstring (fn (make-string max-fn-size :initial-element #\Null)) + (with-cstrings ((fn (make-string max-fn-size :initial-element #\Null)) + (filter filter)) (zeromemory ofn (size-of-foreign-type 'OPENFILENAME)) (setf (get-slot-value ofn 'OPENFILENAME 'lStructSize) (size-of-foreign-type 'OPENFILENAME)) (setf (get-slot-value ofn 'OPENFILENAME 'hwndOwner) owner) @@ -482,6 +512,26 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara (unless (= (funcall dlgfn ofn) 0) (pathname (string-trim (string #\Null) fn))))))) +(defun find-text (&key (owner *NULL*) &aux (max-txt-size 1024)) + (with-foreign-object (fr 'FINDREPLACE) + (with-cstring (txt (make-string max-txt-size :initial-element #\Null)) + (zeromemory fr (size-of-foreign-type 'FINDREPLACE)) + (setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE)) + (setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) owner) + (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) max-txt-size) + ;(setf (get-slot-value fr 'FINDREPLACE 'Flags) 1) + (let ((result (findtext fr))) + (print result) + txt)))) + +#| +(defun set-wndproc (obj fun) + (let ((cb (si:make-dynamic-callback fun (read-from-string (format nil "~A-WNDPROC" (gensym))) :int '(:pointer-void :unsigned-int :unsigned-int :int))) + (old-wndproc (make-pointer (getwindowlong obj *GWL_WNDPROC*) 'HANDLE))) + (setwindowlong obj *GWL_WNDPROC* (make-lparam cb)) + old-wndproc)) +|# + (provide "WIN32") ;;; Test code @@ -518,12 +568,13 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara (defun test-wndproc (hwnd umsg wparam lparam) (cond ((= umsg *WM_DESTROY*) + (setq hBtn nil hOk nil) (postquitmessage 0) 0) ((= umsg *WM_CREATE*) - (setq hBtn (createwindow "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*) + (setq hBtn (createwindowex 0 "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*) 0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*)) - (setq hOk (createwindow "BUTTON" "Close" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*) + (setq hOk (createwindowex 0 "BUTTON" "Close" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*) 0 0 50 20 hwnd (make-ID *OK_ID*) *NULL* *NULL*)) (sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) (sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) @@ -539,8 +590,8 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara ((= umsg *WM_GETMINMAXINFO*) (let* ((btn1-sz (and hBtn (button-min-size hBtn))) (btn2-sz (and hOk (button-min-size hOk))) - (rc (get-titlebar-rect hWnd)) - (titleH (1+ (- (fourth rc) (second rc))))) + #|(rc (get-titlebar-rect hWnd))|# + (titleH #|(1+ (- (fourth rc) (second rc)))|# 30)) (when (and btn1-sz btn2-sz (> titleH 0)) (with-foreign-object (minSz 'POINT) (setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20)) @@ -553,7 +604,8 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara (id (loword wparam))) (cond ((= n *BN_CLICKED*) (cond ((= id *HELLO_ID*) - (format t "~&Hellow World!~%")) + (format t "~&Hellow World!~%") + (get-open-filename :owner hwnd)) ((= id *OK_ID*) (destroywindow hwnd)))) (t @@ -565,7 +617,8 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara (defun do-test () (make-wndclass "MyClass" :lpfnWndProc #'test-wndproc) - (let* ((hwnd (createwindow + (let* ((hwnd (createwindowex + 0 "MyClass" "ECL/Win32 test" *WS_OVERLAPPEDWINDOW*