mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-05 18:30:24 -08:00
Code Issues Projects Releases Packages Wiki Activity

Untabify everything.

Browse source
This commit is contained in:
Zack Piper 2015-09-01 20:10:10 +00:00
parent d5fd24d267
commit 00521d869a
27 changed files with 3621 additions and 3621 deletions
Download patch file Download diff file Expand all files Collapse all files

2
contrib/deflate/deflate.lisp
View file

@ -35,7 +35,7 @@
#:inflate-stream #:inflate-stream
#:inflate-zlib-stream #:parse-zlib-header #:parse-zlib-footer #:inflate-zlib-stream #:parse-zlib-header #:parse-zlib-footer
#:inflate-gzip-stream #:parse-gzip-header #:parse-gzip-footer #:inflate-gzip-stream #:parse-gzip-header #:parse-gzip-footer
#:gunzip)) #:gunzip))
(cl:in-package "DEFLATE") (cl:in-package "DEFLATE")

2990
contrib/defsystem/defsystem.lisp
View file

File diff suppressed because it is too large Load diff

210
contrib/ecl-cdb/ecl-cdb.lisp
View file

@ -68,14 +68,14 @@
(defun read-word (stream) (defun read-word (stream)
(logior (read-byte stream) (logior (read-byte stream)
(ash (read-byte stream) 8) (ash (read-byte stream) 8)
(ash (read-byte stream) 16) (ash (read-byte stream) 16)
(ash (read-byte stream) 24))) (ash (read-byte stream) 24)))
(defun write-word (byte stream) (defun write-word (byte stream)
(declare (type (unsigned-byte 32) byte) (declare (type (unsigned-byte 32) byte)
(stream stream) (stream stream)
(optimize speed (safety 0))) (optimize speed (safety 0)))
(write-byte (logand #xff byte) stream) (write-byte (logand #xff byte) stream)
(write-byte (logand #xff (ash byte -8)) stream) (write-byte (logand #xff (ash byte -8)) stream)
(write-byte (logand #xff (ash byte -16)) stream) (write-byte (logand #xff (ash byte -16)) stream)
@ -91,35 +91,35 @@
(loop with h of-type (unsigned-integer 32) = 5381 (loop with h of-type (unsigned-integer 32) = 5381
for byte of-type (unsigned-byte 8) across key-vector for byte of-type (unsigned-byte 8) across key-vector
do (setf h (logxor (logand #xffffffff do (setf h (logxor (logand #xffffffff
(+ (ash (logand #.(ash #xffffffff -5) h) (+ (ash (logand #.(ash #xffffffff -5) h)
5) 5)
h)) h))
byte)) byte))
finally (return h))) finally (return h)))
(defun %make-cdb (cdb-pathname temporary-pathname) (defun %make-cdb (cdb-pathname temporary-pathname)
(let ((stream (open temporary-pathname (let ((stream (open temporary-pathname
:direction :output :direction :output
:if-exists :supersede :if-exists :supersede
:if-does-not-exist :create :if-does-not-exist :create
:element-type '(unsigned-byte 8)))) :element-type '(unsigned-byte 8))))
(if stream (if stream
(progn (progn
(file-position stream 0) (file-position stream 0)
(dotimes (i (* 256 2)) (dotimes (i (* 256 2))
(write-word 0 stream)) (write-word 0 stream))
(make-cdb :stream stream (make-cdb :stream stream
:pathname cdb-pathname :pathname cdb-pathname
:tables (make-array 256 :initial-element nil) :tables (make-array 256 :initial-element nil)
:temporary-pathname temporary-pathname)) :temporary-pathname temporary-pathname))
(error "Unable to create CDB at filename ~A" temporary-pathname)))) (error "Unable to create CDB at filename ~A" temporary-pathname))))
(defmacro with-output-to-cdb ((cdb cdb-pathname temporary-pathname) &body body) (defmacro with-output-to-cdb ((cdb cdb-pathname temporary-pathname) &body body)
`(let (,cdb) `(let (,cdb)
(unwind-protect (unwind-protect
(progn (progn
(setf ,cdb (%make-cdb ,cdb-pathname ,temporary-pathname)) (setf ,cdb (%make-cdb ,cdb-pathname ,temporary-pathname))
,@body) ,@body)
(close-cdb ,cdb)))) (close-cdb ,cdb))))
(defun add-record (key value cdb) (defun add-record (key value cdb)
@ -127,10 +127,10 @@
;; reference in the CDB structure itself. This reference will be ;; reference in the CDB structure itself. This reference will be
;; used to create the hash. ;; used to create the hash.
(let* ((hash-key (to-cdb-hash key)) (let* ((hash-key (to-cdb-hash key))
(table-index (logand #xff hash-key)) (table-index (logand #xff hash-key))
(stream (cdb-stream cdb))) (stream (cdb-stream cdb)))
(push (cons hash-key (file-position stream)) (push (cons hash-key (file-position stream))
(aref (cdb-tables cdb) table-index)) (aref (cdb-tables cdb) table-index))
(write-word (length key) stream) (write-word (length key) stream)
(write-word (length value) stream) (write-word (length value) stream)
(write-sequence key stream) (write-sequence key stream)
@ -144,26 +144,26 @@
;; Here we use a factor 2. ;; Here we use a factor 2.
(loop with length = (* 2 (length table)) (loop with length = (* 2 (length table))
with vector = (make-array (* 2 length) :initial-element 0 with vector = (make-array (* 2 length) :initial-element 0
:element-type '(unsigned-byte 32)) :element-type '(unsigned-byte 32))
for (hash-key . pos) in table for (hash-key . pos) in table
for index = (mod (ash hash-key -8) length) for index = (mod (ash hash-key -8) length)
do (loop for disp from 0 below length do (loop for disp from 0 below length
for i = (* 2 (mod (+ disp index) length)) for i = (* 2 (mod (+ disp index) length))
for record-pos = (aref vector (1+ i)) for record-pos = (aref vector (1+ i))
until (zerop record-pos) until (zerop record-pos)
finally (setf (aref vector i) hash-key (aref vector (1+ i)) pos)) finally (setf (aref vector i) hash-key (aref vector (1+ i)) pos))
finally (progn (write-vector vector stream) finally (progn (write-vector vector stream)
(return length)))) (return length))))
(defun dump-cdb (cdb) (defun dump-cdb (cdb)
;; After we have dumped all the records in the file, we append the ;; After we have dumped all the records in the file, we append the
;; hash tables and recreate the index table at the beginning. ;; hash tables and recreate the index table at the beginning.
(let* ((stream (cdb-stream cdb)) (let* ((stream (cdb-stream cdb))
(index (make-array (* 2 256) :element-type '(unsigned-byte 32)))) (index (make-array (* 2 256) :element-type '(unsigned-byte 32))))
(loop for table across (cdb-tables cdb) (loop for table across (cdb-tables cdb)
for i of-type fixnum from 0 by 2 for i of-type fixnum from 0 by 2
do (setf (aref index i) (file-position stream) do (setf (aref index i) (file-position stream)
(aref index (1+ i)) (dump-table table stream))) (aref index (1+ i)) (dump-table table stream)))
(file-position stream 0) (file-position stream 0)
(write-vector index stream))) (write-vector index stream)))
@ -173,8 +173,8 @@
(dump-cdb cdb) (dump-cdb cdb)
(close stream) (close stream)
(when (cdb-pathname cdb) (when (cdb-pathname cdb)
(rename-file (cdb-temporary-pathname cdb) (rename-file (cdb-temporary-pathname cdb)
(cdb-pathname cdb)))))) (cdb-pathname cdb))))))
(defun cdb-error (stream) (defun cdb-error (stream)
(error "Error when reading CDB database ~A" stream)) (error "Error when reading CDB database ~A" stream))
@ -185,82 +185,82 @@
(let ((key-length (read-word stream))) (let ((key-length (read-word stream)))
(when (= key-length (length key-vector)) (when (= key-length (length key-vector))
(let* ((value-length (read-word stream)) (let* ((value-length (read-word stream))
(other-key (make-array key-length :element-type '(unsigned-byte 8)))) (other-key (make-array key-length :element-type '(unsigned-byte 8))))
(read-sequence other-key stream) (read-sequence other-key stream)
(when (equalp other-key key-vector) (when (equalp other-key key-vector)
(if return-position-p (if return-position-p
(file-position stream) (file-position stream)
(let ((value (make-array value-length :element-type '(unsigned-byte 8)))) (let ((value (make-array value-length :element-type '(unsigned-byte 8))))
(read-sequence value stream) (read-sequence value stream)
value) value)
)))))) ))))))
(defun lookup-cdb (key stream &optional return-position-p) (defun lookup-cdb (key stream &optional return-position-p)
(if (streamp stream) (if (streamp stream)
(let* ((hash (to-cdb-hash key)) (let* ((hash (to-cdb-hash key))
(table (logand #xFF hash))) (table (logand #xFF hash)))
(unless (file-position stream (* table 8)) (unless (file-position stream (* table 8))
(cdb-error stream)) (cdb-error stream))
(let* ((start (read-word stream)) (let* ((start (read-word stream))
(length (read-word stream)) (length (read-word stream))
(index (mod (ash hash -8) length))) (index (mod (ash hash -8) length)))
(loop for reset = t (loop for reset = t
for i from 0 below length for i from 0 below length
for rounded-i = (mod (+ index i) length) for rounded-i = (mod (+ index i) length)
for position = (+ start (* 8 rounded-i)) for position = (+ start (* 8 rounded-i))
do (progn do (progn
(when reset (when reset
(unless (file-position stream position) (unless (file-position stream position)
(cdb-error stream)) (cdb-error stream))
(setf reset nil)) (setf reset nil))
(let* ((other-hash (read-word stream)) (let* ((other-hash (read-word stream))
(record-position (read-word stream))) (record-position (read-word stream)))
(when (zerop record-position) (when (zerop record-position)
(return nil)) (return nil))
(when (= other-hash hash) (when (= other-hash hash)
(let ((output (values-coincide record-position key stream (let ((output (values-coincide record-position key stream
return-position-p))) return-position-p)))
(if output (if output
(return output) (return output)
(setf reset t))))))))) (setf reset t)))))))))
(with-open-file (s stream :direction :input (with-open-file (s stream :direction :input
:element-type '(unsigned-byte 8)) :element-type '(unsigned-byte 8))
(lookup-cdb key s return-position-p)))) (lookup-cdb key s return-position-p))))
(defun map-cdb (function stream) (defun map-cdb (function stream)
(if (streamp stream) (if (streamp stream)
(let* ((index (make-array (* 256 2) :element-type '(unsigned-byte 32)))) (let* ((index (make-array (* 256 2) :element-type '(unsigned-byte 32))))
(unless (file-position stream 0) (unless (file-position stream 0)
(cdb-error stream)) (cdb-error stream))
(unless (= (read-sequence index stream) (length index)) (unless (= (read-sequence index stream) (length index))
(cdb-error stream)) (cdb-error stream))
(loop for i from 0 by 2 below (length index) (loop for i from 0 by 2 below (length index)
for table-position = (aref index i) for table-position = (aref index i)
for table-length = (aref index (1+ i)) for table-length = (aref index (1+ i))
do (progn do (progn
(unless (file-position stream table-position) (unless (file-position stream table-position)
(cdb-error stream)) (cdb-error stream))
(loop for i from 0 below table-length (loop for i from 0 below table-length
for position from table-position by 8 for position from table-position by 8
for record-hash = (read-word stream) for record-hash = (read-word stream)
for record-position = (read-word stream) for record-position = (read-word stream)
unless (zerop record-position) unless (zerop record-position)
do (progn do (progn
(unless (file-position stream record-position) (unless (file-position stream record-position)
(cdb-error stream)) (cdb-error stream))
(let* ((key-length (read-word stream)) (let* ((key-length (read-word stream))
(value-length (read-word stream)) (value-length (read-word stream))
(key (make-array key-length (key (make-array key-length
:element-type '(unsigned-byte 8))) :element-type '(unsigned-byte 8)))
(value (make-array value-length (value (make-array value-length
:element-type '(unsigned-byte 8)))) :element-type '(unsigned-byte 8))))
(unless (and (= (read-sequence key stream) (unless (and (= (read-sequence key stream)
key-length) key-length)
(= (read-sequence value stream) (= (read-sequence value stream)
value-length)) value-length))
(cdb-error stream)) (cdb-error stream))
(funcall function key value))))))) (funcall function key value)))))))
(with-open-file (s stream :direction :input :element-type '(unsigned-byte 8)) (with-open-file (s stream :direction :input :element-type '(unsigned-byte 8))
(map-cdb function s)))) (map-cdb function s))))
(provide :ecl-cdb) (provide :ecl-cdb)

22
contrib/ecl-cdb/ecl-help.lisp
View file

@ -14,25 +14,25 @@
(defun to-cdb-vector (object) (defun to-cdb-vector (object)
(let* ((vector (make-array 128 :adjustable t (let* ((vector (make-array 128 :adjustable t
:fill-pointer 0 :fill-pointer 0
:element-type '(unsigned-byte 8) :element-type '(unsigned-byte 8)
:initial-element 0)) :initial-element 0))
(stream (ext:make-sequence-output-stream (stream (ext:make-sequence-output-stream
vector :external-format #+unicode :utf-8 #-unicode :default))) vector :external-format #+unicode :utf-8 #-unicode :default)))
(with-standard-io-syntax (with-standard-io-syntax
(let ((si::*print-package* (find-package "CL"))) (let ((si::*print-package* (find-package "CL")))
(write object :stream stream :pretty nil (write object :stream stream :pretty nil
:readably nil :escape t))) :readably nil :escape t)))
vector)) vector))
(defun from-cdb-vector (vector) (defun from-cdb-vector (vector)
(let* ((stream (ext:make-sequence-input-stream (let* ((stream (ext:make-sequence-input-stream
vector :external-format #+unicode :utf-8 #-unicode :default))) vector :external-format #+unicode :utf-8 #-unicode :default)))
(read stream nil nil nil))) (read stream nil nil nil)))
(defun search-help-file (string path) (defun search-help-file (string path)
(let* ((key (to-cdb-vector string)) (let* ((key (to-cdb-vector string))
(value (ecl-cdb:lookup-cdb key path))) (value (ecl-cdb:lookup-cdb key path)))
(when value (when value
(from-cdb-vector value)))) (from-cdb-vector value))))
@ -43,8 +43,8 @@
(loop for k being the hash-key of hash-table (loop for k being the hash-key of hash-table
using (hash-value v) using (hash-value v)
do (ecl-cdb:add-record (to-cdb-vector k) do (ecl-cdb:add-record (to-cdb-vector k)
(to-cdb-vector v) (to-cdb-vector v)
cdb))) cdb)))
;; Testing the consistency of the output ;; Testing the consistency of the output
(when test (when test
(loop for k being the hash-key of hash-table (loop for k being the hash-key of hash-table

24
contrib/ecl-curl/ecl-curl.lisp
View file

@ -59,9 +59,9 @@
(defpackage #:ecl-curl (defpackage #:ecl-curl
(:use #:sb-bsd-sockets #:cl) (:use #:sb-bsd-sockets #:cl)
(:export #:download-url-to-file (:export #:download-url-to-file
#:download-error #:download-error
#:download-url #:download-url
#:download-response)) #:download-response))
(in-package "ECL-CURL") (in-package "ECL-CURL")
@ -176,9 +176,9 @@
(if *proxy* (if *proxy*
url url
(let ((path-start (position #\/ url :start 7))) (let ((path-start (position #\/ url :start 7)))
(if path-start (if path-start
(subseq url path-start) (subseq url path-start)
"/index.html")))) "/index.html"))))
;;;--------------------------------------------------------------------------- ;;;---------------------------------------------------------------------------
;;; CONNECTION & HEADRE ;;; CONNECTION & HEADRE
@ -240,10 +240,10 @@
(let ((length (parse-integer (or (header-value :content-length headers) "") (let ((length (parse-integer (or (header-value :content-length headers) "")
:junk-allowed t))) :junk-allowed t)))
(unless quiet (unless quiet
(format t "~&;;; Downloading ~A bytes from ~A to ~A ...~%" (format t "~&;;; Downloading ~A bytes from ~A to ~A ...~%"
(or length "some unknown number of") (or length "some unknown number of")
url url
file-name)) file-name))
(force-output) (force-output)
(let ((ok? nil) (o nil)) (let ((ok? nil) (o nil))
(unwind-protect (unwind-protect
@ -251,8 +251,8 @@
(setf o (open file-name (setf o (open file-name
:direction :output :if-exists :supersede :direction :output :if-exists :supersede
:external-format :external-format
#-unicode :default #-unicode :default
#+unicode :latin-1)) #+unicode :latin-1))
(if length (if length
(let ((buf (make-array length (let ((buf (make-array length
:element-type :element-type

32
contrib/encodings/generate.lisp
View file

@ -21,13 +21,13 @@
(make-pathname :name name :type "BIN" (make-pathname :name name :type "BIN"
:defaults "build:encodings;")) :defaults "build:encodings;"))
do (progn do (progn
(unless (probe-file orig) (unless (probe-file orig)
(error "Missing mapping") (error "Missing mapping")
(let ((mapping (if (equalp name "JISX0208") (let ((mapping (if (equalp name "JISX0208")
(mapcar #'rest (read-mapping name 3)) (mapcar #'rest (read-mapping name 3))
(read-mapping name)))) (read-mapping name))))
(dump-mapping-array mapping orig))) (dump-mapping-array mapping orig)))
(copy-encoding-file orig copy))) (copy-encoding-file orig copy)))
(defconstant +aliases+ (defconstant +aliases+
'((:us-ascii ext::ascii) '((:us-ascii ext::ascii)
@ -88,17 +88,17 @@
(loop for (name . aliases) in +aliases+ (loop for (name . aliases) in +aliases+
do (loop with *package* = (find-package "CL") do (loop with *package* = (find-package "CL")
for alias in aliases for alias in aliases
for filename0 = (make-pathname :name (symbol-name alias) for filename0 = (make-pathname :name (symbol-name alias)
:defaults "build:encodings;") :defaults "build:encodings;")
for filename = (ensure-directories-exist filename0) for filename = (ensure-directories-exist filename0)
do (with-open-file (out filename :direction :output :if-exists :supersede do (with-open-file (out filename :direction :output :if-exists :supersede
:if-does-not-exist :create :element-type 'base-char) :if-does-not-exist :create :element-type 'base-char)
(format t "~%;;; Creating alias ~A -> ~A, ~A" alias name filename) (format t "~%;;; Creating alias ~A -> ~A, ~A" alias name filename)
(if (keywordp name) (if (keywordp name)
(format out "(defparameter ~S '~S)" alias name) (format out "(defparameter ~S '~S)" alias name)
(format out "(defparameter ~S (ext::make-encoding '~S))" alias name)) (format out "(defparameter ~S (ext::make-encoding '~S))" alias name))
))) )))
(copy-encoding-file "ext:encodings;tools.lisp" "build:encodings;tools.lisp") (copy-encoding-file "ext:encodings;tools.lisp" "build:encodings;tools.lisp")
(copy-encoding-file (merge-pathnames "ISO-2022-JP" +encodings-root+) (copy-encoding-file (merge-pathnames "ISO-2022-JP" +encodings-root+)

122
contrib/encodings/tools.lisp
View file

@ -13,10 +13,10 @@
(defconstant +source-pathname+ (defconstant +source-pathname+
(make-pathname :name nil :type nil (make-pathname :name nil :type nil
:directory (append (pathname-directory *load-pathname*) :directory (append (pathname-directory *load-pathname*)
(list "sources")) (list "sources"))
:host (pathname-host *load-pathname*) :host (pathname-host *load-pathname*)
:device (pathname-device *load-pathname*))) :device (pathname-device *load-pathname*)))
(defconstant +all-mappings+ (defconstant +all-mappings+
'(("ATARIST" "http://unicode.org/Public/MAPPINGS/VENDORS/MISC/ATARIST.TXT") '(("ATARIST" "http://unicode.org/Public/MAPPINGS/VENDORS/MISC/ATARIST.TXT")
@ -100,67 +100,67 @@
(unless (probe-file filename) (unless (probe-file filename)
(let ((command (format nil "curl \"~A\" > ~A" url filename))) (let ((command (format nil "curl \"~A\" > ~A" url filename)))
(unless (zerop (si::system command)) (unless (zerop (si::system command))
(error "Unable to retrieve file ~A" url))))) (error "Unable to retrieve file ~A" url)))))
(defun reformat (line) (defun reformat (line)
(loop with l = (length line) (loop with l = (length line)
for i from 0 below l for i from 0 below l
for c = (char line i) for c = (char line i)
do (cond ((eql c #\#) do (cond ((eql c #\#)
(return (if (zerop i) "" (subseq line 0 (1- i))))) (return (if (zerop i) "" (subseq line 0 (1- i)))))
((not (standard-char-p c)) ((not (standard-char-p c))
(setf (char line i) #\space)) (setf (char line i) #\space))
((and (eql c #\0) ((and (eql c #\0)
(let ((j (1+ i))) (let ((j (1+ i)))
(and (< j l) (member (char line j) '(#\x #\X))))) (and (< j l) (member (char line j) '(#\x #\X)))))
(setf (char line i) #\#))) (setf (char line i) #\#)))
finally (return line))) finally (return line)))
(defun read-mapping (name &optional (n 2)) (defun read-mapping (name &optional (n 2))
(let* ((source-file (make-pathname :name name :defaults +source-pathname+)) (let* ((source-file (make-pathname :name name :defaults +source-pathname+))
(record (find name +all-mappings+ :key #'first :test #'equalp)) (record (find name +all-mappings+ :key #'first :test #'equalp))
(fixes (third record)) (fixes (third record))
(source-url (fourth record))) (source-url (fourth record)))
(unless (probe-file source-file) (unless (probe-file source-file)
(unless source-url (unless source-url
(error "Unknown encoding ~A" name)) (error "Unknown encoding ~A" name))
(download file source-url)) (download file source-url))
(with-open-file (in source-file :direction :input) (with-open-file (in source-file :direction :input)
(loop with output = '() (loop with output = '()
for line = (reformat (read-line in nil nil)) for line = (reformat (read-line in nil nil))
while line while line
unless (zerop (length line)) unless (zerop (length line))
do (with-input-from-string (aux line) do (with-input-from-string (aux line)
(let ((byte-list (loop for byte = (read aux nil nil) (let ((byte-list (loop for byte = (read aux nil nil)
while byte while byte
collect byte))) collect byte)))
(unless (/= (length byte-list) n) (unless (/= (length byte-list) n)
(loop for i in fixes (loop for i in fixes
when (= (first i) (first byte-list)) when (= (first i) (first byte-list))
do (progn (setf byte-list i) (return))) do (progn (setf byte-list i) (return)))
(push byte-list output)))) (push byte-list output))))
finally (return (nreverse output)))))) finally (return (nreverse output))))))
(defun mapping-hash-table (mapping) (defun mapping-hash-table (mapping)
(loop with hash = (make-hash-table :size (floor (* 1.5 (length mapping))) (loop with hash = (make-hash-table :size (floor (* 1.5 (length mapping)))
:test 'eq) :test 'eq)
for (multibyte codepoint) in mapping for (multibyte codepoint) in mapping
for unicode-char = (code-char codepoint) for unicode-char = (code-char codepoint)
do (progn do (progn
(setf (gethash multibyte hash) unicode-char) (setf (gethash multibyte hash) unicode-char)
(setf (gethash unicode-char hash) multibyte) (setf (gethash unicode-char hash) multibyte)
(when (> multibyte #xFF) (when (> multibyte #xFF)
(setf (gethash (ash multibyte -8) hash) t))) (setf (gethash (ash multibyte -8) hash) t)))
finally (return hash))) finally (return hash)))
(defun dump-mapping-array (mapping-assoc output-file) (defun dump-mapping-array (mapping-assoc output-file)
(let* ((mapping-list (reduce #'nconc mapping-assoc)) (let* ((mapping-list (reduce #'nconc mapping-assoc))
(mapping-array (make-array (length mapping-list) :element-type +sequence-type+ (mapping-array (make-array (length mapping-list) :element-type +sequence-type+
:initial-contents mapping-list))) :initial-contents mapping-list)))
(format t "~%;;; Generating ~A" output-file) (format t "~%;;; Generating ~A" output-file)
(force-output t) (force-output t)
(with-open-file (s output-file :direction :output :if-exists :supersede (with-open-file (s output-file :direction :output :if-exists :supersede
:element-type +sequence-type+ :external-format :big-endian) :element-type +sequence-type+ :external-format :big-endian)
(write-byte (length mapping-array) s) (write-byte (length mapping-array) s)
(write-sequence mapping-array s)))) (write-sequence mapping-array s))))
@ -169,34 +169,34 @@
(format t "~%;;; Copying ~A to ~A" in out) (format t "~%;;; Copying ~A to ~A" in out)
(with-open-file (sin in :direction :input :element-type '(unsigned-byte 8)) (with-open-file (sin in :direction :input :element-type '(unsigned-byte 8))
(with-open-file (sout out :direction :output :element-type '(unsigned-byte 8) (with-open-file (sout out :direction :output :element-type '(unsigned-byte 8)
:if-exists :supersede :if-does-not-exist :create) :if-exists :supersede :if-does-not-exist :create)
(loop for nbytes = (read-sequence buffer sin) (loop for nbytes = (read-sequence buffer sin)
until (zerop nbytes) until (zerop nbytes)
do (write-sequence buffer sout :end nbytes)))))) do (write-sequence buffer sout :end nbytes))))))
(defun all-valid-unicode-chars (mapping) (defun all-valid-unicode-chars (mapping)
(cond ((consp mapping) (cond ((consp mapping)
(loop for sublist on mapping (loop for sublist on mapping
for i from 0 below 10 for i from 0 below 10
until (and (eq sublist mapping) (plusp i)) until (and (eq sublist mapping) (plusp i))
collect (all-valid-unicode-chars (first sublist)))) collect (all-valid-unicode-chars (first sublist))))
((hash-table-p mapping) ((hash-table-p mapping)
(concatenate 'string (loop for key being the hash-key in mapping (concatenate 'string (loop for key being the hash-key in mapping
when (characterp key) when (characterp key)
collect key))) collect key)))
((eq mapping :iso-8859-1) ((eq mapping :iso-8859-1)
(coerce 'string (loop for i from 0 to 255 collect (code-char i)))) (coerce 'string (loop for i from 0 to 255 collect (code-char i))))
(t (t
(error "Unknown encoding")))) (error "Unknown encoding"))))
(defun compare-hashes (h1 h2) (defun compare-hashes (h1 h2)
(flet ((h1-in-h2 (h1 h2) (flet ((h1-in-h2 (h1 h2)
(loop for k being the hash-key in h1 using (hash-value v) (loop for k being the hash-key in h1 using (hash-value v)
for v2 = (gethash k h2 nil) for v2 = (gethash k h2 nil)
unless (or (consp v2) (consp v) (equal v v2)) unless (or (consp v2) (consp v) (equal v v2))
do (progn (print (list h1 k v h2 k v2)) do (progn (print (list h1 k v h2 k v2))
(error) (error)
(return nil)) (return nil))
finally (return t)))) finally (return t))))
(and (h1-in-h2 h1 h2) (and (h1-in-h2 h1 h2)
(h1-in-h2 h2 h1)))) (h1-in-h2 h2 h1))))

50
contrib/profile/profile.lisp
View file

@ -61,15 +61,15 @@ extern ECL_API size_t GC_get_total_bytes();
(let () ; This prevents compile-time evaluation of the following (let () ; This prevents compile-time evaluation of the following
(defconstant +wrap+ (ffi:c-inline () () :object (defconstant +wrap+ (ffi:c-inline () () :object
"ecl_make_unsigned_integer(~((size_t)0))" "ecl_make_unsigned_integer(~((size_t)0))"
:one-liner t))) :one-liner t)))
(defun get-bytes-consed (orig) (defun get-bytes-consed (orig)
(let ((bytes (ffi:c-inline () () :object "ecl_make_unsigned_integer(GC_get_total_bytes())" (let ((bytes (ffi:c-inline () () :object "ecl_make_unsigned_integer(GC_get_total_bytes())"
:one-liner t))) :one-liner t)))
(if (< bytes orig) (if (< bytes orig)
(+ (- +wrap+ orig) bytes) (+ (- +wrap+ orig) bytes)
(- bytes orig)))) (- bytes orig))))
(deftype counter () '(integer 0 *)) (deftype counter () '(integer 0 *))
@ -206,28 +206,28 @@ extern ECL_API size_t GC_get_total_bytes();
(let ((dticks 0) (let ((dticks 0)
(dconsing 0) (dconsing 0)
(inner-enclosed-profiles 0) (inner-enclosed-profiles 0)
(old-enclosed-ticks *enclosed-ticks*) (old-enclosed-ticks *enclosed-ticks*)
(old-enclosed-consing *enclosed-consing*) (old-enclosed-consing *enclosed-consing*)
(old-enclosed-profiles *enclosed-profiles*) (old-enclosed-profiles *enclosed-profiles*)
(start-ticks (get-internal-ticks)) (start-ticks (get-internal-ticks))
(start-consed (get-bytes-consed 0))) (start-consed (get-bytes-consed 0)))
(unwind-protect (unwind-protect
(progn (progn
(setf *enclosed-ticks* 0 (setf *enclosed-ticks* 0
*enclosed-profiles* 0 *enclosed-profiles* 0
*enclosed-consing* 0) *enclosed-consing* 0)
(apply encapsulated-fun args)) (apply encapsulated-fun args))
(setf dticks (- (get-internal-ticks) start-ticks)) (setf dticks (- (get-internal-ticks) start-ticks))
(setf dconsing (get-bytes-consed start-consed)) (setf dconsing (get-bytes-consed start-consed))
(setf inner-enclosed-profiles *enclosed-profiles*) (setf inner-enclosed-profiles *enclosed-profiles*)
(let ((net-dticks (- dticks *enclosed-ticks*))) (let ((net-dticks (- dticks *enclosed-ticks*)))
(incf ticks net-dticks)) (incf ticks net-dticks))
(let ((net-dconsing (- dconsing *enclosed-consing*))) (let ((net-dconsing (- dconsing *enclosed-consing*)))
(incf consing net-dconsing)) (incf consing net-dconsing))
(incf profiles inner-enclosed-profiles) (incf profiles inner-enclosed-profiles)
(setf *enclosed-ticks* (+ old-enclosed-ticks dticks) (setf *enclosed-ticks* (+ old-enclosed-ticks dticks)
*enclosed-consing* (+ old-enclosed-consing dconsing) *enclosed-consing* (+ old-enclosed-consing dconsing)
*enclosed-profiles* (+ old-enclosed-profiles inner-enclosed-profiles 1))))) *enclosed-profiles* (+ old-enclosed-profiles inner-enclosed-profiles 1)))))
;; READ-STATS-FUN ;; READ-STATS-FUN
(lambda () (lambda ()
(values count ticks consing profiles)) (values count ticks consing profiles))

24
contrib/quicklisp/ecl-quicklisp.lisp
View file

@ -36,29 +36,29 @@
(ecl-curl:download-url-to-file *quicklisp-url* file) (ecl-curl:download-url-to-file *quicklisp-url* file)
(load file) (load file)
(eval (read-from-string (eval (read-from-string
(format nil "(quicklisp-quickstart:install :path ~S)" (format nil "(quicklisp-quickstart:install :path ~S)"
(namestring (truename target-directory)))) (namestring (truename target-directory))))
))) )))
(handler-case (handler-case
(progn (progn
(unless (probe-file *quicklisp-setup*) (unless (probe-file *quicklisp-setup*)
(install-quicklisp *quicklisp-directory*)) (install-quicklisp *quicklisp-directory*))
(unless (find-package "QL") (unless (find-package "QL")
(load *quicklisp-setup*)) (load *quicklisp-setup*))
(eval (read-from-string " (eval (read-from-string "
(pushnew #'(ext:lambda-block quicklisp-require (module) (pushnew #'(ext:lambda-block quicklisp-require (module)
(let* ((module (string-downcase module))) (let* ((module (string-downcase module)))
(when (find module (ql:provided-systems t) (when (find module (ql:provided-systems t)
:test #'string-equal :test #'string-equal
:key #'ql-dist:name) :key #'ql-dist:name)
(and (ql:quickload module) (and (ql:quickload module)
(provide module))))) (provide module)))))
sys::*module-provider-functions*) sys::*module-provider-functions*)
"))) ")))
(error (c) (error (c)
(format t "~%;;; Unable to load / install quicklisp. Error message follows:~%~A" (format t "~%;;; Unable to load / install quicklisp. Error message follows:~%~A"
c))) c)))
(provide "ecl-quicklisp") (provide "ecl-quicklisp")

58
contrib/serve-event/serve-event.lisp
View file

@ -175,19 +175,19 @@
(setf maxfd fd)))) (setf maxfd fd))))
(multiple-value-bind (retval errno) (multiple-value-bind (retval errno)
(if (null seconds) (if (null seconds)
;; No timeout ;; No timeout
(c-inline (rfd wfd (1+ maxfd)) (c-inline (rfd wfd (1+ maxfd))
(:object :object :int) (values :int :int) (:object :object :int) (values :int :int)
"{ @(return 0) = select(#2, (fd_set*)#0->foreign.data, "{ @(return 0) = select(#2, (fd_set*)#0->foreign.data,
(fd_set*)#1->foreign.data, (fd_set*)#1->foreign.data,
NULL, NULL); NULL, NULL);
@(return 1) = errno; }" @(return 1) = errno; }"
:one-liner nil :one-liner nil
:side-effects t) :side-effects t)
(c-inline (rfd wfd (1+ maxfd) seconds) (c-inline (rfd wfd (1+ maxfd) seconds)
(:object :object :int :double) (values :int :int) (:object :object :int :double) (values :int :int)
"{ struct timeval tv; "{ struct timeval tv;
double seconds = #3; double seconds = #3;
tv.tv_sec = seconds; tv.tv_sec = seconds;
tv.tv_usec = (seconds * 1e6); tv.tv_usec = (seconds * 1e6);
@ -195,26 +195,26 @@
(fd_set*)#1->foreign.data, (fd_set*)#1->foreign.data,
NULL, &tv); NULL, &tv);
@(return 1) = errno; }" @(return 1) = errno; }"
:one-liner nil :one-liner nil
:side-effects t)) :side-effects t))
(cond ((zerop retval) (cond ((zerop retval)
nil) nil)
((minusp retval) ((minusp retval)
(if (= errno +eintr+) (if (= errno +eintr+)
;; suppress EINTR ;; suppress EINTR
nil nil
;; otherwise error ;; otherwise error
(error "Error during select"))) (error "Error during select")))
((plusp retval) ((plusp retval)
(dolist (handler *descriptor-handlers*) (dolist (handler *descriptor-handlers*)
(let ((fd (handler-descriptor handler))) (let ((fd (handler-descriptor handler)))
(if (plusp (ecase (handler-direction handler) (if (plusp (ecase (handler-direction handler)
(:input (fd-isset fd rfd)) (:input (fd-isset fd rfd))
(:output (fd-isset fd wfd)))) (:output (fd-isset fd wfd))))
(funcall (handler-function handler) (funcall (handler-function handler)
(handler-descriptor handler))))) (handler-descriptor handler)))))
t))))))) t)))))))
;;; Wait for up to timeout seconds for an event to happen. Make sure all ;;; Wait for up to timeout seconds for an event to happen. Make sure all

18
contrib/sockets/package.lisp
View file

@ -13,12 +13,12 @@
(defpackage "SB-BSD-SOCKETS" (defpackage "SB-BSD-SOCKETS"
(:use "CL" "FFI" "SI") (:use "CL" "FFI" "SI")
(:export "GET-HOST-BY-NAME" "GET-HOST-BY-ADDRESS" (:export "GET-HOST-BY-NAME" "GET-HOST-BY-ADDRESS"
"SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT" "SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT"
"SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN" "SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN"
"SOCKET-RECEIVE" "SOCKET-CLOSE" "SOCKET-MAKE-STREAM" "SOCKET-RECEIVE" "SOCKET-CLOSE" "SOCKET-MAKE-STREAM"
"GET-PROTOCOL-BY-NAME" "MAKE-INET-ADDRESS" "LOCAL-SOCKET" "GET-PROTOCOL-BY-NAME" "MAKE-INET-ADDRESS" "LOCAL-SOCKET"
"SOCKET" "INET-SOCKET" "SOCKET-FILE-DESCRIPTOR" #+:win32 "NAMED-PIPE-SOCKET" "SOCKET" "INET-SOCKET" "SOCKET-FILE-DESCRIPTOR" #+:win32 "NAMED-PIPE-SOCKET"
"SOCKET-FAMILY" "SOCKET-PROTOCOL" "SOCKET-TYPE" "SOCKET-FAMILY" "SOCKET-PROTOCOL" "SOCKET-TYPE"
"SOCKET-ERROR" "NAME-SERVICE-ERROR" "NON-BLOCKING-MODE" "SOCKET-ERROR" "NAME-SERVICE-ERROR" "NON-BLOCKING-MODE"
"HOST-ENT-NAME" "HOST-ENT-ALIASES" "HOST-ENT-ADDRESS-TYPE" "HOST-ENT-NAME" "HOST-ENT-ALIASES" "HOST-ENT-ADDRESS-TYPE"
"HOST-ENT-ADDRESSES" "HOST-ENT" "HOST-ENT-ADDRESS" "SOCKET-SEND")) "HOST-ENT-ADDRESSES" "HOST-ENT" "HOST-ENT-ADDRESS" "SOCKET-SEND"))

994
contrib/sockets/sockets.lisp
View file

File diff suppressed because it is too large Load diff

104
contrib/sockets/test.lisp
View file

@ -43,18 +43,18 @@
;; fail to make a socket: check correct error return. There's no nice ;; fail to make a socket: check correct error return. There's no nice
;; way to check the condition stuff on its own, which is a shame ;; way to check the condition stuff on its own, which is a shame
(handler-case (handler-case
(make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp")) (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp"))
((or socket-type-not-supported-error protocol-not-supported-error) (c) ((or socket-type-not-supported-error protocol-not-supported-error) (c)
(declare (ignorable c)) t) (declare (ignorable c)) t)
(:no-error nil)) (:no-error nil))
t) t)
(deftest make-inet-socket-keyword-wrong (deftest make-inet-socket-keyword-wrong
;; same again with keywords ;; same again with keywords
(handler-case (handler-case
(make-instance 'inet-socket :type :stream :protocol :udp) (make-instance 'inet-socket :type :stream :protocol :udp)
((or protocol-not-supported-error socket-type-not-supported-error) (c) ((or protocol-not-supported-error socket-type-not-supported-error) (c)
(declare (ignorable c)) t) (declare (ignorable c)) t)
(:no-error nil)) (:no-error nil))
t) t)
@ -83,9 +83,9 @@
(do-gc-portably) ;gc should clear out any old sockets bound to this port (do-gc-portably) ;gc should clear out any old sockets bound to this port
(socket-bind s (make-inet-address "127.0.0.1") 1974) (socket-bind s (make-inet-address "127.0.0.1") 1974)
(handler-case (handler-case
(let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
(socket-bind s2 (make-inet-address "127.0.0.1") 1974) (socket-bind s2 (make-inet-address "127.0.0.1") 1974)
nil) nil)
(address-in-use-error () t))) (address-in-use-error () t)))
t) t)
@ -113,23 +113,23 @@
;;; these require that the echo services are turned on in inetd ;;; these require that the echo services are turned on in inetd
(deftest simple-tcp-client (deftest simple-tcp-client
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
(data (make-string 200))) (data (make-string 200)))
(socket-connect s #(127 0 0 1) 7) (socket-connect s #(127 0 0 1) 7)
(let ((stream (socket-make-stream s :input t :output t :buffering :none))) (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
(format stream "here is some text") (format stream "here is some text")
(let ((data (subseq data 0 (read-buf-nonblock data stream)))) (let ((data (subseq data 0 (read-buf-nonblock data stream))))
(format t "~&Got ~S back from TCP echo server~%" data) (format t "~&Got ~S back from TCP echo server~%" data)
(> (length data) 0)))) (> (length data) 0))))
t) t)
(deftest sockaddr-return-type (deftest sockaddr-return-type
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
(unwind-protect (unwind-protect
(progn (progn
(socket-connect s #(127 0 0 1) 7) (socket-connect s #(127 0 0 1) 7)
(multiple-value-bind (host port) (socket-peername s) (multiple-value-bind (host port) (socket-peername s)
(and (vectorp host) (and (vectorp host)
(numberp port)))) (numberp port))))
(socket-close s))) (socket-close s)))
t) t)
@ -142,8 +142,8 @@
(format stream "here is some text") (format stream "here is some text")
(finish-output stream) (finish-output stream)
(let ((data (subseq data 0 (read-buf-nonblock data stream)))) (let ((data (subseq data 0 (read-buf-nonblock data stream))))
(format t "~&Got ~S back from UDP echo server~%" data) (format t "~&Got ~S back from UDP echo server~%" data)
(> (length data) 0)))) (> (length data) 0))))
t) t)
;;; A fairly rudimentary test that connects to the syslog socket and ;;; A fairly rudimentary test that connects to the syslog socket and
@ -158,23 +158,23 @@
;; unavailable, or if it's a symlink to some weird character ;; unavailable, or if it's a symlink to some weird character
;; device. ;; device.
(when (and (probe-file "/dev/log") (when (and (probe-file "/dev/log")
#-ecl #-ecl
(sb-posix:s-issock (sb-posix:s-issock
(sb-posix::stat-mode (sb-posix:stat "/dev/log")))) (sb-posix::stat-mode (sb-posix:stat "/dev/log"))))
(let ((s (make-instance 'local-socket :type :datagram))) (let ((s (make-instance 'local-socket :type :datagram)))
(format t "Connecting ~A... " s) (format t "Connecting ~A... " s)
(finish-output) (finish-output)
(handler-case (handler-case
(socket-connect s "/dev/log") (socket-connect s "/dev/log")
(socket-error () (socket-error ()
(setq s (make-instance 'local-socket :type :stream)) (setq s (make-instance 'local-socket :type :stream))
(format t "failed~%Retrying with ~A... " s) (format t "failed~%Retrying with ~A... " s)
(finish-output) (finish-output)
(socket-connect s "/dev/log"))) (socket-connect s "/dev/log")))
(format t "ok.~%") (format t "ok.~%")
(let ((stream (socket-make-stream s :input t :output t :buffering :none))) (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
(format stream (format stream
"<7>sb-bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored")))) "<7>sb-bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored"))))
t) t)
t) t)
@ -207,13 +207,13 @@
(deftest simple-http-client-1 (deftest simple-http-client-1
(handler-case (handler-case
(let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) (let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
(let ((data (make-string 200))) (let ((data (make-string 200)))
(setf data (subseq data 0 (setf data (subseq data 0
(read-buf-nonblock data (read-buf-nonblock data
(socket-make-stream s)))) (socket-make-stream s))))
(princ data) (princ data)
(> (length data) 0))) (> (length data) 0)))
(network-unreachable-error () 'network-unreachable)) (network-unreachable-error () 'network-unreachable))
t) t)
@ -223,14 +223,14 @@
;; kernel: we set a size of x and then getsockopt() returns 2x. ;; kernel: we set a size of x and then getsockopt() returns 2x.
;; This is why we compare with >= instead of = ;; This is why we compare with >= instead of =
(handler-case (handler-case
(let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) (let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
(setf (sockopt-receive-buffer s) 1975) (setf (sockopt-receive-buffer s) 1975)
(let ((data (make-string 200))) (let ((data (make-string 200)))
(setf data (subseq data 0 (setf data (subseq data 0
(read-buf-nonblock data (read-buf-nonblock data
(socket-make-stream s)))) (socket-make-stream s))))
(and (> (length data) 0) (and (> (length data) 0)
(>= (sockopt-receive-buffer s) 1975)))) (>= (sockopt-receive-buffer s) 1975))))
(network-unreachable-error () 'network-unreachable)) (network-unreachable-error () 'network-unreachable))
t) t)
@ -253,4 +253,4 @@
(loop (loop
(multiple-value-bind (buf len address port) (socket-receive s nil 500) (multiple-value-bind (buf len address port) (socket-receive s nil 500)
(format t "Received ~A bytes from ~A:~A - ~A ~%" (format t "Received ~A bytes from ~A:~A - ~A ~%"
len address port (subseq buf 0 (min 10 len))))))) len address port (subseq buf 0 (min 10 len)))))))

62
contrib/unicode/load-names.lisp
View file

@ -6,23 +6,23 @@
for c across text for c across text
when (member c set) when (member c set)
do (setf output (list* (make-array (+ (- i start) (if exclude 0 1)) do (setf output (list* (make-array (+ (- i start) (if exclude 0 1))
:element-type elt-type :element-type elt-type
:displaced-to text :displaced-to text
:displaced-index-offset start) :displaced-index-offset start)
output) output)
start (1+ i)) start (1+ i))
finally (return (nreverse (list* (make-array (- i start) finally (return (nreverse (list* (make-array (- i start)
:element-type elt-type :element-type elt-type
:displaced-to text :displaced-to text
:displaced-index-offset start) :displaced-index-offset start)
output))))) output)))))
(defun encode-words (words hash) (defun encode-words (words hash)
(loop for word in words (loop for word in words
collect (or (gethash word hash) collect (or (gethash word hash)
(let* ((word (copy-seq word)) (let* ((word (copy-seq word))
(ndx (hash-table-count hash))) (ndx (hash-table-count hash)))
(setf (gethash word hash) (1+ ndx)))))) (setf (gethash word hash) (1+ ndx))))))
(defun fixup-hangul-syllables (dictionary) (defun fixup-hangul-syllables (dictionary)
;; "Hangul Syllable Composition, Unicode 5.1 section 3-12" ;; "Hangul Syllable Composition, Unicode 5.1 section 3-12"
@ -47,11 +47,11 @@
for v = (+ vbase (floor (mod sindex ncount) tcount)) for v = (+ vbase (floor (mod sindex ncount) tcount))
for tee = (+ tbase (mod sindex tcount)) for tee = (+ tbase (mod sindex tcount))
for name = (list* "HANGUL_" "SYLLABLE_" for name = (list* "HANGUL_" "SYLLABLE_"
(gethash l table) (gethash v table) (gethash l table) (gethash v table)
(unless (= tee tbase) (list (gethash tee table)))) (unless (= tee tbase) (list (gethash tee table))))
for code = (+ sbase sindex) for code = (+ sbase sindex)
collect (list* code (apply #'concatenate 'string name) collect (list* code (apply #'concatenate 'string name)
(encode-words name dictionary))))) (encode-words name dictionary)))))
(defun add-jamo-information (line table) (defun add-jamo-information (line table)
(let* ((split (split-words line :set '(#\;) :exclude t)) (let* ((split (split-words line :set '(#\;) :exclude t))
@ -68,17 +68,17 @@
for ucd-line = (read-line in nil nil nil) for ucd-line = (read-line in nil nil nil)
while ucd-line while ucd-line
nconc (let* ((ucd-data (split-words ucd-line :set '(#\;))) nconc (let* ((ucd-data (split-words ucd-line :set '(#\;)))
(code (first ucd-data)) (code (first ucd-data))
(name (second ucd-data))) (name (second ucd-data)))
(unless (eql (char name 0) #\<) (unless (eql (char name 0) #\<)
(setf name (substitute #\_ #\Space name)) (setf name (substitute #\_ #\Space name))
(list (list* (parse-integer code :radix 16) (list (list* (parse-integer code :radix 16)
name name
(encode-words (split-words (encode-words (split-words
name name
:set '(#\Space #\_ #\-) :set '(#\Space #\_ #\-)
:exclude nil) :exclude nil)
words)))))))) words))))))))
(print (length *data*)) (print (length *data*))
(print (first (last *data*))) (print (first (last *data*)))
@ -86,9 +86,9 @@
;#+(or) ;#+(or)
(progn (progn
(setf *data* (setf *data*
(sort (nconc (fixup-hangul-syllables *words*) *data*) (sort (nconc (fixup-hangul-syllables *words*) *data*)
#'< #'<
:key #'car)) :key #'car))
(print (length *data*)) (print (length *data*))
(print (first (last *data*)))) (print (first (last *data*))))
@ -117,7 +117,7 @@
with last = start with last = start
for (code name . rest) in *data* for (code name . rest) in *data*
do (when (>= (- code last) 2) do (when (>= (- code last) 2)
(setf output (cons (list start last) output) (setf output (cons (list start last) output)
start code)) start code))
(setf last code) (setf last code)
finally (return (nreverse (cons (list start code) output))))) finally (return (nreverse (cons (list start code) output)))))

124
contrib/unicode/names-pairs-sort.lisp
View file

@ -1,6 +1,6 @@
(defparameter *destination* (defparameter *destination*
(merge-pathnames "../../src/c/unicode/" (merge-pathnames "../../src/c/unicode/"
(or *load-truename* *compile-pathname*))) (or *load-truename* *compile-pathname*)))
(let* ((translated-data (copy-tree *compressed-data*)) (let* ((translated-data (copy-tree *compressed-data*))
(pairs (copy-tree *paired-data*)) (pairs (copy-tree *paired-data*))
@ -14,39 +14,39 @@
for line in translated-data for line in translated-data
for pair-code = (third line) for pair-code = (third line)
do (cond ((/= (length line) 3) do (cond ((/= (length line) 3)
(error "Error in compressed data: too long code ~A" line)) (error "Error in compressed data: too long code ~A" line))
((or (aref used-code pair-code) ((or (aref used-code pair-code)
(< pair-code first-code)) (< pair-code first-code))
(let ((new-pair (cons pair-code 0))) (let ((new-pair (cons pair-code 0)))
(setf pairs (acons (incf last-code) new-pair pairs) (setf pairs (acons (incf last-code) new-pair pairs)
(third line) last-code))) (third line) last-code)))
(t (t
(setf (aref used-code pair-code) t)))) (setf (aref used-code pair-code) t))))
;; ;;
;; We now renumber all pairs. ;; We now renumber all pairs.
;; ;;
(let ((translation-table (make-array (1+ last-code) :initial-element nil)) (let ((translation-table (make-array (1+ last-code) :initial-element nil))
(counter -1)) (counter -1))
(flet ((add-code (code) (flet ((add-code (code)
(or (aref translation-table code) (or (aref translation-table code)
(setf (aref translation-table code) (incf counter)))) (setf (aref translation-table code) (incf counter))))
(translate (old-code) (translate (old-code)
(or (aref translation-table old-code) (or (aref translation-table old-code)
(error "Unknown code ~A" old-code)))) (error "Unknown code ~A" old-code))))
;; First of all we add the words ;; First of all we add the words
(loop for i from 0 below first-code (loop for i from 0 below first-code
do (add-code i)) do (add-code i))
;; Then we add all pairs that represent characters, so that they ;; Then we add all pairs that represent characters, so that they
;; are consecutive, too. ;; are consecutive, too.
(loop for line in translated-data (loop for line in translated-data
do (setf (third line) (add-code (third line)))) do (setf (third line) (add-code (third line))))
;; Finally, we add the remaining pairs ;; Finally, we add the remaining pairs
(loop for record in pairs (loop for record in pairs
do (setf (car record) (add-code (car record)))) do (setf (car record) (add-code (car record))))
;; ... and we fix the definitions ;; ... and we fix the definitions
(loop for (code . pair) in pairs (loop for (code . pair) in pairs
do (setf (car pair) (translate (car pair)) do (setf (car pair) (translate (car pair))
(cdr pair) (translate (cdr pair)))))) (cdr pair) (translate (cdr pair))))))
(defparameter *sorted-compressed-data* translated-data) (defparameter *sorted-compressed-data* translated-data)
(defparameter *sorted-pairs* (sort pairs #'< :key #'car)) (defparameter *sorted-pairs* (sort pairs #'< :key #'car))
(print 'finished) (print 'finished)
@ -62,24 +62,24 @@
for line in *sorted-compressed-data* for line in *sorted-compressed-data*
for (ucd-code name code) = line for (ucd-code name code) = line
do (cond ((/= code n) do (cond ((/= code n)
(error "Codes in *sorted-compressed-data* are not consecutive:~%~A" (error "Codes in *sorted-compressed-data* are not consecutive:~%~A"
(cons line (subseq aux 0 10)))) (cons line (subseq aux 0 10))))
((null start-ucd-code) ((null start-ucd-code)
(setf start-ucd-code ucd-code (setf start-ucd-code ucd-code
start-code code)) start-code code))
((= last-ucd-code (1- ucd-code)) ((= last-ucd-code (1- ucd-code))
) )
(t (t
(push (list start-ucd-code last-ucd-code start-code) (push (list start-ucd-code last-ucd-code start-code)
output) output)
(setf start-ucd-code ucd-code (setf start-ucd-code ucd-code
start-code code))) start-code code)))
(setf last-ucd-code ucd-code aux (cons line aux)) (setf last-ucd-code ucd-code aux (cons line aux))
finally (return (nreverse output)))) finally (return (nreverse output))))
(with-open-file (s (merge-pathnames "ucd_names.h" *destination*) (with-open-file (s (merge-pathnames "ucd_names.h" *destination*)
:direction :output :direction :output
:if-exists :supersede) :if-exists :supersede)
(format s "/* (format s "/*
* UNICODE NAMES DATABASE * UNICODE NAMES DATABASE
*/ */
@ -112,17 +112,17 @@ extern const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES];
#endif #endif
" "
(1+ *last-word-index*) (1+ *last-word-index*)
(length *sorted-pairs*) (length *sorted-pairs*)
(length *grouped-characters*) (length *grouped-characters*)
(loop for (code name . rest) in *compressed-data* (loop for (code name . rest) in *compressed-data*
maximize (length name)) maximize (length name))
(length *compressed-data*) (length *compressed-data*)
)) ))
(with-open-file (s (merge-pathnames "ucd_names_pair.c" *destination*) (with-open-file (s (merge-pathnames "ucd_names_pair.c" *destination*)
:direction :output :direction :output
:if-exists :supersede) :if-exists :supersede)
(format s "/* (format s "/*
* Pairs of symbols. * Pairs of symbols.
*/ */
@ -132,19 +132,19 @@ extern const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES];
const ecl_ucd_names_pair_type ecl_ucd_names_pair[ECL_UCD_TOTAL_PAIRS] = { const ecl_ucd_names_pair_type ecl_ucd_names_pair[ECL_UCD_TOTAL_PAIRS] = {
" "
(length *sorted-pairs*) (length *sorted-pairs*)) (length *sorted-pairs*) (length *sorted-pairs*))
(loop for i from 0 (loop for i from 0
for (pair-code . (a . b)) in *sorted-pairs* for (pair-code . (a . b)) in *sorted-pairs*
do (format s "~A{~D, ~D, ~D, ~D}~%" do (format s "~A{~D, ~D, ~D, ~D}~%"
(if (plusp i) "," "") (if (plusp i) "," "")
(logand a #xff) (ash a -8) (logand a #xff) (ash a -8)
(logand b #xff) (ash b -8) (logand b #xff) (ash b -8)
)) ))
(format s "};~%")) (format s "};~%"))
(with-open-file (s (merge-pathnames "ucd_names_codes.c" *destination*) (with-open-file (s (merge-pathnames "ucd_names_codes.c" *destination*)
:direction :output :direction :output
:if-exists :supersede) :if-exists :supersede)
(format s "/* (format s "/*
* Sorted character names. * Sorted character names.
*/ */
@ -158,15 +158,15 @@ const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES] = {
for (ucd-code name code) in l for (ucd-code name code) in l
for i from 0 for i from 0
do (format s "~A{{~D, ~D}, {~D, ~D, ~D}}~%" do (format s "~A{{~D, ~D}, {~D, ~D, ~D}}~%"
(if (plusp i) "," "") (if (plusp i) "," "")
(logand code #xff) (ash code -8) (logand code #xff) (ash code -8)
(logand ucd-code #xff) (logand (ash ucd-code -8) #xff) (logand ucd-code #xff) (logand (ash ucd-code -8) #xff)
(logand (ash ucd-code -16) #xff))) (logand (ash ucd-code -16) #xff)))
(format s "};")) (format s "};"))
(with-open-file (s (merge-pathnames "ucd_names_str.c" *destination*) (with-open-file (s (merge-pathnames "ucd_names_str.c" *destination*)
:direction :output :direction :output
:if-exists :supersede) :if-exists :supersede)
(format s "/* (format s "/*
* Dictionary words. * Dictionary words.
*/ */
@ -182,8 +182,8 @@ const char *ecl_ucd_names_word[ECL_UCD_FIRST_PAIR] = {
(format s "};~%")) (format s "};~%"))
(with-open-file (s (merge-pathnames "ucd_names_char.c" *destination*) (with-open-file (s (merge-pathnames "ucd_names_char.c" *destination*)
:direction :output :direction :output
:if-exists :supersede) :if-exists :supersede)
(format s "/* (format s "/*
* Dictionary words. * Dictionary words.
*/ */
@ -194,11 +194,11 @@ const char *ecl_ucd_names_word[ECL_UCD_FIRST_PAIR] = {
const ecl_ucd_names_char_group ecl_ucd_names_char[ECL_UCD_TOTAL_GROUPS] = { const ecl_ucd_names_char_group ecl_ucd_names_char[ECL_UCD_TOTAL_GROUPS] = {
" "
(length *grouped-characters*)) (length *grouped-characters*))
(loop for i from 0 (loop for i from 0
for (start end pair-code) in *grouped-characters* for (start end pair-code) in *grouped-characters*
do (format s "~A{~D,~D,~D}~%" (if (plusp i) "," "") do (format s "~A{~D,~D,~D}~%" (if (plusp i) "," "")
start end pair-code)) start end pair-code))
(format s "}; (format s "};
static int static int
@ -266,7 +266,7 @@ _ecl_ucd_name_to_code(cl_object name)
ecl_character c = ecl_char_upcase(ecl_char(name, mid)); ecl_character c = ecl_char_upcase(ecl_char(name, mid));
buffer1[mid] = c; buffer1[mid] = c;
if (c < 32 || c > 127) /* All character names are [-A-Z_0-9]* */ if (c < 32 || c > 127) /* All character names are [-A-Z_0-9]* */
return ECL_NIL; return ECL_NIL;
} }
buffer1[mid] = 0; buffer1[mid] = 0;
do { do {
@ -295,4 +295,4 @@ _ecl_ucd_name_to_code(cl_object name)
")) "))
;(ext:run-program "/bin/sh" '("-c" "cp *.c *.h ~/devel/ecl/src/c/unicode/")) ;(ext:run-program "/bin/sh" '("-c" "cp *.c *.h ~/devel/ecl/src/c/unicode/"))

84
contrib/unicode/names-pairs.lisp
View file

@ -10,32 +10,32 @@
with max-pair = nil with max-pair = nil
for (code name . l) in data for (code name . l) in data
do (loop for l2 on l do (loop for l2 on l
for a = (car l2) for a = (car l2)
for b = (cadr l2) for b = (cadr l2)
while b while b
do (let* ((pair (cons a b)) do (let* ((pair (cons a b))
(c (gethash pair table))) (c (gethash pair table)))
(setf (gethash pair table) (setf (gethash pair table)
(setf c (if c (1+ c) 1)) (setf c (if c (1+ c) 1))
a b) a b)
(when (> c max) (when (> c max)
(setf max c max-pair pair)))) (setf max c max-pair pair))))
finally (return (cons max max-pair)))) finally (return (cons max max-pair))))
(defun replace-pair (pair code data) (defun replace-pair (pair code data)
(let ((old-a (car pair)) (let ((old-a (car pair))
(old-b (cdr pair))) (old-b (cdr pair)))
(loop with more = 0 (loop with more = 0
for (ucd-code name . l) in data for (ucd-code name . l) in data
do (loop with l2 = l do (loop with l2 = l
for a = (first l2) for a = (first l2)
for b = (second l2) for b = (second l2)
while b while b
do (when (and (eql a old-a) (eql b old-b)) do (when (and (eql a old-a) (eql b old-b))
;; replace (a b . c) with (pair . c) ;; replace (a b . c) with (pair . c)
(setf (car l2) code (setf (car l2) code
(cdr l2) (cddr l2))) (cdr l2) (cddr l2)))
do (setf l2 (cdr l2))) do (setf l2 (cdr l2)))
do (setf more (+ more (1- (length l)))) do (setf more (+ more (1- (length l))))
finally (return more)))) finally (return more))))
@ -48,21 +48,21 @@
while (and pair (> frequency 1)) while (and pair (> frequency 1))
do do
(format t "~%;;; ~A, ~D -> ~D, ~D left" pair frequency new-symbol (format t "~%;;; ~A, ~D -> ~D, ~D left" pair frequency new-symbol
(replace-pair pair new-symbol data)) (replace-pair pair new-symbol data))
(setf pairs (acons new-symbol pair pairs)) (setf pairs (acons new-symbol pair pairs))
finally finally
;; There are no redundant pairs. We just define ad-hoc new ;; There are no redundant pairs. We just define ad-hoc new
;; symbols for all remaining strings. ;; symbols for all remaining strings.
(loop with n = new-symbol (loop with n = new-symbol
for (code name . l) in data for (code name . l) in data
do (loop with l2 = l do (loop with l2 = l
for a = (first l2) for a = (first l2)
for b = (second l2) for b = (second l2)
while b while b
do (setf pairs (acons n (cons a b) pairs) do (setf pairs (acons n (cons a b) pairs)
(car l2) n (car l2) n
(cdr l2) (cddr l2) (cdr l2) (cddr l2)
n (1+ n)))) n (1+ n))))
(print 'finished) (print 'finished)
(return-from compress (nreverse pairs)))) (return-from compress (nreverse pairs))))
@ -75,13 +75,13 @@
(defparameter *code-ndx-size* (ceiling (integer-length *last-code*) 8)) (defparameter *code-ndx-size* (ceiling (integer-length *last-code*) 8))
(defparameter *pair-table-size* (* (length *paired-data*) (defparameter *pair-table-size* (* (length *paired-data*)
(* 2 *code-ndx-size*))) (* 2 *code-ndx-size*)))
(defparameter *code-to-name-bytes* (defparameter *code-to-name-bytes*
(* (length *compressed-data*) (* (length *compressed-data*)
(+ 3 ; Size of Unicode code (+ 3 ; Size of Unicode code
;; Size of index into the data table ;; Size of index into the data table
*code-ndx-size*))) *code-ndx-size*)))
(defparameter *sorted-names-bytes* (defparameter *sorted-names-bytes*
;; The sorted list of character names is just a list of indices into ;; The sorted list of character names is just a list of indices into
@ -98,16 +98,16 @@
;;; Names to codes table = ~D bytes ;;; Names to codes table = ~D bytes
;;; Total = ~D bytes ;;; Total = ~D bytes
" "
*word-dictionary* *word-dictionary*
*pair-table-size* *pair-table-size*
*code-to-name-bytes* *code-to-name-bytes*
*sorted-names-bytes* *sorted-names-bytes*
(+ (+
*word-dictionary* *word-dictionary*
*pair-table-size* *pair-table-size*
*code-to-name-bytes* *code-to-name-bytes*
*sorted-names-bytes* *sorted-names-bytes*
)) ))
;;; WITH HANGUL ;;; WITH HANGUL
;;; Codes dictionary = 78566 bytes ;;; Codes dictionary = 78566 bytes

10
contrib/unicode/ucd.lisp
View file

@ -104,8 +104,8 @@
(setq *decomposition-base* (make-array (total-ucd-pages) :initial-element nil)) (setq *decomposition-base* (make-array (total-ucd-pages) :initial-element nil))
(setq *ucd-base* (make-array (total-ucd-pages) :initial-element nil)) (setq *ucd-base* (make-array (total-ucd-pages) :initial-element nil))
(with-open-file (*standard-input* (with-open-file (*standard-input*
(make-pathname :name "UnicodeData" :type "txt" (make-pathname :name "UnicodeData" :type "txt"
:defaults *extension-directory*) :defaults *extension-directory*)
:direction :input :external-format :default) :direction :input :external-format :default)
(loop for line = (read-line nil nil) (loop for line = (read-line nil nil)
while line while line
@ -327,9 +327,9 @@
:element-type '(unsigned-byte 8) :element-type '(unsigned-byte 8)
:if-exists :supersede :if-exists :supersede
:if-does-not-exist :create) :if-does-not-exist :create)
(let ((offset (* (length *misc-table*) 8))) (let ((offset (* (length *misc-table*) 8)))
(write-byte (mod offset *page-size*) stream) (write-byte (mod offset *page-size*) stream)
(write-byte (floor offset *page-size*) stream)) (write-byte (floor offset *page-size*) stream))
(loop for (gc-index bidi-index ccc-index decimal-digit digit (loop for (gc-index bidi-index ccc-index decimal-digit digit
bidi-mirrored) bidi-mirrored)
across *misc-table* across *misc-table*

722
contrib/win32/lisp-kw.lisp
View file

@ -1,371 +1,371 @@
(in-package "WIN32") (in-package "WIN32")
(defparameter *txtedit-lisp-kw* (defparameter *txtedit-lisp-kw*
"* find-method pprint-indent "* find-method pprint-indent
** find-package pprint-linear ** find-package pprint-linear
*** find-restart pprint-logical-block *** find-restart pprint-logical-block
+ find-symbol pprint-newline + find-symbol pprint-newline
++ finish-output pprint-pop ++ finish-output pprint-pop
+++ first pprint-tab +++ first pprint-tab
- fixnum pprint-tabular - fixnum pprint-tabular
/ flet prin1 / flet prin1
// float prin1-to-string // float prin1-to-string
/// float-digits princ /// float-digits princ
/= float-precision princ-to-string /= float-precision princ-to-string
1+ float-radix print 1+ float-radix print
1- float-sign print-not-readable 1- float-sign print-not-readable
< floating-point-inexact print-not-readable-object < floating-point-inexact print-not-readable-object
<= floating-point-invalid-operation print-object <= floating-point-invalid-operation print-object
= floating-point-overflow print-unreadable-object = floating-point-overflow print-unreadable-object
> floating-point-underflow probe-file > floating-point-underflow probe-file
>= floatp proclaim >= floatp proclaim
abort floor prog abort floor prog
abs fmakunbound prog* abs fmakunbound prog*
access force-output prog1 access force-output prog1
acons format prog2 acons format prog2
acos formatter progn acos formatter progn
acosh fourth program-error acosh fourth program-error
add-method fresh-line progv add-method fresh-line progv
adjoin fround provide adjoin fround provide
adjust-array ftruncate psetf adjust-array ftruncate psetf
adjustable-array-p ftype psetq adjustable-array-p ftype psetq
allocate-instance funcall push allocate-instance funcall push
alpha-char-p function pushnew alpha-char-p function pushnew
alphanumericp function-keywords putprop alphanumericp function-keywords putprop
and function-lambda-expression quote and function-lambda-expression quote
append functionp random append functionp random
apply gbitp random-state apply gbitp random-state
applyhook gcd random-state-p applyhook gcd random-state-p
apropos generic-function rassoc apropos generic-function rassoc
apropos-list gensym rassoc-if apropos-list gensym rassoc-if
aref gentemp rassoc-if-not aref gentemp rassoc-if-not
arithmetic-error get ratio arithmetic-error get ratio
arithmetic-error-operands get-decoded-time rational arithmetic-error-operands get-decoded-time rational
arithmetic-error-operation get-dispatch-macro-character rationalize arithmetic-error-operation get-dispatch-macro-character rationalize
array get-internal-real-time rationalp array get-internal-real-time rationalp
array-dimension get-internal-run-time read array-dimension get-internal-run-time read
array-dimension-limit get-macro-character read-byte array-dimension-limit get-macro-character read-byte
array-dimensions get-output-stream-string read-char array-dimensions get-output-stream-string read-char
array-displacement get-properties read-char-no-hang array-displacement get-properties read-char-no-hang
array-element-type get-setf-expansion read-delimited-list array-element-type get-setf-expansion read-delimited-list
array-has-fill-pointer-p get-setf-method read-eval-print array-has-fill-pointer-p get-setf-method read-eval-print
array-in-bounds-p get-universal-time read-from-string array-in-bounds-p get-universal-time read-from-string
array-rank getf read-line array-rank getf read-line
array-rank-limit gethash read-preserving-whitespace array-rank-limit gethash read-preserving-whitespace
array-row-major-index go read-sequence array-row-major-index go read-sequence
array-total-size graphic-char-p reader-error array-total-size graphic-char-p reader-error
array-total-size-limit handler-bind readtable array-total-size-limit handler-bind readtable
arrayp handler-case readtable-case arrayp handler-case readtable-case
ash hash-table readtablep ash hash-table readtablep
asin hash-table-count real asin hash-table-count real
asinh hash-table-p realp asinh hash-table-p realp
assert hash-table-rehash-size realpart assert hash-table-rehash-size realpart
assoc hash-table-rehash-threshold reduce assoc hash-table-rehash-threshold reduce
assoc-if hash-table-size reinitialize-instance assoc-if hash-table-size reinitialize-instance
assoc-if-not hash-table-test rem assoc-if-not hash-table-test rem
atan host-namestring remf atan host-namestring remf
atanh identity remhash atanh identity remhash
atom if remove atom if remove
base-char if-exists remove-duplicates base-char if-exists remove-duplicates
base-string ignorable remove-if base-string ignorable remove-if
bignum ignore remove-if-not bignum ignore remove-if-not
bit ignore-errors remove-method bit ignore-errors remove-method
bit-and imagpart remprop bit-and imagpart remprop
bit-andc1 import rename-file bit-andc1 import rename-file
bit-andc2 in-package rename-package bit-andc2 in-package rename-package
bit-eqv in-package replace bit-eqv in-package replace
bit-ior incf require bit-ior incf require
bit-nand initialize-instance rest bit-nand initialize-instance rest
bit-nor inline restart bit-nor inline restart
bit-not input-stream-p restart-bind bit-not input-stream-p restart-bind
bit-orc1 inspect restart-case bit-orc1 inspect restart-case
bit-orc2 int-char restart-name bit-orc2 int-char restart-name
bit-vector integer return bit-vector integer return
bit-vector-p integer-decode-float return-from bit-vector-p integer-decode-float return-from
bit-xor integer-length revappend bit-xor integer-length revappend
block integerp reverse block integerp reverse
boole interactive-stream-p room boole interactive-stream-p room
boole-1 intern rotatef boole-1 intern rotatef
boole-2 internal-time-units-per-second round boole-2 internal-time-units-per-second round
boole-and intersection row-major-aref boole-and intersection row-major-aref
boole-andc1 invalid-method-error rplaca boole-andc1 invalid-method-error rplaca
boole-andc2 invoke-debugger rplacd boole-andc2 invoke-debugger rplacd
boole-c1 invoke-restart safety boole-c1 invoke-restart safety
boole-c2 invoke-restart-interactively satisfies boole-c2 invoke-restart-interactively satisfies
boole-clr isqrt sbit boole-clr isqrt sbit
boole-eqv keyword scale-float boole-eqv keyword scale-float
boole-ior keywordp schar boole-ior keywordp schar
boole-nand labels search boole-nand labels search
boole-nor lambda second boole-nor lambda second
boole-orc1 lambda-list-keywords sequence boole-orc1 lambda-list-keywords sequence
boole-orc2 lambda-parameters-limit serious-condition boole-orc2 lambda-parameters-limit serious-condition
boole-set last set boole-set last set
boole-xor lcm set-char-bit boole-xor lcm set-char-bit
boolean ldb set-difference boolean ldb set-difference
both-case-p ldb-test set-dispatch-macro-character both-case-p ldb-test set-dispatch-macro-character
boundp ldiff set-exclusive-or boundp ldiff set-exclusive-or
break least-negative-double-float set-macro-character break least-negative-double-float set-macro-character
broadcast-stream least-negative-long-float set-pprint-dispatch broadcast-stream least-negative-long-float set-pprint-dispatch
broadcast-stream-streams least-negative-normalized-double-float set-syntax-from-char broadcast-stream-streams least-negative-normalized-double-float set-syntax-from-char
built-in-class least-negative-normalized-long-float setf built-in-class least-negative-normalized-long-float setf
butlast least-negative-normalized-short-float setq butlast least-negative-normalized-short-float setq
byte least-negative-normalized-single-float seventh byte least-negative-normalized-single-float seventh
byte-position least-negative-short-float shadow byte-position least-negative-short-float shadow
byte-size least-negative-single-float shadowing-import byte-size least-negative-single-float shadowing-import
call-arguments-limit least-positive-double-float shared-initialize call-arguments-limit least-positive-double-float shared-initialize
call-method least-positive-long-float shiftf call-method least-positive-long-float shiftf
call-next-method least-positive-normalized-double-float short-float call-next-method least-positive-normalized-double-float short-float
capitalize least-positive-normalized-long-float short-float-epsilon capitalize least-positive-normalized-long-float short-float-epsilon
car least-positive-normalized-short-float short-float-negative-epsilon car least-positive-normalized-short-float short-float-negative-epsilon
case least-positive-normalized-single-float short-site-name case least-positive-normalized-single-float short-site-name
catch least-positive-short-float signal catch least-positive-short-float signal
ccase least-positive-single-float signed-byte ccase least-positive-single-float signed-byte
cdr length signum cdr length signum
ceiling let simle-condition ceiling let simle-condition
cell-error let* simple-array cell-error let* simple-array
cell-error-name lisp simple-base-string cell-error-name lisp simple-base-string
cerror lisp-implementation-type simple-bit-vector cerror lisp-implementation-type simple-bit-vector
change-class lisp-implementation-version simple-bit-vector-p change-class lisp-implementation-version simple-bit-vector-p
char list simple-condition-format-arguments char list simple-condition-format-arguments
char-bit list* simple-condition-format-control char-bit list* simple-condition-format-control
char-bits list-all-packages simple-error char-bits list-all-packages simple-error
char-bits-limit list-length simple-string char-bits-limit list-length simple-string
char-code listen simple-string-p char-code listen simple-string-p
char-code-limit listp simple-type-error char-code-limit listp simple-type-error
char-control-bit load simple-vector char-control-bit load simple-vector
char-downcase load-logical-pathname-translations simple-vector-p char-downcase load-logical-pathname-translations simple-vector-p
char-equal load-time-value simple-warning char-equal load-time-value simple-warning
char-font locally sin char-font locally sin
char-font-limit log single-flaot-epsilon char-font-limit log single-flaot-epsilon
char-greaterp logand single-float char-greaterp logand single-float
char-hyper-bit logandc1 single-float-epsilon char-hyper-bit logandc1 single-float-epsilon
char-int logandc2 single-float-negative-epsilon char-int logandc2 single-float-negative-epsilon
char-lessp logbitp sinh char-lessp logbitp sinh
char-meta-bit logcount sixth char-meta-bit logcount sixth
char-name logeqv sleep char-name logeqv sleep
char-not-equal logical-pathname slot-boundp char-not-equal logical-pathname slot-boundp
char-not-greaterp logical-pathname-translations slot-exists-p char-not-greaterp logical-pathname-translations slot-exists-p
char-not-lessp logior slot-makunbound char-not-lessp logior slot-makunbound
char-super-bit lognand slot-missing char-super-bit lognand slot-missing
char-upcase lognor slot-unbound char-upcase lognor slot-unbound
char/= lognot slot-value char/= lognot slot-value
char< logorc1 software-type char< logorc1 software-type
char<= logorc2 software-version char<= logorc2 software-version
char= logtest some char= logtest some
char> logxor sort char> logxor sort
char>= long-float space char>= long-float space
character long-float-epsilon special character long-float-epsilon special
characterp long-float-negative-epsilon special-form-p characterp long-float-negative-epsilon special-form-p
check-type long-site-name special-operator-p check-type long-site-name special-operator-p
cis loop speed cis loop speed
class loop-finish sqrt class loop-finish sqrt
class-name lower-case-p stable-sort class-name lower-case-p stable-sort
class-of machine-instance standard class-of machine-instance standard
clear-input machine-type standard-char clear-input machine-type standard-char
clear-output machine-version standard-char-p clear-output machine-version standard-char-p
close macro-function standard-class close macro-function standard-class
clrhash macroexpand standard-generic-function clrhash macroexpand standard-generic-function
code-char macroexpand-1 standard-method code-char macroexpand-1 standard-method
coerce macroexpand-l standard-object coerce macroexpand-l standard-object
commonp macrolet step commonp macrolet step
compilation-speed make-array storage-condition compilation-speed make-array storage-condition
compile make-array store-value compile make-array store-value
compile-file make-broadcast-stream stream compile-file make-broadcast-stream stream
compile-file-pathname make-char stream-element-type compile-file-pathname make-char stream-element-type
compiled-function make-concatenated-stream stream-error compiled-function make-concatenated-stream stream-error
compiled-function-p make-condition stream-error-stream compiled-function-p make-condition stream-error-stream
compiler-let make-dispatch-macro-character stream-external-format compiler-let make-dispatch-macro-character stream-external-format
compiler-macro make-echo-stream streamp compiler-macro make-echo-stream streamp
compiler-macro-function make-hash-table streamup compiler-macro-function make-hash-table streamup
complement make-instance string complement make-instance string
complex make-instances-obsolete string-capitalize complex make-instances-obsolete string-capitalize
complexp make-list string-char complexp make-list string-char
compute-applicable-methods make-load-form string-char-p compute-applicable-methods make-load-form string-char-p
compute-restarts make-load-form-saving-slots string-downcase compute-restarts make-load-form-saving-slots string-downcase
concatenate make-method string-equal concatenate make-method string-equal
concatenated-stream make-package string-greaterp concatenated-stream make-package string-greaterp
concatenated-stream-streams make-pathname string-left-trim concatenated-stream-streams make-pathname string-left-trim
cond make-random-state string-lessp cond make-random-state string-lessp
condition make-sequence string-not-equal condition make-sequence string-not-equal
conjugate make-string string-not-greaterp conjugate make-string string-not-greaterp
cons make-string-input-stream string-not-lessp cons make-string-input-stream string-not-lessp
consp make-string-output-stream string-right-strim consp make-string-output-stream string-right-strim
constantly make-symbol string-right-trim constantly make-symbol string-right-trim
constantp make-synonym-stream string-stream constantp make-synonym-stream string-stream
continue make-two-way-stream string-trim continue make-two-way-stream string-trim
control-error makunbound string-upcase control-error makunbound string-upcase
copy-alist map string/= copy-alist map string/=
copy-list map-into string< copy-list map-into string<
copy-pprint-dispatch mapc string<= copy-pprint-dispatch mapc string<=
copy-readtable mapcan string= copy-readtable mapcan string=
copy-seq mapcar string> copy-seq mapcar string>
copy-structure mapcon string>= copy-structure mapcon string>=
copy-symbol maphash stringp copy-symbol maphash stringp
copy-tree mapl structure copy-tree mapl structure
cos maplist structure-class cos maplist structure-class
cosh mask-field structure-object cosh mask-field structure-object
count max style-warning count max style-warning
count-if member sublim count-if member sublim
count-if-not member-if sublis count-if-not member-if sublis
ctypecase member-if-not subseq ctypecase member-if-not subseq
debug merge subsetp debug merge subsetp
decf merge-pathname subst decf merge-pathname subst
declaim merge-pathnames subst-if declaim merge-pathnames subst-if
declaration method subst-if-not declaration method subst-if-not
declare method-combination substitute declare method-combination substitute
decode-float method-combination-error substitute-if decode-float method-combination-error substitute-if
decode-universal-time method-qualifiers substitute-if-not decode-universal-time method-qualifiers substitute-if-not
defclass min subtypep defclass min subtypep
defconstant minusp svref defconstant minusp svref
defgeneric mismatch sxhash defgeneric mismatch sxhash
define-compiler-macro mod symbol define-compiler-macro mod symbol
define-condition most-negative-double-float symbol-function define-condition most-negative-double-float symbol-function
define-method-combination most-negative-fixnum symbol-macrolet define-method-combination most-negative-fixnum symbol-macrolet
define-modify-macro most-negative-long-float symbol-name define-modify-macro most-negative-long-float symbol-name
define-setf-expander most-negative-short-float symbol-package define-setf-expander most-negative-short-float symbol-package
define-setf-method most-negative-single-float symbol-plist define-setf-method most-negative-single-float symbol-plist
define-symbol-macro most-positive-double-float symbol-value define-symbol-macro most-positive-double-float symbol-value
defmacro most-positive-fixnum symbolp defmacro most-positive-fixnum symbolp
defmethod most-positive-long-float synonym-stream defmethod most-positive-long-float synonym-stream
defpackage most-positive-short-float synonym-stream-symbol defpackage most-positive-short-float synonym-stream-symbol
defparameter most-positive-single-float sys defparameter most-positive-single-float sys
defsetf muffle-warning system defsetf muffle-warning system
defstruct multiple-value-bind t defstruct multiple-value-bind t
deftype multiple-value-call tagbody deftype multiple-value-call tagbody
defun multiple-value-list tailp defun multiple-value-list tailp
defvar multiple-value-prog1 tan defvar multiple-value-prog1 tan
delete multiple-value-seteq tanh delete multiple-value-seteq tanh
delete-duplicates multiple-value-setq tenth delete-duplicates multiple-value-setq tenth
delete-file multiple-values-limit terpri delete-file multiple-values-limit terpri
delete-if name-char the delete-if name-char the
delete-if-not namestring third delete-if-not namestring third
delete-package nbutlast throw delete-package nbutlast throw
denominator nconc time denominator nconc time
deposit-field next-method-p trace deposit-field next-method-p trace
describe nil translate-logical-pathname describe nil translate-logical-pathname
describe-object nintersection translate-pathname describe-object nintersection translate-pathname
destructuring-bind ninth tree-equal destructuring-bind ninth tree-equal
digit-char no-applicable-method truename digit-char no-applicable-method truename
digit-char-p no-next-method truncase digit-char-p no-next-method truncase
directory not truncate directory not truncate
directory-namestring notany two-way-stream directory-namestring notany two-way-stream
disassemble notevery two-way-stream-input-stream disassemble notevery two-way-stream-input-stream
division-by-zero notinline two-way-stream-output-stream division-by-zero notinline two-way-stream-output-stream
do nreconc type do nreconc type
do* nreverse type-error do* nreverse type-error
do-all-symbols nset-difference type-error-datum do-all-symbols nset-difference type-error-datum
do-exeternal-symbols nset-exclusive-or type-error-expected-type do-exeternal-symbols nset-exclusive-or type-error-expected-type
do-external-symbols nstring type-of do-external-symbols nstring type-of
do-symbols nstring-capitalize typecase do-symbols nstring-capitalize typecase
documentation nstring-downcase typep documentation nstring-downcase typep
dolist nstring-upcase unbound-slot dolist nstring-upcase unbound-slot
dotimes nsublis unbound-slot-instance dotimes nsublis unbound-slot-instance
double-float nsubst unbound-variable double-float nsubst unbound-variable
double-float-epsilon nsubst-if undefined-function double-float-epsilon nsubst-if undefined-function
double-float-negative-epsilon nsubst-if-not unexport double-float-negative-epsilon nsubst-if-not unexport
dpb nsubstitute unintern dpb nsubstitute unintern
dribble nsubstitute-if union dribble nsubstitute-if union
dynamic-extent nsubstitute-if-not unless dynamic-extent nsubstitute-if-not unless
ecase nth unread ecase nth unread
echo-stream nth-value unread-char echo-stream nth-value unread-char
echo-stream-input-stream nthcdr unsigned-byte echo-stream-input-stream nthcdr unsigned-byte
echo-stream-output-stream null untrace echo-stream-output-stream null untrace
ed number unuse-package ed number unuse-package
eighth numberp unwind-protect eighth numberp unwind-protect
elt numerator update-instance-for-different-class elt numerator update-instance-for-different-class
encode-universal-time nunion update-instance-for-redefined-class encode-universal-time nunion update-instance-for-redefined-class
end-of-file oddp upgraded-array-element-type end-of-file oddp upgraded-array-element-type
endp open upgraded-complex-part-type endp open upgraded-complex-part-type
enough-namestring open-stream-p upper-case-p enough-namestring open-stream-p upper-case-p
ensure-directories-exist optimize use-package ensure-directories-exist optimize use-package
ensure-generic-function or use-value ensure-generic-function or use-value
eq otherwise user eq otherwise user
eql output-stream-p user-homedir-pathname eql output-stream-p user-homedir-pathname
equal package values equal package values
equalp package-error values-list equalp package-error values-list
error package-error-package vector error package-error-package vector
etypecase package-name vector-pop etypecase package-name vector-pop
eval package-nicknames vector-push eval package-nicknames vector-push
eval-when package-shadowing-symbols vector-push-extend eval-when package-shadowing-symbols vector-push-extend
evalhook package-use-list vectorp evalhook package-use-list vectorp
evenp package-used-by-list warn evenp package-used-by-list warn
every packagep warning every packagep warning
exp pairlis when exp pairlis when
export parse-error wild-pathname-p export parse-error wild-pathname-p
expt parse-integer with-accessors expt parse-integer with-accessors
extended-char parse-namestring with-compilation-unit extended-char parse-namestring with-compilation-unit
fboundp pathname with-condition-restarts fboundp pathname with-condition-restarts
fceiling pathname-device with-hash-table-iterator fceiling pathname-device with-hash-table-iterator
fdefinition pathname-directory with-input-from-string fdefinition pathname-directory with-input-from-string
ffloor pathname-host with-open-file ffloor pathname-host with-open-file
fifth pathname-match-p with-open-stream fifth pathname-match-p with-open-stream
file-author pathname-name with-output-to-string file-author pathname-name with-output-to-string
file-error pathname-type with-package-iterator file-error pathname-type with-package-iterator
file-error-pathname pathname-version with-simple-restart file-error-pathname pathname-version with-simple-restart
file-length pathnamep with-slots file-length pathnamep with-slots
file-namestring peek-char with-standard-io-syntax file-namestring peek-char with-standard-io-syntax
file-position phase write file-position phase write
file-stream pi write-byte file-stream pi write-byte
file-string-length plusp write-char file-string-length plusp write-char
file-write-date pop write-line file-write-date pop write-line
fill position write-sequence fill position write-sequence
fill-pointer position-if write-string fill-pointer position-if write-string
find position-if-not write-to-string find position-if-not write-to-string
find-all-symbols pprint y-or-n-p find-all-symbols pprint y-or-n-p
find-class pprint-dispatch yes-or-no-p find-class pprint-dispatch yes-or-no-p
find-if pprint-exit-if-list-exhausted zerop find-if pprint-exit-if-list-exhausted zerop
find-if-not pprint-fill find-if-not pprint-fill
caar cadr cdar cddr caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
*applyhook* *load-pathname* *print-pprint-dispatch* *applyhook* *load-pathname* *print-pprint-dispatch*
*break-on-signals* *load-print* *print-pprint-dispatch* *break-on-signals* *load-print* *print-pprint-dispatch*
*break-on-signals* *load-truename* *print-pretty* *break-on-signals* *load-truename* *print-pretty*
*break-on-warnings* *load-verbose* *print-radix* *break-on-warnings* *load-verbose* *print-radix*
*compile-file-pathname* *macroexpand-hook* *print-readably* *compile-file-pathname* *macroexpand-hook* *print-readably*
*compile-file-pathname* *modules* *print-right-margin* *compile-file-pathname* *modules* *print-right-margin*
*compile-file-truename* *package* *print-right-margin* *compile-file-truename* *package* *print-right-margin*
*compile-file-truename* *print-array* *query-io* *compile-file-truename* *print-array* *query-io*
*compile-print* *print-base* *random-state* *compile-print* *print-base* *random-state*
*compile-verbose* *print-case* *read-base* *compile-verbose* *print-case* *read-base*
*compile-verbose* *print-circle* *read-default-float-format* *compile-verbose* *print-circle* *read-default-float-format*
*debug-io* *print-escape* *read-eval* *debug-io* *print-escape* *read-eval*
*debugger-hook* *print-gensym* *read-suppress* *debugger-hook* *print-gensym* *read-suppress*
*default-pathname-defaults* *print-length* *readtable* *default-pathname-defaults* *print-length* *readtable*
*error-output* *print-level* *standard-input* *error-output* *print-level* *standard-input*
*evalhook* *print-lines* *standard-output* *evalhook* *print-lines* *standard-output*
*features* *print-miser-width* *terminal-io* *features* *print-miser-width* *terminal-io*
*gensym-counter* *print-miser-width* *trace-output*") *gensym-counter* *print-miser-width* *trace-output*")
(defparameter *txtedit-lisp-kw2* (defparameter *txtedit-lisp-kw2*
":abort :from-end :overwrite ":abort :from-end :overwrite
:adjustable :gensym :predicate :adjustable :gensym :predicate
:append :host :preserve-whitespace :append :host :preserve-whitespace
:array :if-does-not-exist :pretty :array :if-does-not-exist :pretty
:base :if-exists :print :base :if-exists :print
:case :include :print-function :case :include :print-function
:circle :index :probe :circle :index :probe
:conc-name :inherited :radix :conc-name :inherited :radix
:constructor :initial-contents :read-only :constructor :initial-contents :read-only
:copier :initial-element :rehash-size :copier :initial-element :rehash-size
:count :initial-offset :rehash-threshold :count :initial-offset :rehash-threshold
:create :initial-value :rename :create :initial-value :rename
:default :input :rename-and-delete :default :input :rename-and-delete
:defaults :internal :size :defaults :internal :size
:device :io :start :device :io :start
:direction :junk-allowed :start1 :direction :junk-allowed :start1
:directory :key :start2 :directory :key :start2
:displaced-index-offset :length :stream :displaced-index-offset :length :stream
:displaced-to :level :supersede :displaced-to :level :supersede
:element-type :name :test :element-type :name :test
:end :named :test-not :end :named :test-not
:end1 :new-version :type :end1 :new-version :type
:end2 :nicknames :use :end2 :nicknames :use
:error :output :verbose :error :output :verbose
:escape :output-file :version :escape :output-file :version
:external :fill-pointer") :external :fill-pointer")
(defparameter *txtedit-decl-forms* (defparameter *txtedit-decl-forms*
'(defmacro defsetf deftype defun defmethod defgeneric lambda '(defmacro defsetf deftype defun defmethod defgeneric lambda

752
contrib/win32/txtedit.lisp
View file

@ -65,35 +65,35 @@ Copyright (c) 2005, Michael Goffioul.")
(defun create-menus () (defun create-menus ()
;(return *NULL*) ;(return *NULL*)
(let ((bar (createmenu)) (let ((bar (createmenu))
(file_pop (createpopupmenu)) (file_pop (createpopupmenu))
(edit_pop (createpopupmenu)) (edit_pop (createpopupmenu))
(win_pop (createpopupmenu)) (win_pop (createpopupmenu))
(help_pop (createpopupmenu))) (help_pop (createpopupmenu)))
;; File menu ;; File menu
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "&File") (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "&File")
(appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New Ctrl+N") (appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New Ctrl+N")
(appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open... Ctrl+O") (appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open... Ctrl+O")
(appendmenu file_pop *MF_STRING* +IDM_CLOSE+ "&Close Ctrl+W") (appendmenu file_pop *MF_STRING* +IDM_CLOSE+ "&Close Ctrl+W")
(appendmenu file_pop *MF_SEPARATOR* 0 "") (appendmenu file_pop *MF_SEPARATOR* 0 "")
(appendmenu file_pop *MF_STRING* +IDM_SAVE+ "&Save Ctrl+S") (appendmenu file_pop *MF_STRING* +IDM_SAVE+ "&Save Ctrl+S")
(appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save &As...") (appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save &As...")
(appendmenu file_pop *MF_SEPARATOR* 0 "") (appendmenu file_pop *MF_SEPARATOR* 0 "")
(appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q") (appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q")
;; Edit menu ;; Edit menu
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "&Edit") (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "&Edit")
(appendmenu edit_pop *MF_STRING* +IDM_UNDO+ "&Undo Ctrl+Z") (appendmenu edit_pop *MF_STRING* +IDM_UNDO+ "&Undo Ctrl+Z")
(appendmenu edit_pop *MF_SEPARATOR* 0 "") (appendmenu edit_pop *MF_SEPARATOR* 0 "")
(appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut Ctrl+X") (appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut Ctrl+X")
(appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C") (appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C")
(appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V") (appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V")
(appendmenu edit_pop *MF_SEPARATOR* 0 "") (appendmenu edit_pop *MF_SEPARATOR* 0 "")
(appendmenu edit_pop *MF_STRING* +IDM_MATCH_PAREN+ "&Match parenthesis Ctrl+D") (appendmenu edit_pop *MF_STRING* +IDM_MATCH_PAREN+ "&Match parenthesis Ctrl+D")
(appendmenu edit_pop *MF_SEPARATOR* 0 "") (appendmenu edit_pop *MF_SEPARATOR* 0 "")
(appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A") (appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A")
;; Windows menu ;; Windows menu
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam win_pop) "&Window") (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam win_pop) "&Window")
(appendmenu win_pop *MF_STRING* +IDM_NEXTWINDOW+ "&Next Ctrl+Right") (appendmenu win_pop *MF_STRING* +IDM_NEXTWINDOW+ "&Next Ctrl+Right")
(appendmenu win_pop *MF_STRING* +IDM_PREVWINDOW+ "&Previous Ctrl+Left") (appendmenu win_pop *MF_STRING* +IDM_PREVWINDOW+ "&Previous Ctrl+Left")
;; Help menu ;; Help menu
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam help_pop) "&Help") (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam help_pop) "&Help")
(appendmenu help_pop *MF_STRING* +IDM_ABOUT+ "&About...") (appendmenu help_pop *MF_STRING* +IDM_ABOUT+ "&About...")
@ -101,13 +101,13 @@ Copyright (c) 2005, Michael Goffioul.")
(defun create-accels () (defun create-accels ()
(macrolet ((add-accel (key ID accTable pos) (macrolet ((add-accel (key ID accTable pos)
`(with-foreign-object (a 'ACCEL) `(with-foreign-object (a 'ACCEL)
(setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*)) (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 (get-slot-value a 'ACCEL 'cmd) ,ID)
(setf (deref-array ,accTable '(* ACCEL) ,pos) a)))) (setf (deref-array ,accTable '(* ACCEL) ,pos) a))))
(let* ((accTableSize (if (= *txtedit-edit-class* 2) 10 9)) (let* ((accTableSize (if (= *txtedit-edit-class* 2) 10 9))
(accTable (allocate-foreign-object 'ACCEL accTableSize))) (accTable (allocate-foreign-object 'ACCEL accTableSize)))
(add-accel #\Q +IDM_QUIT+ accTable 0) (add-accel #\Q +IDM_QUIT+ accTable 0)
(add-accel #\N +IDM_NEW+ accTable 1) (add-accel #\N +IDM_NEW+ accTable 1)
(add-accel #\O +IDM_OPEN+ accTable 2) (add-accel #\O +IDM_OPEN+ accTable 2)
@ -118,10 +118,10 @@ Copyright (c) 2005, Michael Goffioul.")
(add-accel #\W +IDM_CLOSE+ accTable 7) (add-accel #\W +IDM_CLOSE+ accTable 7)
(add-accel #\F +IDM_FIND+ accTable 8) (add-accel #\F +IDM_FIND+ accTable 8)
(when (= *txtedit-edit-class* 2) (when (= *txtedit-edit-class* 2)
(add-accel #\D +IDM_MATCH_PAREN+ accTable 9)) (add-accel #\D +IDM_MATCH_PAREN+ accTable 9))
(prog1 (prog1
(createacceleratortable accTable accTableSize) (createacceleratortable accTable accTableSize)
(free-foreign-object accTable))))) (free-foreign-object accTable)))))
(defun update-caption (hwnd) (defun update-caption (hwnd)
(let ((str (tab-name (current-editor) #'identity nil))) (let ((str (tab-name (current-editor) #'identity nil)))
@ -132,8 +132,8 @@ Copyright (c) 2005, Michael Goffioul.")
(defun tab-name (editor &optional (fun #'file-namestring) (final-char #\Null)) (defun tab-name (editor &optional (fun #'file-namestring) (final-char #\Null))
(format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]" (format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]"
(and (txtedit-title editor) (funcall fun (txtedit-title editor))) (and (txtedit-title editor) (funcall fun (txtedit-title editor)))
(txtedit-dirty editor) final-char)) (txtedit-dirty editor) final-char))
(defun update-tab (idx) (defun update-tab (idx)
(let ((editor (nth idx *txtedit-edit*))) (let ((editor (nth idx *txtedit-edit*)))
@ -146,37 +146,37 @@ Copyright (c) 2005, Michael Goffioul.")
(defun set-current-editor (idx hwnd &optional force-p) (defun set-current-editor (idx hwnd &optional force-p)
(when (<= 0 idx (1- (length *txtedit-edit*))) (when (<= 0 idx (1- (length *txtedit-edit*)))
(let ((old-ed (and *txtedit-current* (let ((old-ed (and *txtedit-current*
(current-editor))) (current-editor)))
(new-ed (nth idx *txtedit-edit*))) (new-ed (nth idx *txtedit-edit*)))
(unless (and (null force-p) (unless (and (null force-p)
(eq old-ed new-ed)) (eq old-ed new-ed))
(setq *txtedit-current* idx) (setq *txtedit-current* idx)
(setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*)) (setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*))
(setfocus (txtedit-handle new-ed)) (setfocus (txtedit-handle new-ed))
(when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx) (when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx)
(sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0)) (sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0))
(update-caption hwnd))))) (update-caption hwnd)))))
(defun close-editor (idx hwnd) (defun close-editor (idx hwnd)
(let ((editor (nth idx *txtedit-edit*))) (let ((editor (nth idx *txtedit-edit*)))
(if (or (null (txtedit-dirty editor)) (if (or (null (txtedit-dirty editor))
(and (set-current-editor idx hwnd) nil) (and (set-current-editor idx hwnd) nil)
(let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C" (let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C"
(txtedit-title editor) #\Null) (txtedit-title editor) #\Null)
"Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*)))) "Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*))))
(cond ((= m-result *IDNO*) t) (cond ((= m-result *IDNO*) t)
((= m-result *IDCANCEL*) nil) ((= m-result *IDCANCEL*) nil)
((= m-result *IDYES*) (warn "Not implemented") nil)))) ((= m-result *IDYES*) (warn "Not implemented") nil))))
(progn (progn
(destroywindow (txtedit-handle editor)) (destroywindow (txtedit-handle editor))
(sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0) (sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0)
(setq *txtedit-edit* (remove editor *txtedit-edit*)) (setq *txtedit-edit* (remove editor *txtedit-edit*))
(when *txtedit-edit* (when *txtedit-edit*
(set-current-editor (min (1- (length *txtedit-edit*)) (set-current-editor (min (1- (length *txtedit-edit*))
(max *txtedit-current* (max *txtedit-current*
0)) 0))
hwnd t)) hwnd t))
t) t)
nil))) nil)))
(ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int)) (ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int))
@ -214,7 +214,7 @@ Copyright (c) 2005, Michael Goffioul.")
(unless (boundp '*txtedit-lisp-kw*) (unless (boundp '*txtedit-lisp-kw*)
(load "lisp-kw.lisp")) (load "lisp-kw.lisp"))
(with-foreign-strings ((kwList *txtedit-lisp-kw*) (with-foreign-strings ((kwList *txtedit-lisp-kw*)
(kwList2 *txtedit-lisp-kw2*)) (kwList2 *txtedit-lisp-kw2*))
(sendmessage hnd 4005 0 (make-lparam kwList)) (sendmessage hnd 4005 0 (make-lparam kwList))
(sendmessage hnd 4005 1 (make-lparam kwList2))) (sendmessage hnd 4005 1 (make-lparam kwList2)))
;; Define margins ;; Define margins
@ -228,21 +228,21 @@ Copyright (c) 2005, Michael Goffioul.")
(defun scintilla-indent-position (pos line hnd) (defun scintilla-indent-position (pos line hnd)
(+ (sendmessage hnd 2127 line 0) (+ (sendmessage hnd 2127 line 0)
(- pos (- pos
(sendmessage hnd 2128 line 0)))) (sendmessage hnd 2128 line 0))))
(defun scintilla-read-form (pos hnd) (defun scintilla-read-form (pos hnd)
(read-from-string (read-from-string
(with-output-to-string (s) (with-output-to-string (s)
(loop for k from pos (loop for k from pos
with style = (sendmessage hnd 2010 pos 0) with style = (sendmessage hnd 2010 pos 0)
for ch = (code-char (sendmessage hnd 2007 k 0)) for ch = (code-char (sendmessage hnd 2007 k 0))
for st = (sendmessage hnd 2010 k 0) for st = (sendmessage hnd 2010 k 0)
if (and (= st style) if (and (= st style)
(graphic-char-p ch) (graphic-char-p ch)
(not (eq ch #\Space))) (not (eq ch #\Space)))
do (write-char ch s) do (write-char ch s)
else else
return nil)) return nil))
nil nil)) nil nil))
(defun scintilla-declare-form-p (form) (defun scintilla-declare-form-p (form)
@ -250,73 +250,73 @@ Copyright (c) 2005, Michael Goffioul.")
(defun scintilla-compute-indentation (curPos curLine hnd) (defun scintilla-compute-indentation (curPos curLine hnd)
(loop for k from curPos downto 0 (loop for k from curPos downto 0
for ch = (code-char (sendmessage hnd 2007 k 0)) for ch = (code-char (sendmessage hnd 2007 k 0))
for st = (sendmessage hnd 2010 k 0) for st = (sendmessage hnd 2010 k 0)
with depth = 0 with depth = 0
with lineIndent = 0 with lineIndent = 0
with lastCharPos = nil with lastCharPos = nil
with prevCharPos = nil with prevCharPos = nil
when (= st 10) when (= st 10)
do (cond ((and (= depth 0) (eq ch #\()) do (cond ((and (= depth 0) (eq ch #\())
(if lastCharPos (if lastCharPos
(let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0))) (let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0)))
lastForm) lastForm)
(cond ((member lastChar (list #\( #\;)) (cond ((member lastChar (list #\( #\;))
(return (scintilla-indent-position lastCharPos curLine hnd))) (return (scintilla-indent-position lastCharPos curLine hnd)))
((and (setq lastForm (scintilla-read-form lastCharPos hnd)) ((and (setq lastForm (scintilla-read-form lastCharPos hnd))
(scintilla-declare-form-p lastForm)) (scintilla-declare-form-p lastForm))
(return (+ (scintilla-indent-position k curLine hnd) 2))) (return (+ (scintilla-indent-position k curLine hnd) 2)))
((and prevCharPos (not (eq prevCharPos lastCharPos))) ((and prevCharPos (not (eq prevCharPos lastCharPos)))
(return (scintilla-indent-position prevCharPos curLine hnd))) (return (scintilla-indent-position prevCharPos curLine hnd)))
(t (t
(return (+ (scintilla-indent-position lastCharPos curLine hnd) 1))))) (return (+ (scintilla-indent-position lastCharPos curLine hnd) 1)))))
(progn (progn
(return (+ (scintilla-indent-position k curLine hnd) 1))))) (return (+ (scintilla-indent-position k curLine hnd) 1)))))
((eq ch #\() (decf depth)) ((eq ch #\() (decf depth))
((eq ch #\)) (incf depth))) ((eq ch #\)) (incf depth)))
if (and (graphic-char-p ch) (not (eq ch #\Space))) if (and (graphic-char-p ch) (not (eq ch #\Space)))
do (setq lastCharPos k) do (setq lastCharPos k)
else else
do (setq prevCharPos lastCharPos) do (setq prevCharPos lastCharPos)
when (eq ch #\Newline) when (eq ch #\Newline)
do (decf curLine) and do (decf curLine) and
do (case lineIndent do (case lineIndent
(0 (incf lineIndent)) (0 (incf lineIndent))
(1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0))))) (1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0)))))
finally (return -1))) finally (return -1)))
(defun scintilla-char-added (hnd ch) (defun scintilla-char-added (hnd ch)
(cond ((eq ch #\Newline) (cond ((eq ch #\Newline)
(let* ((curPos (sendmessage hnd 2008 0 0)) (let* ((curPos (sendmessage hnd 2008 0 0))
(curLine (sendmessage hnd 2166 curPos 0)) (curLine (sendmessage hnd 2166 curPos 0))
(indent (scintilla-compute-indentation (1- curPos) curLine hnd))) (indent (scintilla-compute-indentation (1- curPos) curLine hnd)))
(when (>= indent 0) (when (>= indent 0)
(sendmessage hnd 2126 curLine indent) (sendmessage hnd 2126 curLine indent)
(sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0) (sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0)
))) )))
;((eq ch #\() ;((eq ch #\()
; (let ((curPos (1- (sendmessage hnd 2008 0 0)))) ; (let ((curPos (1- (sendmessage hnd 2008 0 0))))
; (when (scintilla-valid-brace-p curPos hnd) ; (when (scintilla-valid-brace-p curPos hnd)
; (with-foreign-string (s ")") ; (with-foreign-string (s ")")
; (sendmessage hnd 2003 (1+ curPos) (make-lparam s)))))) ; (sendmessage hnd 2003 (1+ curPos) (make-lparam s))))))
(t (t
))) )))
(defun scintilla-get-matching-braces (hnd &aux curPos) (defun scintilla-get-matching-braces (hnd &aux curPos)
(when (>= (setq curPos (1- (sendmessage hnd 2008 0 0))) 0) (when (>= (setq curPos (1- (sendmessage hnd 2008 0 0))) 0)
(let ((ch (code-char (sendmessage hnd 2007 curPos 0)))) (let ((ch (code-char (sendmessage hnd 2007 curPos 0))))
(when (and (or (eq ch #\() (eq ch #\))) (when (and (or (eq ch #\() (eq ch #\)))
(= (sendmessage hnd 2010 curPos 0) 10)) (= (sendmessage hnd 2010 curPos 0) 10))
(let ((matchPos (sendmessage hnd 2353 curPos 0))) (let ((matchPos (sendmessage hnd 2353 curPos 0)))
(return-from scintilla-get-matching-braces (values curPos matchPos)))))) (return-from scintilla-get-matching-braces (values curPos matchPos))))))
(values nil nil)) (values nil nil))
(defun scintilla-check-for-brace (hnd) (defun scintilla-check-for-brace (hnd)
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd) (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
(if curPos (if curPos
(if (>= matchPos 0) (if (>= matchPos 0)
(sendmessage hnd 2351 curPos matchPos) (sendmessage hnd 2351 curPos matchPos)
(sendmessage hnd 2352 curPos 0)) (sendmessage hnd 2352 curPos 0))
(sendmessage hnd 2351 #xFFFFFFFF -1)))) (sendmessage hnd 2351 #xFFFFFFFF -1))))
(defun create-editor (parent &optional (set-current t)) (defun create-editor (parent &optional (set-current t))
@ -324,38 +324,38 @@ Copyright (c) 2005, Michael Goffioul.")
(getclientrect parent r) (getclientrect parent r)
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r)) (sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
(let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (txtedit-class-name) "" (let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (txtedit-class-name) ""
(logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS* (logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS*
*ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*) *ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*)
(get-slot-value r 'RECT 'left) (get-slot-value r 'RECT 'left)
(get-slot-value r 'RECT 'top) (get-slot-value r 'RECT 'top)
(- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left)) (- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top)) (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
*txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*)))) *txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*))))
(sendmessage (txtedit-handle new-editor) *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0) (sendmessage (txtedit-handle new-editor) *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0)
(case *txtedit-edit-class* (case *txtedit-edit-class*
(1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*)) (1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*))
(2 (init-scintilla-component (txtedit-handle new-editor)))) (2 (init-scintilla-component (txtedit-handle new-editor))))
(with-foreign-object (tab 'TCITEM) (with-foreign-object (tab 'TCITEM)
(setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*) (setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*)
(setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor)) (setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor))
(sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab))) (sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab)))
(setq *txtedit-edit* (append *txtedit-edit* (list new-editor))) (setq *txtedit-edit* (append *txtedit-edit* (list new-editor)))
(when set-current (when set-current
(set-current-editor (1- (length *txtedit-edit*)) parent)) (set-current-editor (1- (length *txtedit-edit*)) parent))
new-editor))) new-editor)))
(defun unix2dos (str) (defun unix2dos (str)
(let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0)) (let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0))
(return-p nil) (return-p nil)
c) c)
(with-output-to-string (out new-str) (with-output-to-string (out new-str)
(do ((it (si::make-seq-iterator str) (si::seq-iterator-next str it))) (do ((it (si::make-seq-iterator str) (si::seq-iterator-next str it)))
((null it)) ((null it))
(case (setq c (si::seq-iterator-ref str it)) (case (setq c (si::seq-iterator-ref str it))
(#\Return (setq return-p t)) (#\Return (setq return-p t))
(#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil)) (#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil))
(t (setq return-p nil))) (t (setq return-p nil)))
(write-char c out))) (write-char c out)))
new-str)) new-str))
(defun read-file (pn hwnd) (defun read-file (pn hwnd)
@ -363,13 +363,13 @@ Copyright (c) 2005, Michael Goffioul.")
(if pn (if pn
(with-open-file (f pn) (with-open-file (f pn)
(let* ((len (file-length f)) (let* ((len (file-length f))
(buf (make-string len))) (buf (make-string len)))
(read-sequence buf f) (read-sequence buf f)
(setwindowtext (txtedit-handle (current-editor)) (unix2dos buf)) (setwindowtext (txtedit-handle (current-editor)) (unix2dos buf))
(setf (txtedit-dirty (current-editor)) nil) (setf (txtedit-dirty (current-editor)) nil)
(setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn))) (setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn)))
(update-caption hwnd) (update-caption hwnd)
(update-tab *txtedit-current*))) (update-tab *txtedit-current*)))
(messagebox hwnd "File does not exist." "Error" (logior *MB_OK* *MB_ICONERROR*)))) (messagebox hwnd "File does not exist." "Error" (logior *MB_OK* *MB_ICONERROR*))))
(defun save-file (pn hwnd) (defun save-file (pn hwnd)
@ -390,224 +390,224 @@ Copyright (c) 2005, Michael Goffioul.")
(defun tab-proc (hwnd umsg wparam lparam) (defun tab-proc (hwnd umsg wparam lparam)
(cond ((or (= umsg *WM_COMMAND*) (cond ((or (= umsg *WM_COMMAND*)
(= umsg *WM_NOTIFY*)) (= umsg *WM_NOTIFY*))
(txtedit-proc (getparent hwnd) umsg wparam lparam)) (txtedit-proc (getparent hwnd) umsg wparam lparam))
(t (t
(callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam)))) (callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam))))
(defvar *txtedit-level* 0) (defvar *txtedit-level* 0)
(defun txtedit-proc (hwnd umsg wparam lparam &aux (*txtedit-level* (1+ *txtedit-level*))) (defun txtedit-proc (hwnd umsg wparam lparam &aux (*txtedit-level* (1+ *txtedit-level*)))
;(format t "txtedit-proc: ~D~%" *txtedit-level*) ;(format t "txtedit-proc: ~D~%" *txtedit-level*)
(cond ((= umsg *WM_DESTROY*) (cond ((= umsg *WM_DESTROY*)
(postquitmessage 0) (postquitmessage 0)
0) 0)
((= umsg *WM_CLOSE*) ((= umsg *WM_CLOSE*)
(if (do ((flag t)) (if (do ((flag t))
((not (and *txtedit-edit* flag)) flag) ((not (and *txtedit-edit* flag)) flag)
(setq flag (close-editor 0 hwnd))) (setq flag (close-editor 0 hwnd)))
(destroywindow hwnd) (destroywindow hwnd)
0)) 0))
((= umsg *WM_CREATE*) ((= umsg *WM_CREATE*)
(when (null-pointer-p (getmodulehandle "comctl32")) (when (null-pointer-p (getmodulehandle "comctl32"))
(initcommoncontrols)) (initcommoncontrols))
(setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* "" (setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* ""
(logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0 (logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0
hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*)) hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*))
(setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc)) (setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc))
(sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) (sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
(create-editor hwnd) (create-editor hwnd)
(with-cast-int-pointer (lparam CREATESTRUCT) (with-cast-int-pointer (lparam CREATESTRUCT)
(let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams))) (let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams)))
(unless (null-pointer-p params) (unless (null-pointer-p params)
(read-file (convert-from-foreign-string params) hwnd)))) (read-file (convert-from-foreign-string params) hwnd))))
0) 0)
((= umsg *WM_SIZE*) ((= umsg *WM_SIZE*)
(unless (null-pointer-p *txtedit-tab*) (unless (null-pointer-p *txtedit-tab*)
(movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*) (movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*)
(with-foreign-object (r 'RECT) (with-foreign-object (r 'RECT)
(setrect r 0 0 (loword lparam) (hiword lparam)) (setrect r 0 0 (loword lparam) (hiword lparam))
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r)) (sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
(dotimes (k (length *txtedit-edit*)) (dotimes (k (length *txtedit-edit*))
(movewindow (txtedit-handle (nth k *txtedit-edit*)) (movewindow (txtedit-handle (nth k *txtedit-edit*))
(get-slot-value r 'RECT 'left) (get-slot-value r 'RECT 'top) (get-slot-value r 'RECT 'left) (get-slot-value r 'RECT 'top)
(- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left)) (- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top)) (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
(if (= k *txtedit-current*) *TRUE* *FALSE*))))) (if (= k *txtedit-current*) *TRUE* *FALSE*)))))
0) 0)
((= umsg *WM_SETFOCUS*) ((= umsg *WM_SETFOCUS*)
(unless (null-pointer-p (txtedit-handle (current-editor))) (unless (null-pointer-p (txtedit-handle (current-editor)))
(setfocus (txtedit-handle (current-editor)))) (setfocus (txtedit-handle (current-editor))))
0) 0)
((= umsg *WM_NOTIFY*) ((= umsg *WM_NOTIFY*)
(with-cast-int-pointer (lparam NMHDR) (with-cast-int-pointer (lparam NMHDR)
(let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom)) (let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom))
(code (get-slot-value lparam 'NMHDR 'code)) (code (get-slot-value lparam 'NMHDR 'code))
(hnd (get-slot-value lparam 'NMHDR 'hwndFrom))) (hnd (get-slot-value lparam 'NMHDR 'hwndFrom)))
(cond ((= ctrl-ID +TABCTL_ID+) (cond ((= ctrl-ID +TABCTL_ID+)
(cond ((= code *TCN_SELCHANGE*) (cond ((= code *TCN_SELCHANGE*)
(set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd)) (set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd))
(t (t
))) )))
((and (= *txtedit-edit-class* 2) ((and (= *txtedit-edit-class* 2)
(= code 2001)) (= code 2001))
(with-cast-pointer (lparam SCNotification) (with-cast-pointer (lparam SCNotification)
(scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch))))) (scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch)))))
((and (= *txtedit-edit-class* 2) ((and (= *txtedit-edit-class* 2)
(= code 2007)) (= code 2007))
(scintilla-check-for-brace hnd)) (scintilla-check-for-brace hnd))
(t (t
)))) ))))
0) 0)
((= umsg *WM_CONTEXTMENU*) ((= umsg *WM_CONTEXTMENU*)
(let ((hnd (make-handle wparam)) (let ((hnd (make-handle wparam))
(x (get-x-lparam lparam)) (x (get-x-lparam lparam))
(y (get-y-lparam lparam))) (y (get-y-lparam lparam)))
(cond ((equal hnd *txtedit-tab*) (cond ((equal hnd *txtedit-tab*)
(with-foreign-objects ((ht 'TCHITTESTINFO) (with-foreign-objects ((ht 'TCHITTESTINFO)
(pt 'POINT)) (pt 'POINT))
(setf (get-slot-value pt 'POINT 'x) x) (setf (get-slot-value pt 'POINT 'x) x)
(setf (get-slot-value pt 'POINT 'y) y) (setf (get-slot-value pt 'POINT 'y) y)
(screentoclient *txtedit-tab* pt) (screentoclient *txtedit-tab* pt)
(setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt) (setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt)
(let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht)))) (let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht))))
(when (>= tab 0) (when (>= tab 0)
(let ((hMenu (createpopupmenu)) (let ((hMenu (createpopupmenu))
menu-ID) menu-ID)
(appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close") (appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close")
(when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0) (when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0)
(close-or-exit tab hwnd)) (close-or-exit tab hwnd))
(destroymenu hMenu)))))))) (destroymenu hMenu))))))))
0) 0)
((= umsg *WM_INITMENUPOPUP*) ((= umsg *WM_INITMENUPOPUP*)
(case (loword lparam) (case (loword lparam)
(2 (let* ((wMenu (make-handle wparam)) (2 (let* ((wMenu (make-handle wparam))
(nPos (loword lparam)) (nPos (loword lparam))
(nItems (getmenuitemcount wMenu))) (nItems (getmenuitemcount wMenu)))
(dotimes (j (- nItems 2)) (dotimes (j (- nItems 2))
(deletemenu wMenu 2 *MF_BYPOSITION*)) (deletemenu wMenu 2 *MF_BYPOSITION*))
(when *txtedit-edit* (when *txtedit-edit*
(appendmenu wMenu *MF_SEPARATOR* 0 "") (appendmenu wMenu *MF_SEPARATOR* 0 "")
(loop for e in *txtedit-edit* (loop for e in *txtedit-edit*
for k from 0 for k from 0
do (progn do (progn
(appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e)) (appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e))
(when (= k *txtedit-current*) (when (= k *txtedit-current*)
(checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*)))))) (checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*))))))
(enablemenuitem wMenu +IDM_PREVWINDOW+ (if (= *txtedit-current* 0) *MF_GRAYED* *MF_ENABLED*)) (enablemenuitem wMenu +IDM_PREVWINDOW+ (if (= *txtedit-current* 0) *MF_GRAYED* *MF_ENABLED*))
(enablemenuitem wMenu +IDM_NEXTWINDOW+ (if (< *txtedit-current* (1- (length *txtedit-edit*))) *MF_ENABLED* *MF_GRAYED*)) (enablemenuitem wMenu +IDM_NEXTWINDOW+ (if (< *txtedit-current* (1- (length *txtedit-edit*))) *MF_ENABLED* *MF_GRAYED*))
)) ))
) )
0) 0)
((= umsg *WM_COMMAND*) ((= umsg *WM_COMMAND*)
(let ((ctrl-ID (loword wparam)) (let ((ctrl-ID (loword wparam))
(nmsg (hiword wparam)) (nmsg (hiword wparam))
(hnd (make-pointer lparam 'HANDLE))) (hnd (make-pointer lparam 'HANDLE)))
(cond ((= ctrl-ID +EDITCTL_ID+) (cond ((= ctrl-ID +EDITCTL_ID+)
(cond ((= nmsg *EN_CHANGE*) (cond ((= nmsg *EN_CHANGE*)
(unless (txtedit-dirty (current-editor)) (unless (txtedit-dirty (current-editor))
(setf (txtedit-dirty (current-editor)) t) (setf (txtedit-dirty (current-editor)) t)
(update-caption hwnd) (update-caption hwnd)
(update-tab *txtedit-current*))) (update-tab *txtedit-current*)))
(t (t
))) )))
((= ctrl-ID +IDM_QUIT+) ((= ctrl-ID +IDM_QUIT+)
(sendmessage hwnd *WM_CLOSE* 0 0)) (sendmessage hwnd *WM_CLOSE* 0 0))
((= ctrl-ID +IDM_OPEN+) ((= ctrl-ID +IDM_OPEN+)
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp") (let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
("All Files (*)" . "*"))))) ("All Files (*)" . "*")))))
(when pn (when pn
(create-editor hwnd) (create-editor hwnd)
(read-file pn hwnd)))) (read-file pn hwnd))))
((and (= ctrl-ID +IDM_SAVE+) ((and (= ctrl-ID +IDM_SAVE+)
(txtedit-title (current-editor))) (txtedit-title (current-editor)))
(save-file nil hwnd)) (save-file nil hwnd))
((or (= ctrl-ID +IDM_SAVEAS+) ((or (= ctrl-ID +IDM_SAVEAS+)
(and (= ctrl-ID +IDM_SAVE+) (and (= ctrl-ID +IDM_SAVE+)
(null (txtedit-title (current-editor))))) (null (txtedit-title (current-editor)))))
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp") (let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
("All Files (*)" . "*")) ("All Files (*)" . "*"))
:dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*))) :dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*)))
(when pn (when pn
(save-file pn hwnd)))) (save-file pn hwnd))))
((= ctrl-ID +IDM_NEW+) ((= ctrl-ID +IDM_NEW+)
(create-editor hwnd)) (create-editor hwnd))
((= ctrl-ID +IDM_CUT+) ((= ctrl-ID +IDM_CUT+)
(sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0)) (sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0))
((= ctrl-ID +IDM_COPY+) ((= ctrl-ID +IDM_COPY+)
(sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0)) (sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0))
((= ctrl-ID +IDM_PASTE+) ((= ctrl-ID +IDM_PASTE+)
(sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0)) (sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0))
((= ctrl-ID +IDM_UNDO+) ((= ctrl-ID +IDM_UNDO+)
(unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0) (unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0)
(sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0))) (sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0)))
((= ctrl-ID +IDM_SELECTALL+) ((= ctrl-ID +IDM_SELECTALL+)
(sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1)) (sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1))
((= ctrl-ID +IDM_ABOUT+) ((= ctrl-ID +IDM_ABOUT+)
(messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*))) (messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*)))
((= ctrl-ID +IDM_NEXTWINDOW+) ((= ctrl-ID +IDM_NEXTWINDOW+)
(unless (>= (1+ *txtedit-current*) (length *txtedit-edit*)) (unless (>= (1+ *txtedit-current*) (length *txtedit-edit*))
(set-current-editor (1+ *txtedit-current*) hwnd))) (set-current-editor (1+ *txtedit-current*) hwnd)))
((= ctrl-ID +IDM_PREVWINDOW+) ((= ctrl-ID +IDM_PREVWINDOW+)
(unless (= *txtedit-current* 0) (unless (= *txtedit-current* 0)
(set-current-editor (1- *txtedit-current*) hwnd))) (set-current-editor (1- *txtedit-current*) hwnd)))
((= ctrl-ID +IDM_CLOSE+) ((= ctrl-ID +IDM_CLOSE+)
(close-or-exit *txtedit-current* hwnd)) (close-or-exit *txtedit-current* hwnd))
((= ctrl-ID +IDM_MATCH_PAREN+) ((= ctrl-ID +IDM_MATCH_PAREN+)
(let ((hnd (txtedit-handle (current-editor)))) (let ((hnd (txtedit-handle (current-editor))))
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd) (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
(when (and curPos (>= matchPos 0)) (when (and curPos (>= matchPos 0))
(sendmessage hnd 2025 (1+ matchPos) 0))))) (sendmessage hnd 2025 (1+ matchPos) 0)))))
((= ctrl-ID +IDM_FIND+) ((= ctrl-ID +IDM_FIND+)
(let* ((fr (allocate-foreign-object 'FINDREPLACE)) (let* ((fr (allocate-foreign-object 'FINDREPLACE))
(str (make-string 1024 :initial-element #\Null))) (str (make-string 1024 :initial-element #\Null)))
(zeromemory fr (size-of-foreign-type 'FINDREPLACE)) (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 'lStructSize) (size-of-foreign-type 'FINDREPLACE))
(setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd) (setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd)
(setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str) (setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str)
(setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024) (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024)
(setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*) (setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*)
(setq *txtedit-dlg-handle* (findtext fr)))) (setq *txtedit-dlg-handle* (findtext fr))))
((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+) ((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+)
(set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd) (set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd)
0) 0)
(t (t
))) )))
0) 0)
((= uMsg (1+ *WM_USER*)) ((= uMsg (1+ *WM_USER*))
(print "Open file request received") (print "Open file request received")
(let ((fname (pop *txtedit-files*))) (let ((fname (pop *txtedit-files*)))
(when fname (when fname
(create-editor hwnd) (create-editor hwnd)
(read-file fname hwnd))) (read-file fname hwnd)))
0) 0)
((= uMsg *txtedit-findreplace-msg*) ((= uMsg *txtedit-findreplace-msg*)
(with-cast-int-pointer (lparam FINDREPLACE) (with-cast-int-pointer (lparam FINDREPLACE)
(let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags)) (let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags))
(hnd (txtedit-handle (current-editor)))) (hnd (txtedit-handle (current-editor))))
(cond ((/= 0 (logand flags *FR_DIALOGTERM*)) (cond ((/= 0 (logand flags *FR_DIALOGTERM*))
(free-foreign-object lparam) (free-foreign-object lparam)
(setq *txtedit-dlg-handle* *NULL*)) (setq *txtedit-dlg-handle* *NULL*))
((/= 0 (logand flags *FR_FINDNEXT*)) ((/= 0 (logand flags *FR_FINDNEXT*))
(let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat)) (let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat))
pos pos
(down (/= (logand flags *FR_DOWN*) 0))) (down (/= (logand flags *FR_DOWN*) 0)))
(cond ((= *txtedit-edit-class* 2) (cond ((= *txtedit-edit-class* 2)
(let ((selStart (sendmessage hnd 2143 0 0)) (let ((selStart (sendmessage hnd 2143 0 0))
(selEnd (sendmessage hnd 2145 0 0))) (selEnd (sendmessage hnd 2145 0 0)))
(sendmessage hnd 2025 (if down selEnd selStart) 0) (sendmessage hnd 2025 (if down selEnd selStart) 0)
(sendmessage hnd 2366 0 0) (sendmessage hnd 2366 0 0)
(with-foreign-string (s str) (with-foreign-string (s str)
(if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1) (if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1)
(sendmessage hnd 2169 0 0) (sendmessage hnd 2169 0 0)
(progn (progn
(messagebox *txtedit-dlg-handle* "Finished searching the document" (messagebox *txtedit-dlg-handle* "Finished searching the document"
"Find" (logior *MB_OK* *MB_ICONINFORMATION*)) "Find" (logior *MB_OK* *MB_ICONINFORMATION*))
(sendmessage hnd 2160 selStart selEnd)))))) (sendmessage hnd 2160 selStart selEnd))))))
))) )))
))) )))
0) 0)
(t (t
(defwindowproc hwnd umsg wparam lparam)) (defwindowproc hwnd umsg wparam lparam))
)) ))
(defun txtedit-class-name () (defun txtedit-class-name ()
@ -620,16 +620,16 @@ Copyright (c) 2005, Michael Goffioul.")
(unless *txtedit-class-registered* (unless *txtedit-class-registered*
(case *txtedit-edit-class* (case *txtedit-edit-class*
(-1 (or (and (not (null-pointer-p (loadlibrary "SciLexer.dll"))) (-1 (or (and (not (null-pointer-p (loadlibrary "SciLexer.dll")))
(setq *txtedit-edit-class* 2)) (setq *txtedit-edit-class* 2))
(and (not (null-pointer-p (loadlibrary "riched20.dll"))) (and (not (null-pointer-p (loadlibrary "riched20.dll")))
(setq *txtedit-edit-class* 1)) (setq *txtedit-edit-class* 1))
(setq *txtedit-edit-class* 0))) (setq *txtedit-edit-class* 0)))
(1 (and (null-pointer-p (loadlibrary "riched20.dll")) (1 (and (null-pointer-p (loadlibrary "riched20.dll"))
(error "Cannot load WIN32 library: riched20.dll"))) (error "Cannot load WIN32 library: riched20.dll")))
(2 (and (null-pointer-p (loadlibrary "SciLexer.dll")) (2 (and (null-pointer-p (loadlibrary "SciLexer.dll"))
(error "Cannot load WIN32 library: SciLexer.dll")))) (error "Cannot load WIN32 library: SciLexer.dll"))))
(make-wndclass "SimpleTextEditor" (make-wndclass "SimpleTextEditor"
:lpfnWndProc #'txtedit-proc) :lpfnWndProc #'txtedit-proc)
(setq *txtedit-class-registered* t))) (setq *txtedit-class-registered* t)))
(defun unregister-txtedit-class () (defun unregister-txtedit-class ()
@ -643,15 +643,15 @@ Copyright (c) 2005, Michael Goffioul.")
(defun txtedit (&optional fname &key (class -1) &aux (*txtedit-edit-class* class)) (defun txtedit (&optional fname &key (class -1) &aux (*txtedit-edit-class* class))
(register-txtedit-class) (register-txtedit-class)
(let* ((fname-str (if fname (let* ((fname-str (if fname
(convert-to-foreign-string (coerce fname 'simple-string)) (convert-to-foreign-string (coerce fname 'simple-string))
*NULL*)) *NULL*))
(w (createwindow "SimpleTextEditor" (w (createwindow "SimpleTextEditor"
*txtedit-default-title* *txtedit-default-title*
(logior *WS_OVERLAPPEDWINDOW*) (logior *WS_OVERLAPPEDWINDOW*)
*CW_USEDEFAULT* *CW_USEDEFAULT* *CW_USEDEFAULT* *CW_USEDEFAULT*
*txtedit-width* *txtedit-height* *txtedit-width* *txtedit-height*
*NULL* (create-menus) *NULL* fname-str)) *NULL* (create-menus) *NULL* fname-str))
(accTable (create-accels))) (accTable (create-accels)))
(setq *txtedit-handle* w) (setq *txtedit-handle* w)
(showwindow w *SW_SHOWNORMAL*) (showwindow w *SW_SHOWNORMAL*)
(updatewindow w) (updatewindow w)
@ -669,9 +669,9 @@ Copyright (c) 2005, Michael Goffioul.")
(if (or detach-p *txtedit-process*) (if (or detach-p *txtedit-process*)
(if (member :threads *features*) (if (member :threads *features*)
(if *txtedit-process* (if *txtedit-process*
(progn (progn
(push fname *txtedit-files*) (push fname *txtedit-files*)
(postmessage *txtedit-handle* (1+ *WM_USER*) 0 0)) (postmessage *txtedit-handle* (1+ *WM_USER*) 0 0))
#+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class))))) #+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class)))))
(error "No multi-threading environment detected.")) (error "No multi-threading environment detected."))
(txtedit fname :class class))) (txtedit fname :class class)))

660
contrib/win32/win32.lisp
View file

@ -37,291 +37,291 @@
(define-win-constant *TRUE* 1) (define-win-constant *TRUE* 1)
(define-win-constant *FALSE* 0) (define-win-constant *FALSE* 0)
(define-win-constant *WM_CLOSE* #x0010) (define-win-constant *WM_CLOSE* #x0010)
(define-win-constant *WM_COMMAND* #x0111) (define-win-constant *WM_COMMAND* #x0111)
(define-win-constant *WM_CONTEXTMENU* #x007b) (define-win-constant *WM_CONTEXTMENU* #x007b)
(define-win-constant *WM_COPY* #x0301) (define-win-constant *WM_COPY* #x0301)
(define-win-constant *WM_CREATE* #x0001) (define-win-constant *WM_CREATE* #x0001)
(define-win-constant *WM_CUT* #x0300) (define-win-constant *WM_CUT* #x0300)
(define-win-constant *WM_DESTROY* #x0002) (define-win-constant *WM_DESTROY* #x0002)
(define-win-constant *WM_GETFONT* #x0031) (define-win-constant *WM_GETFONT* #x0031)
(define-win-constant *WM_GETMINMAXINFO* #x0024) (define-win-constant *WM_GETMINMAXINFO* #x0024)
(define-win-constant *WM_INITMENU* #x0116) (define-win-constant *WM_INITMENU* #x0116)
(define-win-constant *WM_INITMENUPOPUP* #x0117) (define-win-constant *WM_INITMENUPOPUP* #x0117)
(define-win-constant *WM_NCPAINT* #x0085) (define-win-constant *WM_NCPAINT* #x0085)
(define-win-constant *WM_NOTIFY* #x004e) (define-win-constant *WM_NOTIFY* #x004e)
(define-win-constant *WM_PAINT* #x000f) (define-win-constant *WM_PAINT* #x000f)
(define-win-constant *WM_PASTE* #x0302) (define-win-constant *WM_PASTE* #x0302)
(define-win-constant *WM_QUIT* #x0012) (define-win-constant *WM_QUIT* #x0012)
(define-win-constant *WM_SETFOCUS* #x0007) (define-win-constant *WM_SETFOCUS* #x0007)
(define-win-constant *WM_SETFONT* #x0030) (define-win-constant *WM_SETFONT* #x0030)
(define-win-constant *WM_SIZE* #x0005) (define-win-constant *WM_SIZE* #x0005)
(define-win-constant *WM_UNDO* #x0304) (define-win-constant *WM_UNDO* #x0304)
(define-win-constant *WM_USER* #x0400) (define-win-constant *WM_USER* #x0400)
(define-win-constant *WS_BORDER* #x00800000) (define-win-constant *WS_BORDER* #x00800000)
(define-win-constant *WS_CHILD* #x40000000) (define-win-constant *WS_CHILD* #x40000000)
(define-win-constant *WS_CLIPCHILDREN* #x02000000) (define-win-constant *WS_CLIPCHILDREN* #x02000000)
(define-win-constant *WS_CLIPSIBLINGS* #x04000000) (define-win-constant *WS_CLIPSIBLINGS* #x04000000)
(define-win-constant *WS_DLGFRAME* #x00400000) (define-win-constant *WS_DLGFRAME* #x00400000)
(define-win-constant *WS_DISABLED* #x08000000) (define-win-constant *WS_DISABLED* #x08000000)
(define-win-constant *WS_HSCROLL* #x00100000) (define-win-constant *WS_HSCROLL* #x00100000)
(define-win-constant *WS_OVERLAPPEDWINDOW* #x00CF0000) (define-win-constant *WS_OVERLAPPEDWINDOW* #x00CF0000)
(define-win-constant *WS_VISIBLE* #x10000000) (define-win-constant *WS_VISIBLE* #x10000000)
(define-win-constant *WS_VSCROLL* #x00200000) (define-win-constant *WS_VSCROLL* #x00200000)
(define-win-constant *WS_EX_CLIENTEDGE* #x00000200) (define-win-constant *WS_EX_CLIENTEDGE* #x00000200)
(define-win-constant *RICHEDIT_CLASS* "RichEdit20A") (define-win-constant *RICHEDIT_CLASS* "RichEdit20A")
(define-win-constant *WC_LISTVIEW* "SysListView32") (define-win-constant *WC_LISTVIEW* "SysListView32")
(define-win-constant *WC_TABCONTROL* "SysTabControl32") (define-win-constant *WC_TABCONTROL* "SysTabControl32")
(define-win-constant *HWND_BOTTOM* (make-pointer 1 'HANDLE)) (define-win-constant *HWND_BOTTOM* (make-pointer 1 'HANDLE))
(define-win-constant *HWND_NOTOPMOST* (make-pointer -2 'HANDLE)) (define-win-constant *HWND_NOTOPMOST* (make-pointer -2 'HANDLE))
(define-win-constant *HWND_TOP* (make-pointer 0 'HANDLE)) (define-win-constant *HWND_TOP* (make-pointer 0 'HANDLE))
(define-win-constant *HWND_TOPMOST* (make-pointer -1 'HANDLE)) (define-win-constant *HWND_TOPMOST* (make-pointer -1 'HANDLE))
(define-win-constant *SWP_DRAWFRAME* #x0020) (define-win-constant *SWP_DRAWFRAME* #x0020)
(define-win-constant *SWP_HIDEWINDOW* #x0080) (define-win-constant *SWP_HIDEWINDOW* #x0080)
(define-win-constant *SWP_NOMOVE* #x0002) (define-win-constant *SWP_NOMOVE* #x0002)
(define-win-constant *SWP_NOOWNERZORDER* #x0200) (define-win-constant *SWP_NOOWNERZORDER* #x0200)
(define-win-constant *SWP_NOREDRAW* #x0008) (define-win-constant *SWP_NOREDRAW* #x0008)
(define-win-constant *SWP_NOREPOSITION* #x0200) (define-win-constant *SWP_NOREPOSITION* #x0200)
(define-win-constant *SWP_NOSIZE* #x0001) (define-win-constant *SWP_NOSIZE* #x0001)
(define-win-constant *SWP_NOZORDER* #x0004) (define-win-constant *SWP_NOZORDER* #x0004)
(define-win-constant *SWP_SHOWWINDOW* #x0040) (define-win-constant *SWP_SHOWWINDOW* #x0040)
(define-win-constant *BS_DEFPUSHBUTTON* #x00000000) (define-win-constant *BS_DEFPUSHBUTTON* #x00000000)
(define-win-constant *BS_PUSHBUTTON* #x00000001) (define-win-constant *BS_PUSHBUTTON* #x00000001)
(define-win-constant *BN_CLICKED* 0) (define-win-constant *BN_CLICKED* 0)
(define-win-constant *ES_AUTOHSCROLL* #x0080) (define-win-constant *ES_AUTOHSCROLL* #x0080)
(define-win-constant *ES_AUTOVSCROLL* #x0040) (define-win-constant *ES_AUTOVSCROLL* #x0040)
(define-win-constant *ES_LEFT* #x0000) (define-win-constant *ES_LEFT* #x0000)
(define-win-constant *ES_MULTILINE* #x0004) (define-win-constant *ES_MULTILINE* #x0004)
(define-win-constant *EM_CANUNDO* #x00c6) (define-win-constant *EM_CANUNDO* #x00c6)
(define-win-constant *EM_SETEVENTMASK* (+ *WM_USER* 69)) (define-win-constant *EM_SETEVENTMASK* (+ *WM_USER* 69))
(define-win-constant *EM_SETSEL* #x00b1) (define-win-constant *EM_SETSEL* #x00b1)
(define-win-constant *EM_UNDO* #x00c7) (define-win-constant *EM_UNDO* #x00c7)
(define-win-constant *EN_CHANGE* #x0300) (define-win-constant *EN_CHANGE* #x0300)
(define-win-constant *ENM_CHANGE* #x00000001) (define-win-constant *ENM_CHANGE* #x00000001)
(define-win-constant *TCIF_IMAGE* #x0002) (define-win-constant *TCIF_IMAGE* #x0002)
(define-win-constant *TCIF_PARAM* #x0008) (define-win-constant *TCIF_PARAM* #x0008)
(define-win-constant *TCIF_RTLREADING* #x0004) (define-win-constant *TCIF_RTLREADING* #x0004)
(define-win-constant *TCIF_STATE* #x0010) (define-win-constant *TCIF_STATE* #x0010)
(define-win-constant *TCIF_TEXT* #x0001) (define-win-constant *TCIF_TEXT* #x0001)
(define-win-constant *TCHT_NOWHERE* #x0001) (define-win-constant *TCHT_NOWHERE* #x0001)
(define-win-constant *TCHT_ONITEM* #x0006) (define-win-constant *TCHT_ONITEM* #x0006)
(define-win-constant *TCHT_ONITEMICON* #x0002) (define-win-constant *TCHT_ONITEMICON* #x0002)
(define-win-constant *TCHT_ONITEMLABEL* #x0004) (define-win-constant *TCHT_ONITEMLABEL* #x0004)
(define-win-constant *TCM_FIRST* #x1300) (define-win-constant *TCM_FIRST* #x1300)
(define-win-constant *TCN_FIRST* #xfffffdda) (define-win-constant *TCN_FIRST* #xfffffdda)
(define-win-constant *TCM_ADJUSTRECT* (+ *TCM_FIRST* 40)) (define-win-constant *TCM_ADJUSTRECT* (+ *TCM_FIRST* 40))
(define-win-constant *TCM_DELETEITEM* (+ *TCM_FIRST* 8)) (define-win-constant *TCM_DELETEITEM* (+ *TCM_FIRST* 8))
(define-win-constant *TCM_GETCURSEL* (+ *TCM_FIRST* 11)) (define-win-constant *TCM_GETCURSEL* (+ *TCM_FIRST* 11))
(define-win-constant *TCM_HITTEST* (+ *TCM_FIRST* 13)) (define-win-constant *TCM_HITTEST* (+ *TCM_FIRST* 13))
(define-win-constant *TCM_INSERTITEM* (+ *TCM_FIRST* 7)) (define-win-constant *TCM_INSERTITEM* (+ *TCM_FIRST* 7))
(define-win-constant *TCM_SETCURSEL* (+ *TCM_FIRST* 12)) (define-win-constant *TCM_SETCURSEL* (+ *TCM_FIRST* 12))
(define-win-constant *TCM_SETITEM* (+ *TCM_FIRST* 6)) (define-win-constant *TCM_SETITEM* (+ *TCM_FIRST* 6))
(define-win-constant *TCN_SELCHANGE* (- *TCN_FIRST* 1)) (define-win-constant *TCN_SELCHANGE* (- *TCN_FIRST* 1))
(define-win-constant *NM_FIRST* #x100000000) (define-win-constant *NM_FIRST* #x100000000)
(define-win-constant *NM_CLICK* (- *NM_FIRST* 1)) (define-win-constant *NM_CLICK* (- *NM_FIRST* 1))
(define-win-constant *NM_RCLICK* (- *NM_FIRST* 5)) (define-win-constant *NM_RCLICK* (- *NM_FIRST* 5))
(define-win-constant *SW_HIDE* 0) (define-win-constant *SW_HIDE* 0)
(define-win-constant *SW_SHOW* 5) (define-win-constant *SW_SHOW* 5)
(define-win-constant *SW_SHOWNORMAL* 1) (define-win-constant *SW_SHOWNORMAL* 1)
(define-win-constant *RDW_ERASE* #x0004) (define-win-constant *RDW_ERASE* #x0004)
(define-win-constant *RDW_FRAME* #x0400) (define-win-constant *RDW_FRAME* #x0400)
(define-win-constant *RDW_INTERNALPAINT* #x0002) (define-win-constant *RDW_INTERNALPAINT* #x0002)
(define-win-constant *RDW_INVALIDATE* #x0001) (define-win-constant *RDW_INVALIDATE* #x0001)
(define-win-constant *RDW_NOERASE* #x0020) (define-win-constant *RDW_NOERASE* #x0020)
(define-win-constant *RDW_NOFRAME* #x0800) (define-win-constant *RDW_NOFRAME* #x0800)
(define-win-constant *RDW_NOINTERNALPAINT* #x0010) (define-win-constant *RDW_NOINTERNALPAINT* #x0010)
(define-win-constant *RDW_VALIDATE* #x0008) (define-win-constant *RDW_VALIDATE* #x0008)
(define-win-constant *RDW_ERASENOW* #x0200) (define-win-constant *RDW_ERASENOW* #x0200)
(define-win-constant *RDW_UPDATENOW* #x0100) (define-win-constant *RDW_UPDATENOW* #x0100)
(define-win-constant *RDW_ALLCHILDREN* #x0080) (define-win-constant *RDW_ALLCHILDREN* #x0080)
(define-win-constant *RDW_NOCHILDREN* #x0040) (define-win-constant *RDW_NOCHILDREN* #x0040)
(define-win-constant *CW_USEDEFAULT* (- #x80000000)) (define-win-constant *CW_USEDEFAULT* (- #x80000000))
(define-win-constant *IDC_ARROW* 32512) (define-win-constant *IDC_ARROW* 32512)
(define-win-constant *IDI_APPLICATION* 32512) (define-win-constant *IDI_APPLICATION* 32512)
(define-win-constant *COLOR_BACKGROUND* 1) (define-win-constant *COLOR_BACKGROUND* 1)
(define-win-constant *DEFAULT_GUI_FONT* 17) (define-win-constant *DEFAULT_GUI_FONT* 17)
(define-win-constant *OEM_FIXED_FONT* 10) (define-win-constant *OEM_FIXED_FONT* 10)
(define-win-constant *SYSTEM_FONT* 13) (define-win-constant *SYSTEM_FONT* 13)
(define-win-constant *SYSTEM_FIXED_FONT* 16) (define-win-constant *SYSTEM_FIXED_FONT* 16)
(define-win-constant *MB_HELP* #x00004000) (define-win-constant *MB_HELP* #x00004000)
(define-win-constant *MB_OK* #x00000000) (define-win-constant *MB_OK* #x00000000)
(define-win-constant *MB_OKCANCEL* #x00000001) (define-win-constant *MB_OKCANCEL* #x00000001)
(define-win-constant *MB_YESNO* #x00000004) (define-win-constant *MB_YESNO* #x00000004)
(define-win-constant *MB_YESNOCANCEL* #x00000003) (define-win-constant *MB_YESNOCANCEL* #x00000003)
(define-win-constant *MB_ICONEXCLAMATION* #x00000030) (define-win-constant *MB_ICONEXCLAMATION* #x00000030)
(define-win-constant *MB_ICONWARNING* #x00000020) (define-win-constant *MB_ICONWARNING* #x00000020)
(define-win-constant *MB_ICONERROR* #x00000010) (define-win-constant *MB_ICONERROR* #x00000010)
(define-win-constant *MB_ICONINFORMATION* #x00000040) (define-win-constant *MB_ICONINFORMATION* #x00000040)
(define-win-constant *MB_ICONQUESTION* #x00000020) (define-win-constant *MB_ICONQUESTION* #x00000020)
(define-win-constant *IDCANCEL* 2) (define-win-constant *IDCANCEL* 2)
(define-win-constant *IDNO* 7) (define-win-constant *IDNO* 7)
(define-win-constant *IDOK* 1) (define-win-constant *IDOK* 1)
(define-win-constant *IDYES* 6) (define-win-constant *IDYES* 6)
(define-win-constant *MF_BYCOMMAND* #x00000000) (define-win-constant *MF_BYCOMMAND* #x00000000)
(define-win-constant *MF_BYPOSITION* #x00000400) (define-win-constant *MF_BYPOSITION* #x00000400)
(define-win-constant *MF_CHECKED* #x00000008) (define-win-constant *MF_CHECKED* #x00000008)
(define-win-constant *MF_DISABLED* #x00000002) (define-win-constant *MF_DISABLED* #x00000002)
(define-win-constant *MF_ENABLED* #x00000000) (define-win-constant *MF_ENABLED* #x00000000)
(define-win-constant *MF_GRAYED* #x00000001) (define-win-constant *MF_GRAYED* #x00000001)
(define-win-constant *MF_MENUBREAK* #x00000040) (define-win-constant *MF_MENUBREAK* #x00000040)
(define-win-constant *MF_POPUP* #x00000010) (define-win-constant *MF_POPUP* #x00000010)
(define-win-constant *MF_SEPARATOR* #x00000800) (define-win-constant *MF_SEPARATOR* #x00000800)
(define-win-constant *MF_STRING* #x00000000) (define-win-constant *MF_STRING* #x00000000)
(define-win-constant *MF_UNCHECKED* #x00000000) (define-win-constant *MF_UNCHECKED* #x00000000)
(define-win-constant *TPM_CENTERALIGN* #x0004) (define-win-constant *TPM_CENTERALIGN* #x0004)
(define-win-constant *TPM_LEFTALIGN* #x0000) (define-win-constant *TPM_LEFTALIGN* #x0000)
(define-win-constant *TPM_RIGHTALIGN* #x0008) (define-win-constant *TPM_RIGHTALIGN* #x0008)
(define-win-constant *TPM_BOTTOMALIGN* #x0020) (define-win-constant *TPM_BOTTOMALIGN* #x0020)
(define-win-constant *TPM_TOPALIGN* #x0000) (define-win-constant *TPM_TOPALIGN* #x0000)
(define-win-constant *TPM_VCENTERALIGN* #x0010) (define-win-constant *TPM_VCENTERALIGN* #x0010)
(define-win-constant *TPM_NONOTIFY* #x0080) (define-win-constant *TPM_NONOTIFY* #x0080)
(define-win-constant *TPM_RETURNCMD* #x0100) (define-win-constant *TPM_RETURNCMD* #x0100)
(define-win-constant *TPM_LEFTBUTTON* #x0000) (define-win-constant *TPM_LEFTBUTTON* #x0000)
(define-win-constant *TPM_RIGHTBUTTON* #x0002) (define-win-constant *TPM_RIGHTBUTTON* #x0002)
(define-win-constant *OFN_FILEMUSTEXIST* #x00001000) (define-win-constant *OFN_FILEMUSTEXIST* #x00001000)
(define-win-constant *OFN_OVERWRITEPROMPT* #x00000002) (define-win-constant *OFN_OVERWRITEPROMPT* #x00000002)
(define-win-constant *OFN_PATHMUSTEXIST* #x00000800) (define-win-constant *OFN_PATHMUSTEXIST* #x00000800)
(define-win-constant *OFN_READONLY* #x00000001) (define-win-constant *OFN_READONLY* #x00000001)
(define-win-constant *FVIRTKEY* *TRUE*) (define-win-constant *FVIRTKEY* *TRUE*)
(define-win-constant *FNOINVERT* #x02) (define-win-constant *FNOINVERT* #x02)
(define-win-constant *FSHIFT* #x04) (define-win-constant *FSHIFT* #x04)
(define-win-constant *FCONTROL* #x08) (define-win-constant *FCONTROL* #x08)
(define-win-constant *FALT* #x10) (define-win-constant *FALT* #x10)
(define-win-constant *VK_F1* #x70) (define-win-constant *VK_F1* #x70)
(define-win-constant *VK_LEFT* #x25) (define-win-constant *VK_LEFT* #x25)
(define-win-constant *VK_RIGHT* #x27) (define-win-constant *VK_RIGHT* #x27)
(define-win-constant *GWL_EXSTYLE* -20) (define-win-constant *GWL_EXSTYLE* -20)
(define-win-constant *GWL_HINSTANCE* -6) (define-win-constant *GWL_HINSTANCE* -6)
(define-win-constant *GWL_HWNDPARENT* -8) (define-win-constant *GWL_HWNDPARENT* -8)
(define-win-constant *GWL_ID* -12) (define-win-constant *GWL_ID* -12)
(define-win-constant *GWL_STYLE* -16) (define-win-constant *GWL_STYLE* -16)
(define-win-constant *GWL_WNDPROC* -4) (define-win-constant *GWL_WNDPROC* -4)
(define-win-constant *FINDMSGSTRING* "commdlg_FindReplace") (define-win-constant *FINDMSGSTRING* "commdlg_FindReplace")
(define-win-constant *HELPMSGSTRING* "commdlg_help") (define-win-constant *HELPMSGSTRING* "commdlg_help")
(define-win-constant *FR_DIALOGTERM* #x00000040) (define-win-constant *FR_DIALOGTERM* #x00000040)
(define-win-constant *FR_DOWN* #x00000001) (define-win-constant *FR_DOWN* #x00000001)
(define-win-constant *FR_FINDNEXT* #x00000008) (define-win-constant *FR_FINDNEXT* #x00000008)
(define-win-constant *FR_HIDEUPDOWN* #x00004000) (define-win-constant *FR_HIDEUPDOWN* #x00004000)
(define-win-constant *FR_HIDEMATCHCASE* #x00008000) (define-win-constant *FR_HIDEMATCHCASE* #x00008000)
(define-win-constant *FR_HIDEWHOLEWORD* #x00010000) (define-win-constant *FR_HIDEWHOLEWORD* #x00010000)
(define-win-constant *FR_MATCHCASE* #x00000004) (define-win-constant *FR_MATCHCASE* #x00000004)
(define-win-constant *FR_NOMATCHCASE* #x00000800) (define-win-constant *FR_NOMATCHCASE* #x00000800)
(define-win-constant *FR_NOUPDOWN* #x00000400) (define-win-constant *FR_NOUPDOWN* #x00000400)
(define-win-constant *FR_NOWHOLEWORD* #x00001000) (define-win-constant *FR_NOWHOLEWORD* #x00001000)
(define-win-constant *FR_REPLACE* #x00000010) (define-win-constant *FR_REPLACE* #x00000010)
(define-win-constant *FR_REPLACEALL* #x00000020) (define-win-constant *FR_REPLACEALL* #x00000020)
(define-win-constant *FR_SHOWHELP* #x00000080) (define-win-constant *FR_SHOWHELP* #x00000080)
(define-win-constant *FR_WHOLEWORD* #x00000002) (define-win-constant *FR_WHOLEWORD* #x00000002)
(defconstant *NULL* (make-null-pointer :void)) (defconstant *NULL* (make-null-pointer :void))
;; Windows structures ;; Windows structures
(def-struct WNDCLASS (def-struct WNDCLASS
(style :unsigned-int) (style :unsigned-int)
(lpfnWndProc WNDPROC) (lpfnWndProc WNDPROC)
(cbClsExtra :int) (cbClsExtra :int)
(cbWndExtra :int) (cbWndExtra :int)
(hInstance HANDLE) (hInstance HANDLE)
(hIcon HANDLE) (hIcon HANDLE)
(hCursor HANDLE) (hCursor HANDLE)
(hbrBackground HANDLE) (hbrBackground HANDLE)
(lpszMenuName :cstring) (lpszMenuName :cstring)
(lpszClassName :cstring)) (lpszClassName :cstring))
(defun make-wndclass (name &key (style 0) (lpfnWndProc nil) (cbClsExtra 0) (cbWndExtra 0) (hInstance *NULL*) (defun make-wndclass (name &key (style 0) (lpfnWndProc nil) (cbClsExtra 0) (cbWndExtra 0) (hInstance *NULL*)
(hIcon (default-icon)) (hCursor (default-cursor)) (hbrBackground (default-background)) (hIcon (default-icon)) (hCursor (default-cursor)) (hbrBackground (default-background))
(lpszMenuName "")) (lpszMenuName ""))
(with-foreign-object (cls 'WNDCLASS) (with-foreign-object (cls 'WNDCLASS)
(setf (get-slot-value cls 'WNDCLASS 'style) style (setf (get-slot-value cls 'WNDCLASS 'style) style
(get-slot-value cls 'WNDCLASS 'lpfnWndProc) (callback 'wndproc-proxy) (get-slot-value cls 'WNDCLASS 'lpfnWndProc) (callback 'wndproc-proxy)
(get-slot-value cls 'WNDCLASS 'cbClsExtra) cbClsExtra (get-slot-value cls 'WNDCLASS 'cbClsExtra) cbClsExtra
(get-slot-value cls 'WNDCLASS 'cbWndExtra) cbWndExtra (get-slot-value cls 'WNDCLASS 'cbWndExtra) cbWndExtra
(get-slot-value cls 'WNDCLASS 'hInstance) hInstance (get-slot-value cls 'WNDCLASS 'hInstance) hInstance
(get-slot-value cls 'WNDCLASS 'hIcon) hIcon (get-slot-value cls 'WNDCLASS 'hIcon) hIcon
(get-slot-value cls 'WNDCLASS 'hCursor) hCursor (get-slot-value cls 'WNDCLASS 'hCursor) hCursor
(get-slot-value cls 'WNDCLASS 'hbrBackground) hbrBackground (get-slot-value cls 'WNDCLASS 'hbrBackground) hbrBackground
(get-slot-value cls 'WNDCLASS 'lpszMenuName) lpszMenuName (get-slot-value cls 'WNDCLASS 'lpszMenuName) lpszMenuName
(get-slot-value cls 'WNDCLASS 'lpszClassName) (string name)) (get-slot-value cls 'WNDCLASS 'lpszClassName) (string name))
(register-wndproc (string name) lpfnWndProc) (register-wndproc (string name) lpfnWndProc)
(registerclass cls))) (registerclass cls)))
(def-struct POINT (def-struct POINT
(x :int) (x :int)
(y :int)) (y :int))
(def-struct MSG (def-struct MSG
(hwnd HANDLE) (hwnd HANDLE)
(message :unsigned-int) (message :unsigned-int)
(wParam :unsigned-int) (wParam :unsigned-int)
(lParam :int) (lParam :int)
(time :unsigned-int) (time :unsigned-int)
(pt POINT)) (pt POINT))
(def-struct CREATESTRUCT (def-struct CREATESTRUCT
(lpCreateParams :pointer-void) (lpCreateParams :pointer-void)
(hInstance HANDLE) (hInstance HANDLE)
(hMenu HANDLE) (hMenu HANDLE)
(hwndParent HANDLE) (hwndParent HANDLE)
(cx :int) (cx :int)
(cy :int) (cy :int)
(x :int) (x :int)
(y :int) (y :int)
(style :long) (style :long)
(lpszName :cstring) (lpszName :cstring)
(lpszClass :cstring) (lpszClass :cstring)
(dwExStyle :unsigned-int)) (dwExStyle :unsigned-int))
(def-struct MINMAXINFO (def-struct MINMAXINFO
(ptReserved POINT) (ptReserved POINT)
(ptMaxSize POINT) (ptMaxSize POINT)
(ptMaxPosition POINT) (ptMaxPosition POINT)
(ptMinTrackSize POINT) (ptMinTrackSize POINT)
(ptMaxTrackSize POINT)) (ptMaxTrackSize POINT))
(def-struct TEXTMETRIC (tmHeight :long) (tmAscent :long) (tmDescent :long) (tmInternalLeading :long) (tmExternalLeading :long) (def-struct TEXTMETRIC (tmHeight :long) (tmAscent :long) (tmDescent :long) (tmInternalLeading :long) (tmExternalLeading :long)
(tmAveCharWidth :long) (tmMaxCharWidth :long) (tmWeight :long) (tmOverhang :long) (tmDigitizedAspectX :long) (tmAveCharWidth :long) (tmMaxCharWidth :long) (tmWeight :long) (tmOverhang :long) (tmDigitizedAspectX :long)
(tmDigitizedAspectY :long) (tmFirstChar :char) (tmLastChar :char) (tmDefaultChar :char) (tmBreakChar :char) (tmDigitizedAspectY :long) (tmFirstChar :char) (tmLastChar :char) (tmDefaultChar :char) (tmBreakChar :char)
(tmItalic :byte) (tmUnderlined :byte) (tmStruckOut :byte) (tmPitchAndFamily :byte) (tmCharSet :byte)) (tmItalic :byte) (tmUnderlined :byte) (tmStruckOut :byte) (tmPitchAndFamily :byte) (tmCharSet :byte))
(def-struct SIZE (cx :long) (cy :long)) (def-struct SIZE (cx :long) (cy :long))
(def-struct RECT (left :long) (top :long) (right :long) (bottom :long)) (def-struct RECT (left :long) (top :long) (right :long) (bottom :long))
(def-struct TITLEBARINFO (cbSize :unsigned-int) (rcTitlebar RECT) (rgstate (:array :unsigned-int 6))) (def-struct TITLEBARINFO (cbSize :unsigned-int) (rcTitlebar RECT) (rgstate (:array :unsigned-int 6)))
(def-struct OPENFILENAME (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (lpstrFilter LPCSTR) (lpstrCustomFilter LPCSTR) (def-struct OPENFILENAME (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (lpstrFilter LPCSTR) (lpstrCustomFilter LPCSTR)
(nMaxFilter :unsigned-int) (nFilterIndex :unsigned-int) (lpstrFile LPCSTR) (nMaxFile :unsigned-int) (lpstrFileTitle LPCSTR) (nMaxFilter :unsigned-int) (nFilterIndex :unsigned-int) (lpstrFile LPCSTR) (nMaxFile :unsigned-int) (lpstrFileTitle LPCSTR)
(nMaxFileTitle :unsigned-int) (lpstrInitialDir LPCSTR) (lpstrTitle LPCSTR) (Flags :unsigned-int) (nFileOffset :unsigned-short) (nMaxFileTitle :unsigned-int) (lpstrInitialDir LPCSTR) (lpstrTitle LPCSTR) (Flags :unsigned-int) (nFileOffset :unsigned-short)
(nFileExtension :unsigned-short) (lpstrDefExt LPCSTR) (lCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR) (nFileExtension :unsigned-short) (lpstrDefExt LPCSTR) (lCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR)
#|(pvReserved :pointer-void) (dwReserved :unsigned-int) (FlagsEx :unsigned-int)|#) #|(pvReserved :pointer-void) (dwReserved :unsigned-int) (FlagsEx :unsigned-int)|#)
(def-struct ACCEL (fVirt :byte) (key :unsigned-short) (cmd :unsigned-short)) (def-struct ACCEL (fVirt :byte) (key :unsigned-short) (cmd :unsigned-short))
(def-struct TCITEM (mask :unsigned-int) (dwState :unsigned-int) (dwStateMask :unsigned-int) (def-struct TCITEM (mask :unsigned-int) (dwState :unsigned-int) (dwStateMask :unsigned-int)
(pszText :cstring) (cchTextMax :int) (iImage :int) (lParam :long)) (pszText :cstring) (cchTextMax :int) (iImage :int) (lParam :long))
(def-struct NMHDR (hwndFrom HANDLE) (idFrom :unsigned-int) (code :unsigned-int)) (def-struct NMHDR (hwndFrom HANDLE) (idFrom :unsigned-int) (code :unsigned-int))
(def-struct TCHITTESTINFO (pt POINT) (flag :unsigned-int)) (def-struct TCHITTESTINFO (pt POINT) (flag :unsigned-int))
(def-struct TPMPARAMS (cbSize :unsigned-int) (rcExclude RECT)) (def-struct TPMPARAMS (cbSize :unsigned-int) (rcExclude RECT))
(def-struct FINDREPLACE (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (Flags DWORD) (def-struct FINDREPLACE (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (Flags DWORD)
(lpstrFindWhat LPCSTR) (lpstrReplaceWith LPCSTR) (wFindWhatLen WORD) (wReplaceWithLen WORD) (lpstrFindWhat LPCSTR) (lpstrReplaceWith LPCSTR) (wFindWhatLen WORD) (wReplaceWithLen WORD)
(lpCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR)) (lpCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR))
;; Windows functions ;; Windows functions
@ -337,9 +337,9 @@
old-proc))) old-proc)))
(defun get-wndproc (obj) (defun get-wndproc (obj)
(let ((entry (or (assoc obj *wndproc-db* :test #'equal) (let ((entry (or (assoc obj *wndproc-db* :test #'equal)
(assoc (getclassname obj) *wndproc-db* :test #'equal)))) (assoc (getclassname obj) *wndproc-db* :test #'equal))))
(and entry (and entry
(cdr entry)))) (cdr entry))))
(defcallback (wndproc-proxy :stdcall) :int ((hnd :pointer-void) (umsg :unsigned-int) (wparam :unsigned-int) (lparam :int)) (defcallback (wndproc-proxy :stdcall) :int ((hnd :pointer-void) (umsg :unsigned-int) (wparam :unsigned-int) (lparam :int))
(let* ((wndproc (get-wndproc hnd))) (let* ((wndproc (get-wndproc hnd)))
(unless wndproc (unless wndproc
@ -395,16 +395,16 @@
(with-foreign-object (s `(:array :char ,max-length)) (with-foreign-object (s `(:array :char ,max-length))
(let ((n (getclassname-i hnd s max-length))) (let ((n (getclassname-i hnd s max-length)))
(when (= n 0) (when (= n 0)
(error "Unable to get class name for ~A" hnd)) (error "Unable to get class name for ~A" hnd))
(convert-from-foreign-string s :length n)))) (convert-from-foreign-string s :length n))))
(def-win32-function ("RegisterClassA" registerclass) ((lpWndClass (* WNDCLASS))) :returning :int :module "user32") (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 ("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 ("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 ("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) (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) (x :int) (y :int) (nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE)
(lpParam :pointer-void)) (lpParam :pointer-void))
:returning HANDLE :module "user32") :returning HANDLE :module "user32")
(defun createwindow (&rest args) (defun createwindow (&rest args)
(apply #'createwindowex 0 args)) (apply #'createwindowex 0 args))
(def-win32-function ("DestroyWindow" destroywindow) ((hWnd HANDLE)) :returning :int :module "user32") (def-win32-function ("DestroyWindow" destroywindow) ((hWnd HANDLE)) :returning :int :module "user32")
@ -413,7 +413,7 @@
(def-win32-function ("RedrawWindow" redrawwindow) ((hWnd HANDLE) (lprcUpdate (* RECT)) (hrgnUpdate HANDLE) (flags :unsigned-int)) :returning :int :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 ("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) (def-win32-function ("SetWindowPos" setwindowpos) ((hWnd HANDLE) (hWndInsertAfter HANDLE) (x :int)
(y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int :module "user32") (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 ("BringWindowToTop" bringwindowtotop) ((hWnd HANDLE)) :returning :int :module "user32")
(def-win32-function ("GetWindowTextA" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int :module "user32") (def-win32-function ("GetWindowTextA" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int :module "user32")
(defun getwindowtext (hnd) (defun getwindowtext (hnd)
@ -461,9 +461,9 @@
(def-win32-function ("CheckMenuItem" checkmenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :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 ("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) (def-win32-function ("TrackPopupMenu" trackpopupmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (x :int) (y :int)
(nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32") (nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32")
(def-win32-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int) (def-win32-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int)
(hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32") (hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32")
(def-win32-function ("CreateAcceleratorTableA" createacceleratortable) ((lpaccl (* ACCEL)) (cEntries :int)) :returning HANDLE :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 ("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 ("DestroyAcceleratorTable" destroyacceleratortable) ((hAccTable HANDLE)) :returning :int :module "user32")
@ -472,19 +472,19 @@
(defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*) (dlgSym nil)) (defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*) (dlgSym nil))
(with-foreign-object (msg 'MSG) (with-foreign-object (msg 'MSG)
(loop for bRet = (getmessage msg *NULL* 0 0) (loop for bRet = (getmessage msg *NULL* 0 0)
when (= bRet 0) return bRet when (= bRet 0) return bRet
if (= bRet -1) if (= bRet -1)
do (error "GetMessage failed!!!") do (error "GetMessage failed!!!")
else else
do (or (and (not (null-pointer-p accelTable)) do (or (and (not (null-pointer-p accelTable))
(not (null-pointer-p accelMain)) (not (null-pointer-p accelMain))
(/= (translateaccelerator accelMain accelTable msg) 0)) (/= (translateaccelerator accelMain accelTable msg) 0))
(and dlgSym (and dlgSym
(not (null-pointer-p (symbol-value dlgSym))) (not (null-pointer-p (symbol-value dlgSym)))
(/= (isdialogmessage (symbol-value dlgSym) msg) 0)) (/= (isdialogmessage (symbol-value dlgSym) msg) 0))
(progn (progn
(translatemessage msg) (translatemessage msg)
(dispatchmessage msg)))))) (dispatchmessage msg))))))
(defun y-or-no-p (&optional control &rest args) (defun y-or-no-p (&optional control &rest args)
(let ((s (coerce (apply #'format nil control args) 'simple-string))) (let ((s (coerce (apply #'format nil control args) 'simple-string)))
@ -492,24 +492,24 @@
*IDYES*))) *IDYES*)))
(defun get-open-filename (&key (owner *NULL*) initial-dir filter (dlgfn #'getopenfilename) (defun get-open-filename (&key (owner *NULL*) initial-dir filter (dlgfn #'getopenfilename)
(flags 0) &aux (max-fn-size 1024)) (flags 0) &aux (max-fn-size 1024))
(flet ((null-concat (x &optional y &aux (xx (if y x (car x))) (yy (if y y (cdr x)))) (flet ((null-concat (x &optional y &aux (xx (if y x (car x))) (yy (if y y (cdr x))))
(concatenate 'string xx (string #\Null) yy))) (concatenate 'string xx (string #\Null) yy)))
(when filter (when filter
(setq filter (format nil "~A~C~C" (reduce #'null-concat (mapcar #'null-concat filter)) #\Null #\Null))) (setq filter (format nil "~A~C~C" (reduce #'null-concat (mapcar #'null-concat filter)) #\Null #\Null)))
(with-foreign-object (ofn 'OPENFILENAME) (with-foreign-object (ofn 'OPENFILENAME)
(with-cstrings ((fn (make-string max-fn-size :initial-element #\Null)) (with-cstrings ((fn (make-string max-fn-size :initial-element #\Null))
(filter filter)) (filter filter))
(zeromemory ofn (size-of-foreign-type 'OPENFILENAME)) (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 'lStructSize) (size-of-foreign-type 'OPENFILENAME))
(setf (get-slot-value ofn 'OPENFILENAME 'hwndOwner) owner) (setf (get-slot-value ofn 'OPENFILENAME 'hwndOwner) owner)
(setf (get-slot-value ofn 'OPENFILENAME 'lpstrFile) fn) (setf (get-slot-value ofn 'OPENFILENAME 'lpstrFile) fn)
(setf (get-slot-value ofn 'OPENFILENAME 'nMaxFile) max-fn-size) (setf (get-slot-value ofn 'OPENFILENAME 'nMaxFile) max-fn-size)
(setf (get-slot-value ofn 'OPENFILENAME 'Flags) flags) (setf (get-slot-value ofn 'OPENFILENAME 'Flags) flags)
(when filter (when filter
(setf (get-slot-value ofn 'OPENFILENAME 'lpstrFilter) filter)) (setf (get-slot-value ofn 'OPENFILENAME 'lpstrFilter) filter))
(unless (= (funcall dlgfn ofn) 0) (unless (= (funcall dlgfn ofn) 0)
(pathname (string-trim (string #\Null) fn))))))) (pathname (string-trim (string #\Null) fn)))))))
(defun find-text (&key (owner *NULL*) &aux (max-txt-size 1024)) (defun find-text (&key (owner *NULL*) &aux (max-txt-size 1024))
(with-foreign-object (fr 'FINDREPLACE) (with-foreign-object (fr 'FINDREPLACE)
@ -520,13 +520,13 @@
(setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) max-txt-size) (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) max-txt-size)
;(setf (get-slot-value fr 'FINDREPLACE 'Flags) 1) ;(setf (get-slot-value fr 'FINDREPLACE 'Flags) 1)
(let ((result (findtext fr))) (let ((result (findtext fr)))
(print result) (print result)
txt)))) txt))))
#| #|
(defun set-wndproc (obj fun) (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))) (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))) (old-wndproc (make-pointer (getwindowlong obj *GWL_WNDPROC*) 'HANDLE)))
(setwindowlong obj *GWL_WNDPROC* (make-lparam cb)) (setwindowlong obj *GWL_WNDPROC* (make-lparam cb))
old-wndproc)) old-wndproc))
|# |#
@ -543,17 +543,17 @@
(defun button-min-size (hnd) (defun button-min-size (hnd)
(let ((fnt (make-pointer (sendmessage hnd *WM_GETFONT* 0 0) :pointer-void)) (let ((fnt (make-pointer (sendmessage hnd *WM_GETFONT* 0 0) :pointer-void))
(hdc (getdc hnd)) (hdc (getdc hnd))
(txt (getwindowtext hnd))) (txt (getwindowtext hnd)))
(unless (null-pointer-p fnt) (unless (null-pointer-p fnt)
(selectobject hdc fnt)) (selectobject hdc fnt))
(with-foreign-objects ((sz 'SIZE) (with-foreign-objects ((sz 'SIZE)
(tm 'TEXTMETRIC)) (tm 'TEXTMETRIC))
(gettextextentpoint32 hdc txt (length txt) sz) (gettextextentpoint32 hdc txt (length txt) sz)
(gettextmetrics hdc tm) (gettextmetrics hdc tm)
(releasedc hnd hdc) (releasedc hnd hdc)
(list (+ (get-slot-value sz 'SIZE 'cx) 20) (list (+ (get-slot-value sz 'SIZE 'cx) 20)
(+ (get-slot-value tm 'TEXTMETRIC 'tmHeight) 10))))) (+ (get-slot-value tm 'TEXTMETRIC 'tmHeight) 10)))))
(defun get-titlebar-rect (hnd) (defun get-titlebar-rect (hnd)
(with-foreign-object (ti 'TITLEBARINFO) (with-foreign-object (ti 'TITLEBARINFO)
@ -561,74 +561,74 @@
(gettitlebarinfo hnd ti) (gettitlebarinfo hnd ti)
(let ((rc (get-slot-value ti 'TITLEBARINFO 'rcTitlebar))) (let ((rc (get-slot-value ti 'TITLEBARINFO 'rcTitlebar)))
(list (get-slot-value rc 'RECT 'left) (list (get-slot-value rc 'RECT 'left)
(get-slot-value rc 'RECT 'top) (get-slot-value rc 'RECT 'top)
(get-slot-value rc 'RECT 'right) (get-slot-value rc 'RECT 'right)
(get-slot-value rc 'RECT 'bottom))))) (get-slot-value rc 'RECT 'bottom)))))
(defun test-wndproc (hwnd umsg wparam lparam) (defun test-wndproc (hwnd umsg wparam lparam)
(cond ((= umsg *WM_DESTROY*) (cond ((= umsg *WM_DESTROY*)
(setq hBtn nil hOk nil) (setq hBtn nil hOk nil)
(postquitmessage 0) (postquitmessage 0)
0) 0)
((= umsg *WM_CREATE*) ((= umsg *WM_CREATE*)
(setq hBtn (createwindowex 0 "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*)) 0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*))
(setq hOk (createwindowex 0 "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*)) 0 0 50 20 hwnd (make-ID *OK_ID*) *NULL* *NULL*))
(sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) (sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
(sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) (sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
0) 0)
((= umsg *WM_SIZE*) ((= umsg *WM_SIZE*)
(let* ((new-w (loword lparam)) (let* ((new-w (loword lparam))
(new-h (hiword lparam)) (new-h (hiword lparam))
(wb (- new-w 20)) (wb (- new-w 20))
(hb (/ (- new-h 30) 2))) (hb (/ (- new-h 30) 2)))
(movewindow hBtn 10 10 wb hb *TRUE*) (movewindow hBtn 10 10 wb hb *TRUE*)
(movewindow hOk 10 (+ 20 hb) wb hb *TRUE*)) (movewindow hOk 10 (+ 20 hb) wb hb *TRUE*))
0) 0)
((= umsg *WM_GETMINMAXINFO*) ((= umsg *WM_GETMINMAXINFO*)
(let* ((btn1-sz (and hBtn (button-min-size hBtn))) (let* ((btn1-sz (and hBtn (button-min-size hBtn)))
(btn2-sz (and hOk (button-min-size hOk))) (btn2-sz (and hOk (button-min-size hOk)))
#|(rc (get-titlebar-rect hWnd))|# #|(rc (get-titlebar-rect hWnd))|#
(titleH #|(1+ (- (fourth rc) (second rc)))|# 30)) (titleH #|(1+ (- (fourth rc) (second rc)))|# 30))
(when (and btn1-sz btn2-sz (> titleH 0)) (when (and btn1-sz btn2-sz (> titleH 0))
(with-foreign-object (minSz 'POINT) (with-foreign-object (minSz 'POINT)
(setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20)) (setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20))
(setf (get-slot-value minSz 'POINT 'y) (+ (second btn1-sz) (second btn2-sz) 30 titleH)) (setf (get-slot-value minSz 'POINT 'y) (+ (second btn1-sz) (second btn2-sz) 30 titleH))
(with-cast-int-pointer (lparam MINMAXINFO) (with-cast-int-pointer (lparam MINMAXINFO)
(setf (get-slot-value lparam 'MINMAXINFO 'ptMinTrackSize) minSz))))) (setf (get-slot-value lparam 'MINMAXINFO 'ptMinTrackSize) minSz)))))
0) 0)
((= umsg *WM_COMMAND*) ((= umsg *WM_COMMAND*)
(let ((n (hiword wparam)) (let ((n (hiword wparam))
(id (loword wparam))) (id (loword wparam)))
(cond ((= n *BN_CLICKED*) (cond ((= n *BN_CLICKED*)
(cond ((= id *HELLO_ID*) (cond ((= id *HELLO_ID*)
(format t "~&Hellow World!~%") (format t "~&Hellow World!~%")
(get-open-filename :owner hwnd)) (get-open-filename :owner hwnd))
((= id *OK_ID*) ((= id *OK_ID*)
(destroywindow hwnd)))) (destroywindow hwnd))))
(t (t
(format t "~&Un-handled notification: ~D~%" n)))) (format t "~&Un-handled notification: ~D~%" n))))
0) 0)
(t (t
(defwindowproc hwnd umsg wparam lparam)))) (defwindowproc hwnd umsg wparam lparam))))
(defun do-test () (defun do-test ()
(make-wndclass "MyClass" (make-wndclass "MyClass"
:lpfnWndProc #'test-wndproc) :lpfnWndProc #'test-wndproc)
(let* ((hwnd (createwindowex (let* ((hwnd (createwindowex
0 0
"MyClass" "MyClass"
"ECL/Win32 test" "ECL/Win32 test"
*WS_OVERLAPPEDWINDOW* *WS_OVERLAPPEDWINDOW*
*CW_USEDEFAULT* *CW_USEDEFAULT*
*CW_USEDEFAULT* *CW_USEDEFAULT*
130 130
120 120
*NULL* *NULL*
*NULL* *NULL*
*NULL* *NULL*
*NULL*))) *NULL*)))
(when (si::null-pointer-p hwnd) (when (si::null-pointer-p hwnd)
(error "Unable to create window")) (error "Unable to create window"))
(showwindow hwnd *SW_SHOWNORMAL*) (showwindow hwnd *SW_SHOWNORMAL*)

4
examples/asdf/readme.lisp
View file

@ -92,5 +92,5 @@ Executing standalone file 'example'
;;; ;;;
(mapc #'delete-file (append (directory "*.o") (mapc #'delete-file (append (directory "*.o")
(directory "*.obj") (directory "*.obj")
(directory "example-mono*"))) (directory "example-mono*")))

2
examples/build/hello.lisp
View file

@ -5,7 +5,7 @@
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version. ;;; version 2 of the License, or (at your option) any later version.
;;; ;;;
;;; See file '../Copyright' for full details. ;;; See file '../Copyright' for full details.
(ffi::clines "extern const char *hello_string;") (ffi::clines "extern const char *hello_string;")

2
examples/build/hello_aux.c
View file

@ -5,7 +5,7 @@
* License as published by the Free Software Foundation; either * License as published by the Free Software Foundation; either
* version 2 of the License, or (at your option) any later version. * version 2 of the License, or (at your option) any later version.
* *
* See file '../Copyright' for full details. * See file '../Copyright' for full details.
*/ */
const char *hello_string = "Hello world!"; const char *hello_string = "Hello world!";

30
examples/build/readme.lisp
View file

@ -5,7 +5,7 @@
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version. ;;; version 2 of the License, or (at your option) any later version.
;;; ;;;
;;; See file '../Copyright' for full details. ;;; See file '../Copyright' for full details.
;;; ;;;
;;; DESCRIPTION: ;;; DESCRIPTION:
@ -14,15 +14,15 @@
;;; file called hello_aux.c. Both hello.lisp and hello_aux.c are ;;; file called hello_aux.c. Both hello.lisp and hello_aux.c are
;;; compiled and linked into either ;;; compiled and linked into either
;;; ;;;
;;; 1) a FASL file (see build_fasl.lisp) ;;; 1) a FASL file (see build_fasl.lisp)
;;; 2) a shared library (see build_dll.lisp) ;;; 2) a shared library (see build_dll.lisp)
;;; 3) or a standalone executable file. (build_exe.lisp) ;;; 3) or a standalone executable file. (build_exe.lisp)
;;; ;;;
;;; USE: ;;; USE:
;;; ;;;
;;; Launch a copy of ECL and load this file in it ;;; Launch a copy of ECL and load this file in it
;;; ;;;
;;; (load "readme.lisp") ;;; (load "readme.lisp")
;;; ;;;
(format t " (format t "
@ -46,10 +46,10 @@
(defconstant +compound-fasl+ (compile-file-pathname "compound" :type :fasl)) (defconstant +compound-fasl+ (compile-file-pathname "compound" :type :fasl))
(c::build-fasl +compound-fasl+ (c::build-fasl +compound-fasl+
:lisp-files :lisp-files
(list (compile-file-pathname "hello.lisp" :type :object)) (list (compile-file-pathname "hello.lisp" :type :object))
:ld-flags :ld-flags
(list (namestring (compile-file-pathname "hello_aux.c" :type :object)))) (list (namestring (compile-file-pathname "hello_aux.c" :type :object))))
;;; ;;;
;;; * We load both files ;;; * We load both files
@ -73,12 +73,12 @@
(defconstant +standalone-exe+ (compile-file-pathname "standalone" :type :program)) (defconstant +standalone-exe+ (compile-file-pathname "standalone" :type :program))
(c::build-program +standalone-exe+ (c::build-program +standalone-exe+
:lisp-files :lisp-files
(list (compile-file-pathname "hello.lisp" :type :object)) (list (compile-file-pathname "hello.lisp" :type :object))
:ld-flags :ld-flags
(list (namestring (compile-file-pathname "hello_aux.c" :type :object))) (list (namestring (compile-file-pathname "hello_aux.c" :type :object)))
:epilogue-code :epilogue-code
'(si::quit)) '(si::quit))
;; ;;
;; * Test the program ;; * Test the program

114
examples/threads/import/import.c
View file

@ -18,13 +18,13 @@
#include <pthread.h> #include <pthread.h>
/* /*
* GOAL: To execute lisp code from threads which have not * GOAL: To execute lisp code from threads which have not
* been generated by our lisp environment. * been generated by our lisp environment.
* *
* ASSUMES: ECL has been configured with threads (--enable-threads) * ASSUMES: ECL has been configured with threads (--enable-threads)
* and installed somewhere on the path. * and installed somewhere on the path.
* *
* COMPILE: Run "make" from the command line. * COMPILE: Run "make" from the command line.
* *
* *
* When this example is compiled and run, it generates a number of * When this example is compiled and run, it generates a number of
@ -51,70 +51,70 @@
static void * static void *
thread_entry_point(void *data) thread_entry_point(void *data)
{ {
cl_object form = (cl_object)data; cl_object form = (cl_object)data;
/* /*
* This is the entry point of the threads we have created. * This is the entry point of the threads we have created.
* These threads have no valid lisp environment. The following * These threads have no valid lisp environment. The following
* routine initializes the lisp and makes it ready for working * routine initializes the lisp and makes it ready for working
* in this thread. * in this thread.
*/ */
ecl_import_current_thread(Cnil, Cnil); ecl_import_current_thread(Cnil, Cnil);
/* /*
* Here we execute some lisp code code. * Here we execute some lisp code code.
*/ */
cl_eval(form); cl_eval(form);
/* /*
* Finally, when we exit the thread we have to release the * Finally, when we exit the thread we have to release the
* resources allocated by the lisp environment. * resources allocated by the lisp environment.
*/ */
ecl_release_current_thread(); ecl_release_current_thread();
return NULL; return NULL;
} }
int main(int narg, char **argv) int main(int narg, char **argv)
{ {
pthread_t child_thread; pthread_t child_thread;
int i, code; int i, code;
/* /*
* First of all, we have to initialize the ECL environment. * First of all, we have to initialize the ECL environment.
* This should be done from the main thread. * This should be done from the main thread.
*/ */
cl_boot(narg, argv); cl_boot(narg, argv);
/* /*
* Here we spawn 10 threads using the OS functions. The * Here we spawn 10 threads using the OS functions. The
* current version is for Unix and uses pthread_create. * current version is for Unix and uses pthread_create.
* Since we have included <gc.h>, pthread_create will be * Since we have included <gc.h>, pthread_create will be
* replaced with the appropiate routine from the garbage * replaced with the appropiate routine from the garbage
* collector. * collector.
*/ */
cl_object sym_print = c_string_to_object("PRINT"); cl_object sym_print = c_string_to_object("PRINT");
/* /*
* This array will keep the forms we want to evaluate from * This array will keep the forms we want to evaluate from
* being garbage collected. * being garbage collected.
*/ */
volatile cl_object forms[4]; volatile cl_object forms[4];
for (i = 0; i < 4; i++) { for (i = 0; i < 4; i++) {
forms[i] = cl_list(2, sym_print, MAKE_FIXNUM(i)); forms[i] = cl_list(2, sym_print, MAKE_FIXNUM(i));
code = pthread_create(&child_thread, NULL, thread_entry_point, code = pthread_create(&child_thread, NULL, thread_entry_point,
(void*)forms[i]); (void*)forms[i]);
if (code) { if (code) {
printf("Unable to create thread\n"); printf("Unable to create thread\n");
exit(1); exit(1);
} }
} }
/* /*
* Here we wait for the last thread to finish. * Here we wait for the last thread to finish.
*/ */
pthread_join(child_thread, NULL); pthread_join(child_thread, NULL);
return 0; return 0;
} }

10
examples/threads/import_win32/import.c
View file

@ -20,13 +20,13 @@
#endif #endif
/* /*
* GOAL: To execute lisp code from threads which have not * GOAL: To execute lisp code from threads which have not
* been generated by our lisp environment. * been generated by our lisp environment.
* *
* ASSUMES: ECL has been configured with threads (--enable-threads) * ASSUMES: ECL has been configured with threads (--enable-threads)
* and installed somewhere on the path. * and installed somewhere on the path.
* *
* COMPILE: Run "make" from the command line. * COMPILE: Run "make" from the command line.
* *
* *
* When this example is compiled and run, it generates a number of * When this example is compiled and run, it generates a number of

16
src/clx/excldep.c
View file

@ -19,7 +19,7 @@
#define SUCCESS 1 #define SUCCESS 1
#ifdef FD_SETSIZE #ifdef FD_SETSIZE
#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ #define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */
#else #else
#define NUMBER_OF_FDS 32 #define NUMBER_OF_FDS 32
#endif #endif
@ -45,8 +45,8 @@ int fd_wait_for_input(fd, timeout)
int checkfds[CHECKLEN]; int checkfds[CHECKLEN];
if (fd < 0 || fd >= NUMBER_OF_FDS) { if (fd < 0 || fd >= NUMBER_OF_FDS) {
fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd);
fflush(stderr); fflush(stderr);
} }
for (i = 0; i < CHECKLEN; i++) for (i = 0; i < CHECKLEN; i++)
@ -54,18 +54,18 @@ int fd_wait_for_input(fd, timeout)
checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int)));
if (timeout) { if (timeout) {
timer.tv_sec = timeout; timer.tv_sec = timeout;
timer.tv_usec = 0; timer.tv_usec = 0;
i = select(32, checkfds, (int *)0, (int *)0, &timer); i = select(32, checkfds, (int *)0, (int *)0, &timer);
} else } else
i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0);
if (i < 0) if (i < 0)
/* error condition */ /* error condition */
if (errno == EINTR) if (errno == EINTR)
return (INTERRUPT); return (INTERRUPT);
else else
return (ERROR); return (ERROR);
else if (i == 0) else if (i == 0)
return (TIMEOUT); return (TIMEOUT);
else else