Re-vamped Win32 FFI example using static and/or dynamic FFI/callbacks. The
example can make use of Scintilla component to provide syntax highlightening.
This commit is contained in:
goffioul
parent
7626509a55
commit
1a8185a2da
5 changed files with 993 additions and 324 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
")
|
||||
374
contrib/win32/lisp-kw.lisp
Normal file
374
contrib/win32/lisp-kw.lisp
Normal file
|
|
@ -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))
|
||||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -16,208 +16,232 @@
|
|||
|
||||
(in-package "WIN32")
|
||||
|
||||
(clines "#define WINVER 0x500")
|
||||
(clines "#include <windows.h>")
|
||||
(clines "#include <windowsx.h>")
|
||||
(clines "#include <commctrl.h>")
|
||||
(clines "#include <richedit.h>")
|
||||
(clines
|
||||
"#include <windows.h>"
|
||||
"#include <commctrl.h>"
|
||||
)
|
||||
|
||||
;; 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*
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue