mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-05 18:30:24 -08:00
Untabify everything.
This commit is contained in:
Zack Piper
parent
d5fd24d267
commit
00521d869a
27 changed files with 3621 additions and 3621 deletions
|
|
@ -35,7 +35,7 @@
|
|||
#:inflate-stream
|
||||
#:inflate-zlib-stream #:parse-zlib-header #:parse-zlib-footer
|
||||
#:inflate-gzip-stream #:parse-gzip-header #:parse-gzip-footer
|
||||
#:gunzip))
|
||||
#:gunzip))
|
||||
|
||||
(cl:in-package "DEFLATE")
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -68,14 +68,14 @@
|
|||
|
||||
(defun read-word (stream)
|
||||
(logior (read-byte stream)
|
||||
(ash (read-byte stream) 8)
|
||||
(ash (read-byte stream) 16)
|
||||
(ash (read-byte stream) 24)))
|
||||
(ash (read-byte stream) 8)
|
||||
(ash (read-byte stream) 16)
|
||||
(ash (read-byte stream) 24)))
|
||||
|
||||
(defun write-word (byte stream)
|
||||
(declare (type (unsigned-byte 32) byte)
|
||||
(stream stream)
|
||||
(optimize speed (safety 0)))
|
||||
(stream stream)
|
||||
(optimize speed (safety 0)))
|
||||
(write-byte (logand #xff byte) stream)
|
||||
(write-byte (logand #xff (ash byte -8)) stream)
|
||||
(write-byte (logand #xff (ash byte -16)) stream)
|
||||
|
|
@ -91,35 +91,35 @@
|
|||
(loop with h of-type (unsigned-integer 32) = 5381
|
||||
for byte of-type (unsigned-byte 8) across key-vector
|
||||
do (setf h (logxor (logand #xffffffff
|
||||
(+ (ash (logand #.(ash #xffffffff -5) h)
|
||||
5)
|
||||
h))
|
||||
byte))
|
||||
(+ (ash (logand #.(ash #xffffffff -5) h)
|
||||
5)
|
||||
h))
|
||||
byte))
|
||||
finally (return h)))
|
||||
|
||||
(defun %make-cdb (cdb-pathname temporary-pathname)
|
||||
(let ((stream (open temporary-pathname
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create
|
||||
:element-type '(unsigned-byte 8))))
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create
|
||||
:element-type '(unsigned-byte 8))))
|
||||
(if stream
|
||||
(progn
|
||||
(file-position stream 0)
|
||||
(dotimes (i (* 256 2))
|
||||
(write-word 0 stream))
|
||||
(make-cdb :stream stream
|
||||
:pathname cdb-pathname
|
||||
:tables (make-array 256 :initial-element nil)
|
||||
:temporary-pathname temporary-pathname))
|
||||
(error "Unable to create CDB at filename ~A" temporary-pathname))))
|
||||
(progn
|
||||
(file-position stream 0)
|
||||
(dotimes (i (* 256 2))
|
||||
(write-word 0 stream))
|
||||
(make-cdb :stream stream
|
||||
:pathname cdb-pathname
|
||||
:tables (make-array 256 :initial-element nil)
|
||||
:temporary-pathname temporary-pathname))
|
||||
(error "Unable to create CDB at filename ~A" temporary-pathname))))
|
||||
|
||||
(defmacro with-output-to-cdb ((cdb cdb-pathname temporary-pathname) &body body)
|
||||
`(let (,cdb)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf ,cdb (%make-cdb ,cdb-pathname ,temporary-pathname))
|
||||
,@body)
|
||||
(progn
|
||||
(setf ,cdb (%make-cdb ,cdb-pathname ,temporary-pathname))
|
||||
,@body)
|
||||
(close-cdb ,cdb))))
|
||||
|
||||
(defun add-record (key value cdb)
|
||||
|
|
@ -127,10 +127,10 @@
|
|||
;; reference in the CDB structure itself. This reference will be
|
||||
;; used to create the hash.
|
||||
(let* ((hash-key (to-cdb-hash key))
|
||||
(table-index (logand #xff hash-key))
|
||||
(stream (cdb-stream cdb)))
|
||||
(table-index (logand #xff hash-key))
|
||||
(stream (cdb-stream cdb)))
|
||||
(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 value) stream)
|
||||
(write-sequence key stream)
|
||||
|
|
@ -144,26 +144,26 @@
|
|||
;; Here we use a factor 2.
|
||||
(loop with length = (* 2 (length table))
|
||||
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 index = (mod (ash hash-key -8) length)
|
||||
do (loop for disp from 0 below length
|
||||
for i = (* 2 (mod (+ disp index) length))
|
||||
for record-pos = (aref vector (1+ i))
|
||||
until (zerop record-pos)
|
||||
finally (setf (aref vector i) hash-key (aref vector (1+ i)) pos))
|
||||
for i = (* 2 (mod (+ disp index) length))
|
||||
for record-pos = (aref vector (1+ i))
|
||||
until (zerop record-pos)
|
||||
finally (setf (aref vector i) hash-key (aref vector (1+ i)) pos))
|
||||
finally (progn (write-vector vector stream)
|
||||
(return length))))
|
||||
(return length))))
|
||||
|
||||
(defun dump-cdb (cdb)
|
||||
;; After we have dumped all the records in the file, we append the
|
||||
;; hash tables and recreate the index table at the beginning.
|
||||
(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)
|
||||
for i of-type fixnum from 0 by 2
|
||||
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)
|
||||
(write-vector index stream)))
|
||||
|
||||
|
|
@ -173,8 +173,8 @@
|
|||
(dump-cdb cdb)
|
||||
(close stream)
|
||||
(when (cdb-pathname cdb)
|
||||
(rename-file (cdb-temporary-pathname cdb)
|
||||
(cdb-pathname cdb))))))
|
||||
(rename-file (cdb-temporary-pathname cdb)
|
||||
(cdb-pathname cdb))))))
|
||||
|
||||
(defun cdb-error (stream)
|
||||
(error "Error when reading CDB database ~A" stream))
|
||||
|
|
@ -185,82 +185,82 @@
|
|||
(let ((key-length (read-word stream)))
|
||||
(when (= key-length (length key-vector))
|
||||
(let* ((value-length (read-word stream))
|
||||
(other-key (make-array key-length :element-type '(unsigned-byte 8))))
|
||||
(read-sequence other-key stream)
|
||||
(when (equalp other-key key-vector)
|
||||
(if return-position-p
|
||||
(file-position stream)
|
||||
(let ((value (make-array value-length :element-type '(unsigned-byte 8))))
|
||||
(read-sequence value stream)
|
||||
value)
|
||||
))))))
|
||||
(other-key (make-array key-length :element-type '(unsigned-byte 8))))
|
||||
(read-sequence other-key stream)
|
||||
(when (equalp other-key key-vector)
|
||||
(if return-position-p
|
||||
(file-position stream)
|
||||
(let ((value (make-array value-length :element-type '(unsigned-byte 8))))
|
||||
(read-sequence value stream)
|
||||
value)
|
||||
))))))
|
||||
|
||||
(defun lookup-cdb (key stream &optional return-position-p)
|
||||
(if (streamp stream)
|
||||
(let* ((hash (to-cdb-hash key))
|
||||
(table (logand #xFF hash)))
|
||||
(unless (file-position stream (* table 8))
|
||||
(cdb-error stream))
|
||||
(let* ((start (read-word stream))
|
||||
(length (read-word stream))
|
||||
(index (mod (ash hash -8) length)))
|
||||
(loop for reset = t
|
||||
for i from 0 below length
|
||||
for rounded-i = (mod (+ index i) length)
|
||||
for position = (+ start (* 8 rounded-i))
|
||||
do (progn
|
||||
(when reset
|
||||
(unless (file-position stream position)
|
||||
(cdb-error stream))
|
||||
(setf reset nil))
|
||||
(let* ((other-hash (read-word stream))
|
||||
(record-position (read-word stream)))
|
||||
(when (zerop record-position)
|
||||
(return nil))
|
||||
(when (= other-hash hash)
|
||||
(let ((output (values-coincide record-position key stream
|
||||
return-position-p)))
|
||||
(if output
|
||||
(return output)
|
||||
(setf reset t)))))))))
|
||||
(table (logand #xFF hash)))
|
||||
(unless (file-position stream (* table 8))
|
||||
(cdb-error stream))
|
||||
(let* ((start (read-word stream))
|
||||
(length (read-word stream))
|
||||
(index (mod (ash hash -8) length)))
|
||||
(loop for reset = t
|
||||
for i from 0 below length
|
||||
for rounded-i = (mod (+ index i) length)
|
||||
for position = (+ start (* 8 rounded-i))
|
||||
do (progn
|
||||
(when reset
|
||||
(unless (file-position stream position)
|
||||
(cdb-error stream))
|
||||
(setf reset nil))
|
||||
(let* ((other-hash (read-word stream))
|
||||
(record-position (read-word stream)))
|
||||
(when (zerop record-position)
|
||||
(return nil))
|
||||
(when (= other-hash hash)
|
||||
(let ((output (values-coincide record-position key stream
|
||||
return-position-p)))
|
||||
(if output
|
||||
(return output)
|
||||
(setf reset t)))))))))
|
||||
(with-open-file (s stream :direction :input
|
||||
:element-type '(unsigned-byte 8))
|
||||
(lookup-cdb key s return-position-p))))
|
||||
:element-type '(unsigned-byte 8))
|
||||
(lookup-cdb key s return-position-p))))
|
||||
|
||||
(defun map-cdb (function stream)
|
||||
(if (streamp stream)
|
||||
(let* ((index (make-array (* 256 2) :element-type '(unsigned-byte 32))))
|
||||
(unless (file-position stream 0)
|
||||
(cdb-error stream))
|
||||
(unless (= (read-sequence index stream) (length index))
|
||||
(cdb-error stream))
|
||||
(loop for i from 0 by 2 below (length index)
|
||||
for table-position = (aref index i)
|
||||
for table-length = (aref index (1+ i))
|
||||
do (progn
|
||||
(unless (file-position stream table-position)
|
||||
(cdb-error stream))
|
||||
(loop for i from 0 below table-length
|
||||
for position from table-position by 8
|
||||
for record-hash = (read-word stream)
|
||||
for record-position = (read-word stream)
|
||||
unless (zerop record-position)
|
||||
do (progn
|
||||
(unless (file-position stream record-position)
|
||||
(cdb-error stream))
|
||||
(let* ((key-length (read-word stream))
|
||||
(value-length (read-word stream))
|
||||
(key (make-array key-length
|
||||
:element-type '(unsigned-byte 8)))
|
||||
(value (make-array value-length
|
||||
:element-type '(unsigned-byte 8))))
|
||||
(unless (and (= (read-sequence key stream)
|
||||
key-length)
|
||||
(= (read-sequence value stream)
|
||||
value-length))
|
||||
(cdb-error stream))
|
||||
(funcall function key value)))))))
|
||||
(unless (file-position stream 0)
|
||||
(cdb-error stream))
|
||||
(unless (= (read-sequence index stream) (length index))
|
||||
(cdb-error stream))
|
||||
(loop for i from 0 by 2 below (length index)
|
||||
for table-position = (aref index i)
|
||||
for table-length = (aref index (1+ i))
|
||||
do (progn
|
||||
(unless (file-position stream table-position)
|
||||
(cdb-error stream))
|
||||
(loop for i from 0 below table-length
|
||||
for position from table-position by 8
|
||||
for record-hash = (read-word stream)
|
||||
for record-position = (read-word stream)
|
||||
unless (zerop record-position)
|
||||
do (progn
|
||||
(unless (file-position stream record-position)
|
||||
(cdb-error stream))
|
||||
(let* ((key-length (read-word stream))
|
||||
(value-length (read-word stream))
|
||||
(key (make-array key-length
|
||||
:element-type '(unsigned-byte 8)))
|
||||
(value (make-array value-length
|
||||
:element-type '(unsigned-byte 8))))
|
||||
(unless (and (= (read-sequence key stream)
|
||||
key-length)
|
||||
(= (read-sequence value stream)
|
||||
value-length))
|
||||
(cdb-error stream))
|
||||
(funcall function key value)))))))
|
||||
(with-open-file (s stream :direction :input :element-type '(unsigned-byte 8))
|
||||
(map-cdb function s))))
|
||||
(map-cdb function s))))
|
||||
|
||||
(provide :ecl-cdb)
|
||||
|
|
|
|||
|
|
@ -14,25 +14,25 @@
|
|||
|
||||
(defun to-cdb-vector (object)
|
||||
(let* ((vector (make-array 128 :adjustable t
|
||||
:fill-pointer 0
|
||||
:element-type '(unsigned-byte 8)
|
||||
:initial-element 0))
|
||||
(stream (ext:make-sequence-output-stream
|
||||
vector :external-format #+unicode :utf-8 #-unicode :default)))
|
||||
:fill-pointer 0
|
||||
:element-type '(unsigned-byte 8)
|
||||
:initial-element 0))
|
||||
(stream (ext:make-sequence-output-stream
|
||||
vector :external-format #+unicode :utf-8 #-unicode :default)))
|
||||
(with-standard-io-syntax
|
||||
(let ((si::*print-package* (find-package "CL")))
|
||||
(write object :stream stream :pretty nil
|
||||
:readably nil :escape t)))
|
||||
(write object :stream stream :pretty nil
|
||||
:readably nil :escape t)))
|
||||
vector))
|
||||
|
||||
(defun from-cdb-vector (vector)
|
||||
(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)))
|
||||
|
||||
(defun search-help-file (string path)
|
||||
(let* ((key (to-cdb-vector string))
|
||||
(value (ecl-cdb:lookup-cdb key path)))
|
||||
(value (ecl-cdb:lookup-cdb key path)))
|
||||
(when value
|
||||
(from-cdb-vector value))))
|
||||
|
||||
|
|
@ -43,8 +43,8 @@
|
|||
(loop for k being the hash-key of hash-table
|
||||
using (hash-value v)
|
||||
do (ecl-cdb:add-record (to-cdb-vector k)
|
||||
(to-cdb-vector v)
|
||||
cdb)))
|
||||
(to-cdb-vector v)
|
||||
cdb)))
|
||||
;; Testing the consistency of the output
|
||||
(when test
|
||||
(loop for k being the hash-key of hash-table
|
||||
|
|
|
|||
|
|
@ -59,9 +59,9 @@
|
|||
(defpackage #:ecl-curl
|
||||
(:use #:sb-bsd-sockets #:cl)
|
||||
(:export #:download-url-to-file
|
||||
#:download-error
|
||||
#:download-url
|
||||
#:download-response))
|
||||
#:download-error
|
||||
#:download-url
|
||||
#:download-response))
|
||||
|
||||
(in-package "ECL-CURL")
|
||||
|
||||
|
|
@ -176,9 +176,9 @@
|
|||
(if *proxy*
|
||||
url
|
||||
(let ((path-start (position #\/ url :start 7)))
|
||||
(if path-start
|
||||
(subseq url path-start)
|
||||
"/index.html"))))
|
||||
(if path-start
|
||||
(subseq url path-start)
|
||||
"/index.html"))))
|
||||
|
||||
;;;---------------------------------------------------------------------------
|
||||
;;; CONNECTION & HEADRE
|
||||
|
|
@ -240,10 +240,10 @@
|
|||
(let ((length (parse-integer (or (header-value :content-length headers) "")
|
||||
:junk-allowed t)))
|
||||
(unless quiet
|
||||
(format t "~&;;; Downloading ~A bytes from ~A to ~A ...~%"
|
||||
(or length "some unknown number of")
|
||||
url
|
||||
file-name))
|
||||
(format t "~&;;; Downloading ~A bytes from ~A to ~A ...~%"
|
||||
(or length "some unknown number of")
|
||||
url
|
||||
file-name))
|
||||
(force-output)
|
||||
(let ((ok? nil) (o nil))
|
||||
(unwind-protect
|
||||
|
|
@ -251,8 +251,8 @@
|
|||
(setf o (open file-name
|
||||
:direction :output :if-exists :supersede
|
||||
:external-format
|
||||
#-unicode :default
|
||||
#+unicode :latin-1))
|
||||
#-unicode :default
|
||||
#+unicode :latin-1))
|
||||
(if length
|
||||
(let ((buf (make-array length
|
||||
:element-type
|
||||
|
|
|
|||
|
|
@ -21,13 +21,13 @@
|
|||
(make-pathname :name name :type "BIN"
|
||||
:defaults "build:encodings;"))
|
||||
do (progn
|
||||
(unless (probe-file orig)
|
||||
(unless (probe-file orig)
|
||||
(error "Missing mapping")
|
||||
(let ((mapping (if (equalp name "JISX0208")
|
||||
(mapcar #'rest (read-mapping name 3))
|
||||
(read-mapping name))))
|
||||
(dump-mapping-array mapping orig)))
|
||||
(copy-encoding-file orig copy)))
|
||||
(let ((mapping (if (equalp name "JISX0208")
|
||||
(mapcar #'rest (read-mapping name 3))
|
||||
(read-mapping name))))
|
||||
(dump-mapping-array mapping orig)))
|
||||
(copy-encoding-file orig copy)))
|
||||
|
||||
(defconstant +aliases+
|
||||
'((:us-ascii ext::ascii)
|
||||
|
|
@ -88,17 +88,17 @@
|
|||
|
||||
(loop for (name . aliases) in +aliases+
|
||||
do (loop with *package* = (find-package "CL")
|
||||
for alias in aliases
|
||||
for filename0 = (make-pathname :name (symbol-name alias)
|
||||
for alias in aliases
|
||||
for filename0 = (make-pathname :name (symbol-name alias)
|
||||
:defaults "build:encodings;")
|
||||
for filename = (ensure-directories-exist filename0)
|
||||
do (with-open-file (out filename :direction :output :if-exists :supersede
|
||||
:if-does-not-exist :create :element-type 'base-char)
|
||||
(format t "~%;;; Creating alias ~A -> ~A, ~A" alias name filename)
|
||||
(if (keywordp name)
|
||||
(format out "(defparameter ~S '~S)" alias name)
|
||||
(format out "(defparameter ~S (ext::make-encoding '~S))" alias name))
|
||||
)))
|
||||
for filename = (ensure-directories-exist filename0)
|
||||
do (with-open-file (out filename :direction :output :if-exists :supersede
|
||||
:if-does-not-exist :create :element-type 'base-char)
|
||||
(format t "~%;;; Creating alias ~A -> ~A, ~A" alias name filename)
|
||||
(if (keywordp name)
|
||||
(format out "(defparameter ~S '~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 (merge-pathnames "ISO-2022-JP" +encodings-root+)
|
||||
|
|
|
|||
|
|
@ -13,10 +13,10 @@
|
|||
|
||||
(defconstant +source-pathname+
|
||||
(make-pathname :name nil :type nil
|
||||
:directory (append (pathname-directory *load-pathname*)
|
||||
(list "sources"))
|
||||
:host (pathname-host *load-pathname*)
|
||||
:device (pathname-device *load-pathname*)))
|
||||
:directory (append (pathname-directory *load-pathname*)
|
||||
(list "sources"))
|
||||
:host (pathname-host *load-pathname*)
|
||||
:device (pathname-device *load-pathname*)))
|
||||
|
||||
(defconstant +all-mappings+
|
||||
'(("ATARIST" "http://unicode.org/Public/MAPPINGS/VENDORS/MISC/ATARIST.TXT")
|
||||
|
|
@ -100,67 +100,67 @@
|
|||
(unless (probe-file filename)
|
||||
(let ((command (format nil "curl \"~A\" > ~A" url filename)))
|
||||
(unless (zerop (si::system command))
|
||||
(error "Unable to retrieve file ~A" url)))))
|
||||
(error "Unable to retrieve file ~A" url)))))
|
||||
|
||||
(defun reformat (line)
|
||||
(loop with l = (length line)
|
||||
for i from 0 below l
|
||||
for c = (char line i)
|
||||
do (cond ((eql c #\#)
|
||||
(return (if (zerop i) "" (subseq line 0 (1- i)))))
|
||||
((not (standard-char-p c))
|
||||
(setf (char line i) #\space))
|
||||
((and (eql c #\0)
|
||||
(let ((j (1+ i)))
|
||||
(and (< j l) (member (char line j) '(#\x #\X)))))
|
||||
(setf (char line i) #\#)))
|
||||
(return (if (zerop i) "" (subseq line 0 (1- i)))))
|
||||
((not (standard-char-p c))
|
||||
(setf (char line i) #\space))
|
||||
((and (eql c #\0)
|
||||
(let ((j (1+ i)))
|
||||
(and (< j l) (member (char line j) '(#\x #\X)))))
|
||||
(setf (char line i) #\#)))
|
||||
finally (return line)))
|
||||
|
||||
(defun read-mapping (name &optional (n 2))
|
||||
(let* ((source-file (make-pathname :name name :defaults +source-pathname+))
|
||||
(record (find name +all-mappings+ :key #'first :test #'equalp))
|
||||
(fixes (third record))
|
||||
(source-url (fourth record)))
|
||||
(record (find name +all-mappings+ :key #'first :test #'equalp))
|
||||
(fixes (third record))
|
||||
(source-url (fourth record)))
|
||||
(unless (probe-file source-file)
|
||||
(unless source-url
|
||||
(error "Unknown encoding ~A" name))
|
||||
(error "Unknown encoding ~A" name))
|
||||
(download file source-url))
|
||||
(with-open-file (in source-file :direction :input)
|
||||
(loop with output = '()
|
||||
for line = (reformat (read-line in nil nil))
|
||||
while line
|
||||
unless (zerop (length line))
|
||||
do (with-input-from-string (aux line)
|
||||
(let ((byte-list (loop for byte = (read aux nil nil)
|
||||
while byte
|
||||
collect byte)))
|
||||
(unless (/= (length byte-list) n)
|
||||
(loop for i in fixes
|
||||
when (= (first i) (first byte-list))
|
||||
do (progn (setf byte-list i) (return)))
|
||||
(push byte-list output))))
|
||||
finally (return (nreverse output))))))
|
||||
for line = (reformat (read-line in nil nil))
|
||||
while line
|
||||
unless (zerop (length line))
|
||||
do (with-input-from-string (aux line)
|
||||
(let ((byte-list (loop for byte = (read aux nil nil)
|
||||
while byte
|
||||
collect byte)))
|
||||
(unless (/= (length byte-list) n)
|
||||
(loop for i in fixes
|
||||
when (= (first i) (first byte-list))
|
||||
do (progn (setf byte-list i) (return)))
|
||||
(push byte-list output))))
|
||||
finally (return (nreverse output))))))
|
||||
|
||||
(defun mapping-hash-table (mapping)
|
||||
(loop with hash = (make-hash-table :size (floor (* 1.5 (length mapping)))
|
||||
:test 'eq)
|
||||
:test 'eq)
|
||||
for (multibyte codepoint) in mapping
|
||||
for unicode-char = (code-char codepoint)
|
||||
do (progn
|
||||
(setf (gethash multibyte hash) unicode-char)
|
||||
(setf (gethash unicode-char hash) multibyte)
|
||||
(when (> multibyte #xFF)
|
||||
(setf (gethash (ash multibyte -8) hash) t)))
|
||||
(setf (gethash multibyte hash) unicode-char)
|
||||
(setf (gethash unicode-char hash) multibyte)
|
||||
(when (> multibyte #xFF)
|
||||
(setf (gethash (ash multibyte -8) hash) t)))
|
||||
finally (return hash)))
|
||||
|
||||
(defun dump-mapping-array (mapping-assoc output-file)
|
||||
(let* ((mapping-list (reduce #'nconc mapping-assoc))
|
||||
(mapping-array (make-array (length mapping-list) :element-type +sequence-type+
|
||||
:initial-contents mapping-list)))
|
||||
(mapping-array (make-array (length mapping-list) :element-type +sequence-type+
|
||||
:initial-contents mapping-list)))
|
||||
(format t "~%;;; Generating ~A" output-file)
|
||||
(force-output t)
|
||||
(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-sequence mapping-array s))))
|
||||
|
||||
|
|
@ -169,34 +169,34 @@
|
|||
(format t "~%;;; Copying ~A to ~A" in out)
|
||||
(with-open-file (sin in :direction :input :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)
|
||||
(loop for nbytes = (read-sequence buffer sin)
|
||||
until (zerop nbytes)
|
||||
do (write-sequence buffer sout :end nbytes))))))
|
||||
:if-exists :supersede :if-does-not-exist :create)
|
||||
(loop for nbytes = (read-sequence buffer sin)
|
||||
until (zerop nbytes)
|
||||
do (write-sequence buffer sout :end nbytes))))))
|
||||
|
||||
(defun all-valid-unicode-chars (mapping)
|
||||
(cond ((consp mapping)
|
||||
(loop for sublist on mapping
|
||||
for i from 0 below 10
|
||||
until (and (eq sublist mapping) (plusp i))
|
||||
collect (all-valid-unicode-chars (first sublist))))
|
||||
((hash-table-p mapping)
|
||||
(concatenate 'string (loop for key being the hash-key in mapping
|
||||
when (characterp key)
|
||||
collect key)))
|
||||
((eq mapping :iso-8859-1)
|
||||
(coerce 'string (loop for i from 0 to 255 collect (code-char i))))
|
||||
(t
|
||||
(error "Unknown encoding"))))
|
||||
(loop for sublist on mapping
|
||||
for i from 0 below 10
|
||||
until (and (eq sublist mapping) (plusp i))
|
||||
collect (all-valid-unicode-chars (first sublist))))
|
||||
((hash-table-p mapping)
|
||||
(concatenate 'string (loop for key being the hash-key in mapping
|
||||
when (characterp key)
|
||||
collect key)))
|
||||
((eq mapping :iso-8859-1)
|
||||
(coerce 'string (loop for i from 0 to 255 collect (code-char i))))
|
||||
(t
|
||||
(error "Unknown encoding"))))
|
||||
|
||||
(defun compare-hashes (h1 h2)
|
||||
(flet ((h1-in-h2 (h1 h2)
|
||||
(loop for k being the hash-key in h1 using (hash-value v)
|
||||
for v2 = (gethash k h2 nil)
|
||||
unless (or (consp v2) (consp v) (equal v v2))
|
||||
do (progn (print (list h1 k v h2 k v2))
|
||||
(error)
|
||||
(return nil))
|
||||
finally (return t))))
|
||||
(loop for k being the hash-key in h1 using (hash-value v)
|
||||
for v2 = (gethash k h2 nil)
|
||||
unless (or (consp v2) (consp v) (equal v v2))
|
||||
do (progn (print (list h1 k v h2 k v2))
|
||||
(error)
|
||||
(return nil))
|
||||
finally (return t))))
|
||||
(and (h1-in-h2 h1 h2)
|
||||
(h1-in-h2 h2 h1))))
|
||||
(h1-in-h2 h2 h1))))
|
||||
|
|
|
|||
|
|
@ -61,15 +61,15 @@ extern ECL_API size_t GC_get_total_bytes();
|
|||
|
||||
(let () ; This prevents compile-time evaluation of the following
|
||||
(defconstant +wrap+ (ffi:c-inline () () :object
|
||||
"ecl_make_unsigned_integer(~((size_t)0))"
|
||||
:one-liner t)))
|
||||
"ecl_make_unsigned_integer(~((size_t)0))"
|
||||
:one-liner t)))
|
||||
|
||||
(defun get-bytes-consed (orig)
|
||||
(let ((bytes (ffi:c-inline () () :object "ecl_make_unsigned_integer(GC_get_total_bytes())"
|
||||
:one-liner t)))
|
||||
:one-liner t)))
|
||||
(if (< bytes orig)
|
||||
(+ (- +wrap+ orig) bytes)
|
||||
(- bytes orig))))
|
||||
(+ (- +wrap+ orig) bytes)
|
||||
(- bytes orig))))
|
||||
|
||||
(deftype counter () '(integer 0 *))
|
||||
|
||||
|
|
@ -206,28 +206,28 @@ extern ECL_API size_t GC_get_total_bytes();
|
|||
(let ((dticks 0)
|
||||
(dconsing 0)
|
||||
(inner-enclosed-profiles 0)
|
||||
(old-enclosed-ticks *enclosed-ticks*)
|
||||
(old-enclosed-consing *enclosed-consing*)
|
||||
(old-enclosed-profiles *enclosed-profiles*)
|
||||
(start-ticks (get-internal-ticks))
|
||||
(start-consed (get-bytes-consed 0)))
|
||||
(old-enclosed-ticks *enclosed-ticks*)
|
||||
(old-enclosed-consing *enclosed-consing*)
|
||||
(old-enclosed-profiles *enclosed-profiles*)
|
||||
(start-ticks (get-internal-ticks))
|
||||
(start-consed (get-bytes-consed 0)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf *enclosed-ticks* 0
|
||||
*enclosed-profiles* 0
|
||||
*enclosed-consing* 0)
|
||||
(apply encapsulated-fun args))
|
||||
(setf dticks (- (get-internal-ticks) start-ticks))
|
||||
(setf dconsing (get-bytes-consed start-consed))
|
||||
(setf inner-enclosed-profiles *enclosed-profiles*)
|
||||
(let ((net-dticks (- dticks *enclosed-ticks*)))
|
||||
(incf ticks net-dticks))
|
||||
(let ((net-dconsing (- dconsing *enclosed-consing*)))
|
||||
(incf consing net-dconsing))
|
||||
(incf profiles inner-enclosed-profiles)
|
||||
(progn
|
||||
(setf *enclosed-ticks* 0
|
||||
*enclosed-profiles* 0
|
||||
*enclosed-consing* 0)
|
||||
(apply encapsulated-fun args))
|
||||
(setf dticks (- (get-internal-ticks) start-ticks))
|
||||
(setf dconsing (get-bytes-consed start-consed))
|
||||
(setf inner-enclosed-profiles *enclosed-profiles*)
|
||||
(let ((net-dticks (- dticks *enclosed-ticks*)))
|
||||
(incf ticks net-dticks))
|
||||
(let ((net-dconsing (- dconsing *enclosed-consing*)))
|
||||
(incf consing net-dconsing))
|
||||
(incf profiles inner-enclosed-profiles)
|
||||
(setf *enclosed-ticks* (+ old-enclosed-ticks dticks)
|
||||
*enclosed-consing* (+ old-enclosed-consing dconsing)
|
||||
*enclosed-profiles* (+ old-enclosed-profiles inner-enclosed-profiles 1)))))
|
||||
*enclosed-consing* (+ old-enclosed-consing dconsing)
|
||||
*enclosed-profiles* (+ old-enclosed-profiles inner-enclosed-profiles 1)))))
|
||||
;; READ-STATS-FUN
|
||||
(lambda ()
|
||||
(values count ticks consing profiles))
|
||||
|
|
|
|||
|
|
@ -36,29 +36,29 @@
|
|||
(ecl-curl:download-url-to-file *quicklisp-url* file)
|
||||
(load file)
|
||||
(eval (read-from-string
|
||||
(format nil "(quicklisp-quickstart:install :path ~S)"
|
||||
(namestring (truename target-directory))))
|
||||
)))
|
||||
(format nil "(quicklisp-quickstart:install :path ~S)"
|
||||
(namestring (truename target-directory))))
|
||||
)))
|
||||
|
||||
(handler-case
|
||||
(progn
|
||||
(unless (probe-file *quicklisp-setup*)
|
||||
(install-quicklisp *quicklisp-directory*))
|
||||
(install-quicklisp *quicklisp-directory*))
|
||||
(unless (find-package "QL")
|
||||
(load *quicklisp-setup*))
|
||||
(load *quicklisp-setup*))
|
||||
(eval (read-from-string "
|
||||
(pushnew #'(ext:lambda-block quicklisp-require (module)
|
||||
(let* ((module (string-downcase module)))
|
||||
(when (find module (ql:provided-systems t)
|
||||
:test #'string-equal
|
||||
:key #'ql-dist:name)
|
||||
(and (ql:quickload module)
|
||||
(let* ((module (string-downcase module)))
|
||||
(when (find module (ql:provided-systems t)
|
||||
:test #'string-equal
|
||||
:key #'ql-dist:name)
|
||||
(and (ql:quickload module)
|
||||
(provide module)))))
|
||||
sys::*module-provider-functions*)
|
||||
sys::*module-provider-functions*)
|
||||
")))
|
||||
(error (c)
|
||||
(format t "~%;;; Unable to load / install quicklisp. Error message follows:~%~A"
|
||||
c)))
|
||||
c)))
|
||||
|
||||
(provide "ecl-quicklisp")
|
||||
|
||||
|
|
|
|||
|
|
@ -175,19 +175,19 @@
|
|||
(setf maxfd fd))))
|
||||
|
||||
(multiple-value-bind (retval errno)
|
||||
(if (null seconds)
|
||||
;; No timeout
|
||||
(c-inline (rfd wfd (1+ maxfd))
|
||||
(:object :object :int) (values :int :int)
|
||||
"{ @(return 0) = select(#2, (fd_set*)#0->foreign.data,
|
||||
(if (null seconds)
|
||||
;; No timeout
|
||||
(c-inline (rfd wfd (1+ maxfd))
|
||||
(:object :object :int) (values :int :int)
|
||||
"{ @(return 0) = select(#2, (fd_set*)#0->foreign.data,
|
||||
(fd_set*)#1->foreign.data,
|
||||
NULL, NULL);
|
||||
@(return 1) = errno; }"
|
||||
:one-liner nil
|
||||
:side-effects t)
|
||||
(c-inline (rfd wfd (1+ maxfd) seconds)
|
||||
(:object :object :int :double) (values :int :int)
|
||||
"{ struct timeval tv;
|
||||
:one-liner nil
|
||||
:side-effects t)
|
||||
(c-inline (rfd wfd (1+ maxfd) seconds)
|
||||
(:object :object :int :double) (values :int :int)
|
||||
"{ struct timeval tv;
|
||||
double seconds = #3;
|
||||
tv.tv_sec = seconds;
|
||||
tv.tv_usec = (seconds * 1e6);
|
||||
|
|
@ -195,26 +195,26 @@
|
|||
(fd_set*)#1->foreign.data,
|
||||
NULL, &tv);
|
||||
@(return 1) = errno; }"
|
||||
:one-liner nil
|
||||
:side-effects t))
|
||||
:one-liner nil
|
||||
:side-effects t))
|
||||
|
||||
(cond ((zerop retval)
|
||||
nil)
|
||||
((minusp retval)
|
||||
(if (= errno +eintr+)
|
||||
;; suppress EINTR
|
||||
nil
|
||||
;; otherwise error
|
||||
(error "Error during select")))
|
||||
((plusp retval)
|
||||
(dolist (handler *descriptor-handlers*)
|
||||
(let ((fd (handler-descriptor handler)))
|
||||
(if (plusp (ecase (handler-direction handler)
|
||||
(:input (fd-isset fd rfd))
|
||||
(:output (fd-isset fd wfd))))
|
||||
(funcall (handler-function handler)
|
||||
(handler-descriptor handler)))))
|
||||
t)))))))
|
||||
(cond ((zerop retval)
|
||||
nil)
|
||||
((minusp retval)
|
||||
(if (= errno +eintr+)
|
||||
;; suppress EINTR
|
||||
nil
|
||||
;; otherwise error
|
||||
(error "Error during select")))
|
||||
((plusp retval)
|
||||
(dolist (handler *descriptor-handlers*)
|
||||
(let ((fd (handler-descriptor handler)))
|
||||
(if (plusp (ecase (handler-direction handler)
|
||||
(:input (fd-isset fd rfd))
|
||||
(:output (fd-isset fd wfd))))
|
||||
(funcall (handler-function handler)
|
||||
(handler-descriptor handler)))))
|
||||
t)))))))
|
||||
|
||||
|
||||
;;; Wait for up to timeout seconds for an event to happen. Make sure all
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
(defpackage "SB-BSD-SOCKETS"
|
||||
(:use "CL" "FFI" "SI")
|
||||
(:export "GET-HOST-BY-NAME" "GET-HOST-BY-ADDRESS"
|
||||
"SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT"
|
||||
"SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN"
|
||||
"SOCKET-RECEIVE" "SOCKET-CLOSE" "SOCKET-MAKE-STREAM"
|
||||
"GET-PROTOCOL-BY-NAME" "MAKE-INET-ADDRESS" "LOCAL-SOCKET"
|
||||
"SOCKET" "INET-SOCKET" "SOCKET-FILE-DESCRIPTOR" #+:win32 "NAMED-PIPE-SOCKET"
|
||||
"SOCKET-FAMILY" "SOCKET-PROTOCOL" "SOCKET-TYPE"
|
||||
"SOCKET-ERROR" "NAME-SERVICE-ERROR" "NON-BLOCKING-MODE"
|
||||
"HOST-ENT-NAME" "HOST-ENT-ALIASES" "HOST-ENT-ADDRESS-TYPE"
|
||||
"HOST-ENT-ADDRESSES" "HOST-ENT" "HOST-ENT-ADDRESS" "SOCKET-SEND"))
|
||||
"SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT"
|
||||
"SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN"
|
||||
"SOCKET-RECEIVE" "SOCKET-CLOSE" "SOCKET-MAKE-STREAM"
|
||||
"GET-PROTOCOL-BY-NAME" "MAKE-INET-ADDRESS" "LOCAL-SOCKET"
|
||||
"SOCKET" "INET-SOCKET" "SOCKET-FILE-DESCRIPTOR" #+:win32 "NAMED-PIPE-SOCKET"
|
||||
"SOCKET-FAMILY" "SOCKET-PROTOCOL" "SOCKET-TYPE"
|
||||
"SOCKET-ERROR" "NAME-SERVICE-ERROR" "NON-BLOCKING-MODE"
|
||||
"HOST-ENT-NAME" "HOST-ENT-ALIASES" "HOST-ENT-ADDRESS-TYPE"
|
||||
"HOST-ENT-ADDRESSES" "HOST-ENT" "HOST-ENT-ADDRESS" "SOCKET-SEND"))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -43,18 +43,18 @@
|
|||
;; 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
|
||||
(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)
|
||||
(declare (ignorable c)) t)
|
||||
(declare (ignorable c)) t)
|
||||
(:no-error nil))
|
||||
t)
|
||||
|
||||
(deftest make-inet-socket-keyword-wrong
|
||||
;; same again with keywords
|
||||
(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)
|
||||
(declare (ignorable c)) t)
|
||||
(declare (ignorable c)) t)
|
||||
(:no-error nil))
|
||||
t)
|
||||
|
||||
|
|
@ -83,9 +83,9 @@
|
|||
(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)
|
||||
(handler-case
|
||||
(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)
|
||||
nil)
|
||||
(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)
|
||||
nil)
|
||||
(address-in-use-error () t)))
|
||||
t)
|
||||
|
||||
|
|
@ -113,23 +113,23 @@
|
|||
;;; these require that the echo services are turned on in inetd
|
||||
(deftest simple-tcp-client
|
||||
(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)
|
||||
(let ((stream (socket-make-stream s :input t :output t :buffering :none)))
|
||||
(format stream "here is some text")
|
||||
(let ((data (subseq data 0 (read-buf-nonblock data stream))))
|
||||
(format t "~&Got ~S back from TCP echo server~%" data)
|
||||
(> (length data) 0))))
|
||||
(format stream "here is some text")
|
||||
(let ((data (subseq data 0 (read-buf-nonblock data stream))))
|
||||
(format t "~&Got ~S back from TCP echo server~%" data)
|
||||
(> (length data) 0))))
|
||||
t)
|
||||
|
||||
(deftest sockaddr-return-type
|
||||
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(socket-connect s #(127 0 0 1) 7)
|
||||
(multiple-value-bind (host port) (socket-peername s)
|
||||
(and (vectorp host)
|
||||
(numberp port))))
|
||||
(progn
|
||||
(socket-connect s #(127 0 0 1) 7)
|
||||
(multiple-value-bind (host port) (socket-peername s)
|
||||
(and (vectorp host)
|
||||
(numberp port))))
|
||||
(socket-close s)))
|
||||
t)
|
||||
|
||||
|
|
@ -142,8 +142,8 @@
|
|||
(format stream "here is some text")
|
||||
(finish-output stream)
|
||||
(let ((data (subseq data 0 (read-buf-nonblock data stream))))
|
||||
(format t "~&Got ~S back from UDP echo server~%" data)
|
||||
(> (length data) 0))))
|
||||
(format t "~&Got ~S back from UDP echo server~%" data)
|
||||
(> (length data) 0))))
|
||||
t)
|
||||
|
||||
;;; 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
|
||||
;; device.
|
||||
(when (and (probe-file "/dev/log")
|
||||
#-ecl
|
||||
(sb-posix:s-issock
|
||||
(sb-posix::stat-mode (sb-posix:stat "/dev/log"))))
|
||||
(let ((s (make-instance 'local-socket :type :datagram)))
|
||||
(format t "Connecting ~A... " s)
|
||||
(finish-output)
|
||||
(handler-case
|
||||
(socket-connect s "/dev/log")
|
||||
(socket-error ()
|
||||
(setq s (make-instance 'local-socket :type :stream))
|
||||
(format t "failed~%Retrying with ~A... " s)
|
||||
(finish-output)
|
||||
(socket-connect s "/dev/log")))
|
||||
(format t "ok.~%")
|
||||
(let ((stream (socket-make-stream s :input t :output t :buffering :none)))
|
||||
(format stream
|
||||
"<7>sb-bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored"))))
|
||||
#-ecl
|
||||
(sb-posix:s-issock
|
||||
(sb-posix::stat-mode (sb-posix:stat "/dev/log"))))
|
||||
(let ((s (make-instance 'local-socket :type :datagram)))
|
||||
(format t "Connecting ~A... " s)
|
||||
(finish-output)
|
||||
(handler-case
|
||||
(socket-connect s "/dev/log")
|
||||
(socket-error ()
|
||||
(setq s (make-instance 'local-socket :type :stream))
|
||||
(format t "failed~%Retrying with ~A... " s)
|
||||
(finish-output)
|
||||
(socket-connect s "/dev/log")))
|
||||
(format t "ok.~%")
|
||||
(let ((stream (socket-make-stream s :input t :output t :buffering :none)))
|
||||
(format stream
|
||||
"<7>sb-bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored"))))
|
||||
t)
|
||||
t)
|
||||
|
||||
|
|
@ -207,13 +207,13 @@
|
|||
|
||||
(deftest simple-http-client-1
|
||||
(handler-case
|
||||
(let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
|
||||
(let ((data (make-string 200)))
|
||||
(setf data (subseq data 0
|
||||
(read-buf-nonblock data
|
||||
(socket-make-stream s))))
|
||||
(princ data)
|
||||
(> (length data) 0)))
|
||||
(let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
|
||||
(let ((data (make-string 200)))
|
||||
(setf data (subseq data 0
|
||||
(read-buf-nonblock data
|
||||
(socket-make-stream s))))
|
||||
(princ data)
|
||||
(> (length data) 0)))
|
||||
(network-unreachable-error () 'network-unreachable))
|
||||
t)
|
||||
|
||||
|
|
@ -223,14 +223,14 @@
|
|||
;; kernel: we set a size of x and then getsockopt() returns 2x.
|
||||
;; This is why we compare with >= instead of =
|
||||
(handler-case
|
||||
(let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
|
||||
(setf (sockopt-receive-buffer s) 1975)
|
||||
(let ((data (make-string 200)))
|
||||
(setf data (subseq data 0
|
||||
(read-buf-nonblock data
|
||||
(socket-make-stream s))))
|
||||
(and (> (length data) 0)
|
||||
(>= (sockopt-receive-buffer s) 1975))))
|
||||
(let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
|
||||
(setf (sockopt-receive-buffer s) 1975)
|
||||
(let ((data (make-string 200)))
|
||||
(setf data (subseq data 0
|
||||
(read-buf-nonblock data
|
||||
(socket-make-stream s))))
|
||||
(and (> (length data) 0)
|
||||
(>= (sockopt-receive-buffer s) 1975))))
|
||||
(network-unreachable-error () 'network-unreachable))
|
||||
t)
|
||||
|
||||
|
|
@ -253,4 +253,4 @@
|
|||
(loop
|
||||
(multiple-value-bind (buf len address port) (socket-receive s nil 500)
|
||||
(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)))))))
|
||||
|
|
|
|||
|
|
@ -6,23 +6,23 @@
|
|||
for c across text
|
||||
when (member c set)
|
||||
do (setf output (list* (make-array (+ (- i start) (if exclude 0 1))
|
||||
:element-type elt-type
|
||||
:displaced-to text
|
||||
:displaced-index-offset start)
|
||||
output)
|
||||
start (1+ i))
|
||||
:element-type elt-type
|
||||
:displaced-to text
|
||||
:displaced-index-offset start)
|
||||
output)
|
||||
start (1+ i))
|
||||
finally (return (nreverse (list* (make-array (- i start)
|
||||
:element-type elt-type
|
||||
:displaced-to text
|
||||
:displaced-index-offset start)
|
||||
output)))))
|
||||
:element-type elt-type
|
||||
:displaced-to text
|
||||
:displaced-index-offset start)
|
||||
output)))))
|
||||
|
||||
(defun encode-words (words hash)
|
||||
(loop for word in words
|
||||
collect (or (gethash word hash)
|
||||
(let* ((word (copy-seq word))
|
||||
(ndx (hash-table-count hash)))
|
||||
(setf (gethash word hash) (1+ ndx))))))
|
||||
(let* ((word (copy-seq word))
|
||||
(ndx (hash-table-count hash)))
|
||||
(setf (gethash word hash) (1+ ndx))))))
|
||||
|
||||
(defun fixup-hangul-syllables (dictionary)
|
||||
;; "Hangul Syllable Composition, Unicode 5.1 section 3-12"
|
||||
|
|
@ -47,11 +47,11 @@
|
|||
for v = (+ vbase (floor (mod sindex ncount) tcount))
|
||||
for tee = (+ tbase (mod sindex tcount))
|
||||
for name = (list* "HANGUL_" "SYLLABLE_"
|
||||
(gethash l table) (gethash v table)
|
||||
(unless (= tee tbase) (list (gethash tee table))))
|
||||
(gethash l table) (gethash v table)
|
||||
(unless (= tee tbase) (list (gethash tee table))))
|
||||
for code = (+ sbase sindex)
|
||||
collect (list* code (apply #'concatenate 'string name)
|
||||
(encode-words name dictionary)))))
|
||||
(encode-words name dictionary)))))
|
||||
|
||||
(defun add-jamo-information (line table)
|
||||
(let* ((split (split-words line :set '(#\;) :exclude t))
|
||||
|
|
@ -68,17 +68,17 @@
|
|||
for ucd-line = (read-line in nil nil nil)
|
||||
while ucd-line
|
||||
nconc (let* ((ucd-data (split-words ucd-line :set '(#\;)))
|
||||
(code (first ucd-data))
|
||||
(name (second ucd-data)))
|
||||
(unless (eql (char name 0) #\<)
|
||||
(setf name (substitute #\_ #\Space name))
|
||||
(list (list* (parse-integer code :radix 16)
|
||||
name
|
||||
(encode-words (split-words
|
||||
name
|
||||
:set '(#\Space #\_ #\-)
|
||||
:exclude nil)
|
||||
words))))))))
|
||||
(code (first ucd-data))
|
||||
(name (second ucd-data)))
|
||||
(unless (eql (char name 0) #\<)
|
||||
(setf name (substitute #\_ #\Space name))
|
||||
(list (list* (parse-integer code :radix 16)
|
||||
name
|
||||
(encode-words (split-words
|
||||
name
|
||||
:set '(#\Space #\_ #\-)
|
||||
:exclude nil)
|
||||
words))))))))
|
||||
|
||||
(print (length *data*))
|
||||
(print (first (last *data*)))
|
||||
|
|
@ -86,9 +86,9 @@
|
|||
;#+(or)
|
||||
(progn
|
||||
(setf *data*
|
||||
(sort (nconc (fixup-hangul-syllables *words*) *data*)
|
||||
#'<
|
||||
:key #'car))
|
||||
(sort (nconc (fixup-hangul-syllables *words*) *data*)
|
||||
#'<
|
||||
:key #'car))
|
||||
(print (length *data*))
|
||||
(print (first (last *data*))))
|
||||
|
||||
|
|
@ -117,7 +117,7 @@
|
|||
with last = start
|
||||
for (code name . rest) in *data*
|
||||
do (when (>= (- code last) 2)
|
||||
(setf output (cons (list start last) output)
|
||||
start code))
|
||||
(setf output (cons (list start last) output)
|
||||
start code))
|
||||
(setf last code)
|
||||
finally (return (nreverse (cons (list start code) output)))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(defparameter *destination*
|
||||
(merge-pathnames "../../src/c/unicode/"
|
||||
(or *load-truename* *compile-pathname*)))
|
||||
(or *load-truename* *compile-pathname*)))
|
||||
|
||||
(let* ((translated-data (copy-tree *compressed-data*))
|
||||
(pairs (copy-tree *paired-data*))
|
||||
|
|
@ -14,39 +14,39 @@
|
|||
for line in translated-data
|
||||
for pair-code = (third line)
|
||||
do (cond ((/= (length line) 3)
|
||||
(error "Error in compressed data: too long code ~A" line))
|
||||
((or (aref used-code pair-code)
|
||||
(< pair-code first-code))
|
||||
(let ((new-pair (cons pair-code 0)))
|
||||
(setf pairs (acons (incf last-code) new-pair pairs)
|
||||
(third line) last-code)))
|
||||
(t
|
||||
(setf (aref used-code pair-code) t))))
|
||||
(error "Error in compressed data: too long code ~A" line))
|
||||
((or (aref used-code pair-code)
|
||||
(< pair-code first-code))
|
||||
(let ((new-pair (cons pair-code 0)))
|
||||
(setf pairs (acons (incf last-code) new-pair pairs)
|
||||
(third line) last-code)))
|
||||
(t
|
||||
(setf (aref used-code pair-code) t))))
|
||||
;;
|
||||
;; We now renumber all pairs.
|
||||
;;
|
||||
(let ((translation-table (make-array (1+ last-code) :initial-element nil))
|
||||
(counter -1))
|
||||
(counter -1))
|
||||
(flet ((add-code (code)
|
||||
(or (aref translation-table code)
|
||||
(setf (aref translation-table code) (incf counter))))
|
||||
(translate (old-code)
|
||||
(or (aref translation-table old-code)
|
||||
(error "Unknown code ~A" old-code))))
|
||||
(or (aref translation-table code)
|
||||
(setf (aref translation-table code) (incf counter))))
|
||||
(translate (old-code)
|
||||
(or (aref translation-table old-code)
|
||||
(error "Unknown code ~A" old-code))))
|
||||
;; First of all we add the words
|
||||
(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
|
||||
;; are consecutive, too.
|
||||
(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
|
||||
(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
|
||||
(loop for (code . pair) in pairs
|
||||
do (setf (car pair) (translate (car pair))
|
||||
(cdr pair) (translate (cdr pair))))))
|
||||
do (setf (car pair) (translate (car pair))
|
||||
(cdr pair) (translate (cdr pair))))))
|
||||
(defparameter *sorted-compressed-data* translated-data)
|
||||
(defparameter *sorted-pairs* (sort pairs #'< :key #'car))
|
||||
(print 'finished)
|
||||
|
|
@ -62,24 +62,24 @@
|
|||
for line in *sorted-compressed-data*
|
||||
for (ucd-code name code) = line
|
||||
do (cond ((/= code n)
|
||||
(error "Codes in *sorted-compressed-data* are not consecutive:~%~A"
|
||||
(cons line (subseq aux 0 10))))
|
||||
((null start-ucd-code)
|
||||
(setf start-ucd-code ucd-code
|
||||
start-code code))
|
||||
((= last-ucd-code (1- ucd-code))
|
||||
)
|
||||
(t
|
||||
(push (list start-ucd-code last-ucd-code start-code)
|
||||
output)
|
||||
(setf start-ucd-code ucd-code
|
||||
start-code code)))
|
||||
(error "Codes in *sorted-compressed-data* are not consecutive:~%~A"
|
||||
(cons line (subseq aux 0 10))))
|
||||
((null start-ucd-code)
|
||||
(setf start-ucd-code ucd-code
|
||||
start-code code))
|
||||
((= last-ucd-code (1- ucd-code))
|
||||
)
|
||||
(t
|
||||
(push (list start-ucd-code last-ucd-code start-code)
|
||||
output)
|
||||
(setf start-ucd-code ucd-code
|
||||
start-code code)))
|
||||
(setf last-ucd-code ucd-code aux (cons line aux))
|
||||
finally (return (nreverse output))))
|
||||
|
||||
(with-open-file (s (merge-pathnames "ucd_names.h" *destination*)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
(format s "/*
|
||||
* UNICODE NAMES DATABASE
|
||||
*/
|
||||
|
|
@ -112,17 +112,17 @@ extern const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES];
|
|||
|
||||
#endif
|
||||
"
|
||||
(1+ *last-word-index*)
|
||||
(length *sorted-pairs*)
|
||||
(length *grouped-characters*)
|
||||
(loop for (code name . rest) in *compressed-data*
|
||||
maximize (length name))
|
||||
(length *compressed-data*)
|
||||
))
|
||||
(1+ *last-word-index*)
|
||||
(length *sorted-pairs*)
|
||||
(length *grouped-characters*)
|
||||
(loop for (code name . rest) in *compressed-data*
|
||||
maximize (length name))
|
||||
(length *compressed-data*)
|
||||
))
|
||||
|
||||
(with-open-file (s (merge-pathnames "ucd_names_pair.c" *destination*)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
(format s "/*
|
||||
* 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] = {
|
||||
"
|
||||
(length *sorted-pairs*) (length *sorted-pairs*))
|
||||
(length *sorted-pairs*) (length *sorted-pairs*))
|
||||
(loop for i from 0
|
||||
for (pair-code . (a . b)) in *sorted-pairs*
|
||||
do (format s "~A{~D, ~D, ~D, ~D}~%"
|
||||
(if (plusp i) "," "")
|
||||
(logand a #xff) (ash a -8)
|
||||
(logand b #xff) (ash b -8)
|
||||
))
|
||||
(if (plusp i) "," "")
|
||||
(logand a #xff) (ash a -8)
|
||||
(logand b #xff) (ash b -8)
|
||||
))
|
||||
(format s "};~%"))
|
||||
|
||||
(with-open-file (s (merge-pathnames "ucd_names_codes.c" *destination*)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
(format s "/*
|
||||
* 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 i from 0
|
||||
do (format s "~A{{~D, ~D}, {~D, ~D, ~D}}~%"
|
||||
(if (plusp i) "," "")
|
||||
(logand code #xff) (ash code -8)
|
||||
(logand ucd-code #xff) (logand (ash ucd-code -8) #xff)
|
||||
(logand (ash ucd-code -16) #xff)))
|
||||
(if (plusp i) "," "")
|
||||
(logand code #xff) (ash code -8)
|
||||
(logand ucd-code #xff) (logand (ash ucd-code -8) #xff)
|
||||
(logand (ash ucd-code -16) #xff)))
|
||||
(format s "};"))
|
||||
|
||||
(with-open-file (s (merge-pathnames "ucd_names_str.c" *destination*)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
(format s "/*
|
||||
* Dictionary words.
|
||||
*/
|
||||
|
|
@ -182,8 +182,8 @@ const char *ecl_ucd_names_word[ECL_UCD_FIRST_PAIR] = {
|
|||
(format s "};~%"))
|
||||
|
||||
(with-open-file (s (merge-pathnames "ucd_names_char.c" *destination*)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
(format s "/*
|
||||
* 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] = {
|
||||
"
|
||||
(length *grouped-characters*))
|
||||
(length *grouped-characters*))
|
||||
(loop for i from 0
|
||||
for (start end pair-code) in *grouped-characters*
|
||||
do (format s "~A{~D,~D,~D}~%" (if (plusp i) "," "")
|
||||
start end pair-code))
|
||||
start end pair-code))
|
||||
(format s "};
|
||||
|
||||
static int
|
||||
|
|
@ -266,7 +266,7 @@ _ecl_ucd_name_to_code(cl_object name)
|
|||
ecl_character c = ecl_char_upcase(ecl_char(name, mid));
|
||||
buffer1[mid] = c;
|
||||
if (c < 32 || c > 127) /* All character names are [-A-Z_0-9]* */
|
||||
return ECL_NIL;
|
||||
return ECL_NIL;
|
||||
}
|
||||
buffer1[mid] = 0;
|
||||
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/"))
|
||||
|
|
|
|||
|
|
@ -10,32 +10,32 @@
|
|||
with max-pair = nil
|
||||
for (code name . l) in data
|
||||
do (loop for l2 on l
|
||||
for a = (car l2)
|
||||
for b = (cadr l2)
|
||||
while b
|
||||
do (let* ((pair (cons a b))
|
||||
(c (gethash pair table)))
|
||||
(setf (gethash pair table)
|
||||
(setf c (if c (1+ c) 1))
|
||||
a b)
|
||||
(when (> c max)
|
||||
(setf max c max-pair pair))))
|
||||
for a = (car l2)
|
||||
for b = (cadr l2)
|
||||
while b
|
||||
do (let* ((pair (cons a b))
|
||||
(c (gethash pair table)))
|
||||
(setf (gethash pair table)
|
||||
(setf c (if c (1+ c) 1))
|
||||
a b)
|
||||
(when (> c max)
|
||||
(setf max c max-pair pair))))
|
||||
finally (return (cons max max-pair))))
|
||||
|
||||
(defun replace-pair (pair code data)
|
||||
(let ((old-a (car pair))
|
||||
(old-b (cdr pair)))
|
||||
(old-b (cdr pair)))
|
||||
(loop with more = 0
|
||||
for (ucd-code name . l) in data
|
||||
do (loop with l2 = l
|
||||
for a = (first l2)
|
||||
for b = (second l2)
|
||||
while b
|
||||
do (when (and (eql a old-a) (eql b old-b))
|
||||
;; replace (a b . c) with (pair . c)
|
||||
(setf (car l2) code
|
||||
(cdr l2) (cddr l2)))
|
||||
do (setf l2 (cdr l2)))
|
||||
for a = (first l2)
|
||||
for b = (second l2)
|
||||
while b
|
||||
do (when (and (eql a old-a) (eql b old-b))
|
||||
;; replace (a b . c) with (pair . c)
|
||||
(setf (car l2) code
|
||||
(cdr l2) (cddr l2)))
|
||||
do (setf l2 (cdr l2)))
|
||||
do (setf more (+ more (1- (length l))))
|
||||
finally (return more))))
|
||||
|
||||
|
|
@ -48,21 +48,21 @@
|
|||
while (and pair (> frequency 1))
|
||||
do
|
||||
(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))
|
||||
finally
|
||||
;; There are no redundant pairs. We just define ad-hoc new
|
||||
;; symbols for all remaining strings.
|
||||
(loop with n = new-symbol
|
||||
for (code name . l) in data
|
||||
do (loop with l2 = l
|
||||
for a = (first l2)
|
||||
for b = (second l2)
|
||||
while b
|
||||
do (setf pairs (acons n (cons a b) pairs)
|
||||
(car l2) n
|
||||
(cdr l2) (cddr l2)
|
||||
n (1+ n))))
|
||||
for (code name . l) in data
|
||||
do (loop with l2 = l
|
||||
for a = (first l2)
|
||||
for b = (second l2)
|
||||
while b
|
||||
do (setf pairs (acons n (cons a b) pairs)
|
||||
(car l2) n
|
||||
(cdr l2) (cddr l2)
|
||||
n (1+ n))))
|
||||
(print 'finished)
|
||||
(return-from compress (nreverse pairs))))
|
||||
|
||||
|
|
@ -75,13 +75,13 @@
|
|||
(defparameter *code-ndx-size* (ceiling (integer-length *last-code*) 8))
|
||||
|
||||
(defparameter *pair-table-size* (* (length *paired-data*)
|
||||
(* 2 *code-ndx-size*)))
|
||||
(* 2 *code-ndx-size*)))
|
||||
|
||||
(defparameter *code-to-name-bytes*
|
||||
(* (length *compressed-data*)
|
||||
(+ 3 ; Size of Unicode code
|
||||
;; Size of index into the data table
|
||||
*code-ndx-size*)))
|
||||
;; Size of index into the data table
|
||||
*code-ndx-size*)))
|
||||
|
||||
(defparameter *sorted-names-bytes*
|
||||
;; The sorted list of character names is just a list of indices into
|
||||
|
|
@ -98,16 +98,16 @@
|
|||
;;; Names to codes table = ~D bytes
|
||||
;;; Total = ~D bytes
|
||||
"
|
||||
*word-dictionary*
|
||||
*pair-table-size*
|
||||
*code-to-name-bytes*
|
||||
*sorted-names-bytes*
|
||||
(+
|
||||
*word-dictionary*
|
||||
*pair-table-size*
|
||||
*code-to-name-bytes*
|
||||
*sorted-names-bytes*
|
||||
))
|
||||
*word-dictionary*
|
||||
*pair-table-size*
|
||||
*code-to-name-bytes*
|
||||
*sorted-names-bytes*
|
||||
(+
|
||||
*word-dictionary*
|
||||
*pair-table-size*
|
||||
*code-to-name-bytes*
|
||||
*sorted-names-bytes*
|
||||
))
|
||||
|
||||
;;; WITH HANGUL
|
||||
;;; Codes dictionary = 78566 bytes
|
||||
|
|
|
|||
|
|
@ -104,8 +104,8 @@
|
|||
(setq *decomposition-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*
|
||||
(make-pathname :name "UnicodeData" :type "txt"
|
||||
:defaults *extension-directory*)
|
||||
(make-pathname :name "UnicodeData" :type "txt"
|
||||
:defaults *extension-directory*)
|
||||
:direction :input :external-format :default)
|
||||
(loop for line = (read-line nil nil)
|
||||
while line
|
||||
|
|
@ -327,9 +327,9 @@
|
|||
:element-type '(unsigned-byte 8)
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(let ((offset (* (length *misc-table*) 8)))
|
||||
(write-byte (mod offset *page-size*) stream)
|
||||
(write-byte (floor offset *page-size*) stream))
|
||||
(let ((offset (* (length *misc-table*) 8)))
|
||||
(write-byte (mod offset *page-size*) stream)
|
||||
(write-byte (floor offset *page-size*) stream))
|
||||
(loop for (gc-index bidi-index ccc-index decimal-digit digit
|
||||
bidi-mirrored)
|
||||
across *misc-table*
|
||||
|
|
|
|||
|
|
@ -1,371 +1,371 @@
|
|||
(in-package "WIN32")
|
||||
|
||||
(defparameter *txtedit-lisp-kw*
|
||||
"* find-method pprint-indent
|
||||
** find-package pprint-linear
|
||||
*** find-restart pprint-logical-block
|
||||
+ find-symbol pprint-newline
|
||||
++ finish-output pprint-pop
|
||||
+++ first pprint-tab
|
||||
- fixnum pprint-tabular
|
||||
/ flet prin1
|
||||
// float prin1-to-string
|
||||
/// float-digits princ
|
||||
/= float-precision princ-to-string
|
||||
1+ float-radix print
|
||||
1- float-sign print-not-readable
|
||||
< floating-point-inexact print-not-readable-object
|
||||
<= floating-point-invalid-operation print-object
|
||||
= floating-point-overflow print-unreadable-object
|
||||
> floating-point-underflow probe-file
|
||||
>= floatp proclaim
|
||||
abort floor prog
|
||||
abs fmakunbound prog*
|
||||
access force-output prog1
|
||||
acons format prog2
|
||||
acos formatter progn
|
||||
acosh fourth program-error
|
||||
add-method fresh-line progv
|
||||
adjoin fround provide
|
||||
adjust-array ftruncate psetf
|
||||
adjustable-array-p ftype psetq
|
||||
allocate-instance funcall push
|
||||
alpha-char-p function pushnew
|
||||
alphanumericp function-keywords putprop
|
||||
and function-lambda-expression quote
|
||||
append functionp random
|
||||
apply gbitp random-state
|
||||
applyhook gcd random-state-p
|
||||
apropos generic-function rassoc
|
||||
apropos-list gensym rassoc-if
|
||||
aref gentemp rassoc-if-not
|
||||
arithmetic-error get ratio
|
||||
arithmetic-error-operands get-decoded-time rational
|
||||
arithmetic-error-operation get-dispatch-macro-character rationalize
|
||||
array get-internal-real-time rationalp
|
||||
array-dimension get-internal-run-time read
|
||||
array-dimension-limit get-macro-character read-byte
|
||||
array-dimensions get-output-stream-string read-char
|
||||
array-displacement get-properties read-char-no-hang
|
||||
array-element-type get-setf-expansion read-delimited-list
|
||||
array-has-fill-pointer-p get-setf-method read-eval-print
|
||||
array-in-bounds-p get-universal-time read-from-string
|
||||
array-rank getf read-line
|
||||
array-rank-limit gethash read-preserving-whitespace
|
||||
array-row-major-index go read-sequence
|
||||
array-total-size graphic-char-p reader-error
|
||||
array-total-size-limit handler-bind readtable
|
||||
arrayp handler-case readtable-case
|
||||
ash hash-table readtablep
|
||||
asin hash-table-count real
|
||||
asinh hash-table-p realp
|
||||
assert hash-table-rehash-size realpart
|
||||
assoc hash-table-rehash-threshold reduce
|
||||
assoc-if hash-table-size reinitialize-instance
|
||||
assoc-if-not hash-table-test rem
|
||||
atan host-namestring remf
|
||||
atanh identity remhash
|
||||
atom if remove
|
||||
base-char if-exists remove-duplicates
|
||||
base-string ignorable remove-if
|
||||
bignum ignore remove-if-not
|
||||
bit ignore-errors remove-method
|
||||
bit-and imagpart remprop
|
||||
bit-andc1 import rename-file
|
||||
bit-andc2 in-package rename-package
|
||||
bit-eqv in-package replace
|
||||
bit-ior incf require
|
||||
bit-nand initialize-instance rest
|
||||
bit-nor inline restart
|
||||
bit-not input-stream-p restart-bind
|
||||
bit-orc1 inspect restart-case
|
||||
bit-orc2 int-char restart-name
|
||||
bit-vector integer return
|
||||
bit-vector-p integer-decode-float return-from
|
||||
bit-xor integer-length revappend
|
||||
block integerp reverse
|
||||
boole interactive-stream-p room
|
||||
boole-1 intern rotatef
|
||||
boole-2 internal-time-units-per-second round
|
||||
boole-and intersection row-major-aref
|
||||
boole-andc1 invalid-method-error rplaca
|
||||
boole-andc2 invoke-debugger rplacd
|
||||
boole-c1 invoke-restart safety
|
||||
boole-c2 invoke-restart-interactively satisfies
|
||||
boole-clr isqrt sbit
|
||||
boole-eqv keyword scale-float
|
||||
boole-ior keywordp schar
|
||||
boole-nand labels search
|
||||
boole-nor lambda second
|
||||
boole-orc1 lambda-list-keywords sequence
|
||||
boole-orc2 lambda-parameters-limit serious-condition
|
||||
boole-set last set
|
||||
boole-xor lcm set-char-bit
|
||||
boolean ldb set-difference
|
||||
both-case-p ldb-test set-dispatch-macro-character
|
||||
boundp ldiff set-exclusive-or
|
||||
break least-negative-double-float set-macro-character
|
||||
broadcast-stream least-negative-long-float set-pprint-dispatch
|
||||
broadcast-stream-streams least-negative-normalized-double-float set-syntax-from-char
|
||||
built-in-class least-negative-normalized-long-float setf
|
||||
butlast least-negative-normalized-short-float setq
|
||||
byte least-negative-normalized-single-float seventh
|
||||
byte-position least-negative-short-float shadow
|
||||
byte-size least-negative-single-float shadowing-import
|
||||
call-arguments-limit least-positive-double-float shared-initialize
|
||||
call-method least-positive-long-float shiftf
|
||||
call-next-method least-positive-normalized-double-float short-float
|
||||
capitalize least-positive-normalized-long-float short-float-epsilon
|
||||
car least-positive-normalized-short-float short-float-negative-epsilon
|
||||
case least-positive-normalized-single-float short-site-name
|
||||
catch least-positive-short-float signal
|
||||
ccase least-positive-single-float signed-byte
|
||||
cdr length signum
|
||||
ceiling let simle-condition
|
||||
cell-error let* simple-array
|
||||
cell-error-name lisp simple-base-string
|
||||
cerror lisp-implementation-type simple-bit-vector
|
||||
change-class lisp-implementation-version simple-bit-vector-p
|
||||
char list simple-condition-format-arguments
|
||||
char-bit list* simple-condition-format-control
|
||||
char-bits list-all-packages simple-error
|
||||
char-bits-limit list-length simple-string
|
||||
char-code listen simple-string-p
|
||||
char-code-limit listp simple-type-error
|
||||
char-control-bit load simple-vector
|
||||
char-downcase load-logical-pathname-translations simple-vector-p
|
||||
char-equal load-time-value simple-warning
|
||||
char-font locally sin
|
||||
char-font-limit log single-flaot-epsilon
|
||||
char-greaterp logand single-float
|
||||
char-hyper-bit logandc1 single-float-epsilon
|
||||
char-int logandc2 single-float-negative-epsilon
|
||||
char-lessp logbitp sinh
|
||||
char-meta-bit logcount sixth
|
||||
char-name logeqv sleep
|
||||
char-not-equal logical-pathname slot-boundp
|
||||
char-not-greaterp logical-pathname-translations slot-exists-p
|
||||
char-not-lessp logior slot-makunbound
|
||||
char-super-bit lognand slot-missing
|
||||
char-upcase lognor slot-unbound
|
||||
char/= lognot slot-value
|
||||
char< logorc1 software-type
|
||||
char<= logorc2 software-version
|
||||
char= logtest some
|
||||
char> logxor sort
|
||||
char>= long-float space
|
||||
character long-float-epsilon special
|
||||
characterp long-float-negative-epsilon special-form-p
|
||||
check-type long-site-name special-operator-p
|
||||
cis loop speed
|
||||
class loop-finish sqrt
|
||||
class-name lower-case-p stable-sort
|
||||
class-of machine-instance standard
|
||||
clear-input machine-type standard-char
|
||||
clear-output machine-version standard-char-p
|
||||
close macro-function standard-class
|
||||
clrhash macroexpand standard-generic-function
|
||||
code-char macroexpand-1 standard-method
|
||||
coerce macroexpand-l standard-object
|
||||
commonp macrolet step
|
||||
compilation-speed make-array storage-condition
|
||||
compile make-array store-value
|
||||
compile-file make-broadcast-stream stream
|
||||
compile-file-pathname make-char stream-element-type
|
||||
compiled-function make-concatenated-stream stream-error
|
||||
compiled-function-p make-condition stream-error-stream
|
||||
compiler-let make-dispatch-macro-character stream-external-format
|
||||
compiler-macro make-echo-stream streamp
|
||||
compiler-macro-function make-hash-table streamup
|
||||
complement make-instance string
|
||||
complex make-instances-obsolete string-capitalize
|
||||
complexp make-list string-char
|
||||
compute-applicable-methods make-load-form string-char-p
|
||||
compute-restarts make-load-form-saving-slots string-downcase
|
||||
concatenate make-method string-equal
|
||||
concatenated-stream make-package string-greaterp
|
||||
concatenated-stream-streams make-pathname string-left-trim
|
||||
cond make-random-state string-lessp
|
||||
condition make-sequence string-not-equal
|
||||
conjugate make-string string-not-greaterp
|
||||
cons make-string-input-stream string-not-lessp
|
||||
consp make-string-output-stream string-right-strim
|
||||
constantly make-symbol string-right-trim
|
||||
constantp make-synonym-stream string-stream
|
||||
continue make-two-way-stream string-trim
|
||||
control-error makunbound string-upcase
|
||||
copy-alist map string/=
|
||||
copy-list map-into string<
|
||||
copy-pprint-dispatch mapc string<=
|
||||
copy-readtable mapcan string=
|
||||
copy-seq mapcar string>
|
||||
copy-structure mapcon string>=
|
||||
copy-symbol maphash stringp
|
||||
copy-tree mapl structure
|
||||
cos maplist structure-class
|
||||
cosh mask-field structure-object
|
||||
count max style-warning
|
||||
count-if member sublim
|
||||
count-if-not member-if sublis
|
||||
ctypecase member-if-not subseq
|
||||
debug merge subsetp
|
||||
decf merge-pathname subst
|
||||
declaim merge-pathnames subst-if
|
||||
declaration method subst-if-not
|
||||
declare method-combination substitute
|
||||
decode-float method-combination-error substitute-if
|
||||
decode-universal-time method-qualifiers substitute-if-not
|
||||
defclass min subtypep
|
||||
defconstant minusp svref
|
||||
defgeneric mismatch sxhash
|
||||
define-compiler-macro mod symbol
|
||||
define-condition most-negative-double-float symbol-function
|
||||
define-method-combination most-negative-fixnum symbol-macrolet
|
||||
define-modify-macro most-negative-long-float symbol-name
|
||||
define-setf-expander most-negative-short-float symbol-package
|
||||
define-setf-method most-negative-single-float symbol-plist
|
||||
define-symbol-macro most-positive-double-float symbol-value
|
||||
defmacro most-positive-fixnum symbolp
|
||||
defmethod most-positive-long-float synonym-stream
|
||||
defpackage most-positive-short-float synonym-stream-symbol
|
||||
defparameter most-positive-single-float sys
|
||||
defsetf muffle-warning system
|
||||
defstruct multiple-value-bind t
|
||||
deftype multiple-value-call tagbody
|
||||
defun multiple-value-list tailp
|
||||
defvar multiple-value-prog1 tan
|
||||
delete multiple-value-seteq tanh
|
||||
delete-duplicates multiple-value-setq tenth
|
||||
delete-file multiple-values-limit terpri
|
||||
delete-if name-char the
|
||||
delete-if-not namestring third
|
||||
delete-package nbutlast throw
|
||||
denominator nconc time
|
||||
deposit-field next-method-p trace
|
||||
describe nil translate-logical-pathname
|
||||
describe-object nintersection translate-pathname
|
||||
destructuring-bind ninth tree-equal
|
||||
digit-char no-applicable-method truename
|
||||
digit-char-p no-next-method truncase
|
||||
directory not truncate
|
||||
directory-namestring notany two-way-stream
|
||||
disassemble notevery two-way-stream-input-stream
|
||||
division-by-zero notinline two-way-stream-output-stream
|
||||
do nreconc type
|
||||
do* nreverse type-error
|
||||
do-all-symbols nset-difference type-error-datum
|
||||
do-exeternal-symbols nset-exclusive-or type-error-expected-type
|
||||
do-external-symbols nstring type-of
|
||||
do-symbols nstring-capitalize typecase
|
||||
documentation nstring-downcase typep
|
||||
dolist nstring-upcase unbound-slot
|
||||
dotimes nsublis unbound-slot-instance
|
||||
double-float nsubst unbound-variable
|
||||
double-float-epsilon nsubst-if undefined-function
|
||||
double-float-negative-epsilon nsubst-if-not unexport
|
||||
dpb nsubstitute unintern
|
||||
dribble nsubstitute-if union
|
||||
dynamic-extent nsubstitute-if-not unless
|
||||
ecase nth unread
|
||||
echo-stream nth-value unread-char
|
||||
echo-stream-input-stream nthcdr unsigned-byte
|
||||
echo-stream-output-stream null untrace
|
||||
ed number unuse-package
|
||||
eighth numberp unwind-protect
|
||||
elt numerator update-instance-for-different-class
|
||||
encode-universal-time nunion update-instance-for-redefined-class
|
||||
end-of-file oddp upgraded-array-element-type
|
||||
endp open upgraded-complex-part-type
|
||||
enough-namestring open-stream-p upper-case-p
|
||||
ensure-directories-exist optimize use-package
|
||||
ensure-generic-function or use-value
|
||||
eq otherwise user
|
||||
eql output-stream-p user-homedir-pathname
|
||||
equal package values
|
||||
equalp package-error values-list
|
||||
error package-error-package vector
|
||||
etypecase package-name vector-pop
|
||||
eval package-nicknames vector-push
|
||||
eval-when package-shadowing-symbols vector-push-extend
|
||||
evalhook package-use-list vectorp
|
||||
evenp package-used-by-list warn
|
||||
every packagep warning
|
||||
exp pairlis when
|
||||
export parse-error wild-pathname-p
|
||||
expt parse-integer with-accessors
|
||||
extended-char parse-namestring with-compilation-unit
|
||||
fboundp pathname with-condition-restarts
|
||||
fceiling pathname-device with-hash-table-iterator
|
||||
fdefinition pathname-directory with-input-from-string
|
||||
ffloor pathname-host with-open-file
|
||||
fifth pathname-match-p with-open-stream
|
||||
file-author pathname-name with-output-to-string
|
||||
file-error pathname-type with-package-iterator
|
||||
file-error-pathname pathname-version with-simple-restart
|
||||
file-length pathnamep with-slots
|
||||
file-namestring peek-char with-standard-io-syntax
|
||||
file-position phase write
|
||||
file-stream pi write-byte
|
||||
file-string-length plusp write-char
|
||||
file-write-date pop write-line
|
||||
fill position write-sequence
|
||||
fill-pointer position-if write-string
|
||||
find position-if-not write-to-string
|
||||
find-all-symbols pprint y-or-n-p
|
||||
find-class pprint-dispatch yes-or-no-p
|
||||
find-if pprint-exit-if-list-exhausted zerop
|
||||
find-if-not pprint-fill
|
||||
"* find-method pprint-indent
|
||||
** find-package pprint-linear
|
||||
*** find-restart pprint-logical-block
|
||||
+ find-symbol pprint-newline
|
||||
++ finish-output pprint-pop
|
||||
+++ first pprint-tab
|
||||
- fixnum pprint-tabular
|
||||
/ flet prin1
|
||||
// float prin1-to-string
|
||||
/// float-digits princ
|
||||
/= float-precision princ-to-string
|
||||
1+ float-radix print
|
||||
1- float-sign print-not-readable
|
||||
< floating-point-inexact print-not-readable-object
|
||||
<= floating-point-invalid-operation print-object
|
||||
= floating-point-overflow print-unreadable-object
|
||||
> floating-point-underflow probe-file
|
||||
>= floatp proclaim
|
||||
abort floor prog
|
||||
abs fmakunbound prog*
|
||||
access force-output prog1
|
||||
acons format prog2
|
||||
acos formatter progn
|
||||
acosh fourth program-error
|
||||
add-method fresh-line progv
|
||||
adjoin fround provide
|
||||
adjust-array ftruncate psetf
|
||||
adjustable-array-p ftype psetq
|
||||
allocate-instance funcall push
|
||||
alpha-char-p function pushnew
|
||||
alphanumericp function-keywords putprop
|
||||
and function-lambda-expression quote
|
||||
append functionp random
|
||||
apply gbitp random-state
|
||||
applyhook gcd random-state-p
|
||||
apropos generic-function rassoc
|
||||
apropos-list gensym rassoc-if
|
||||
aref gentemp rassoc-if-not
|
||||
arithmetic-error get ratio
|
||||
arithmetic-error-operands get-decoded-time rational
|
||||
arithmetic-error-operation get-dispatch-macro-character rationalize
|
||||
array get-internal-real-time rationalp
|
||||
array-dimension get-internal-run-time read
|
||||
array-dimension-limit get-macro-character read-byte
|
||||
array-dimensions get-output-stream-string read-char
|
||||
array-displacement get-properties read-char-no-hang
|
||||
array-element-type get-setf-expansion read-delimited-list
|
||||
array-has-fill-pointer-p get-setf-method read-eval-print
|
||||
array-in-bounds-p get-universal-time read-from-string
|
||||
array-rank getf read-line
|
||||
array-rank-limit gethash read-preserving-whitespace
|
||||
array-row-major-index go read-sequence
|
||||
array-total-size graphic-char-p reader-error
|
||||
array-total-size-limit handler-bind readtable
|
||||
arrayp handler-case readtable-case
|
||||
ash hash-table readtablep
|
||||
asin hash-table-count real
|
||||
asinh hash-table-p realp
|
||||
assert hash-table-rehash-size realpart
|
||||
assoc hash-table-rehash-threshold reduce
|
||||
assoc-if hash-table-size reinitialize-instance
|
||||
assoc-if-not hash-table-test rem
|
||||
atan host-namestring remf
|
||||
atanh identity remhash
|
||||
atom if remove
|
||||
base-char if-exists remove-duplicates
|
||||
base-string ignorable remove-if
|
||||
bignum ignore remove-if-not
|
||||
bit ignore-errors remove-method
|
||||
bit-and imagpart remprop
|
||||
bit-andc1 import rename-file
|
||||
bit-andc2 in-package rename-package
|
||||
bit-eqv in-package replace
|
||||
bit-ior incf require
|
||||
bit-nand initialize-instance rest
|
||||
bit-nor inline restart
|
||||
bit-not input-stream-p restart-bind
|
||||
bit-orc1 inspect restart-case
|
||||
bit-orc2 int-char restart-name
|
||||
bit-vector integer return
|
||||
bit-vector-p integer-decode-float return-from
|
||||
bit-xor integer-length revappend
|
||||
block integerp reverse
|
||||
boole interactive-stream-p room
|
||||
boole-1 intern rotatef
|
||||
boole-2 internal-time-units-per-second round
|
||||
boole-and intersection row-major-aref
|
||||
boole-andc1 invalid-method-error rplaca
|
||||
boole-andc2 invoke-debugger rplacd
|
||||
boole-c1 invoke-restart safety
|
||||
boole-c2 invoke-restart-interactively satisfies
|
||||
boole-clr isqrt sbit
|
||||
boole-eqv keyword scale-float
|
||||
boole-ior keywordp schar
|
||||
boole-nand labels search
|
||||
boole-nor lambda second
|
||||
boole-orc1 lambda-list-keywords sequence
|
||||
boole-orc2 lambda-parameters-limit serious-condition
|
||||
boole-set last set
|
||||
boole-xor lcm set-char-bit
|
||||
boolean ldb set-difference
|
||||
both-case-p ldb-test set-dispatch-macro-character
|
||||
boundp ldiff set-exclusive-or
|
||||
break least-negative-double-float set-macro-character
|
||||
broadcast-stream least-negative-long-float set-pprint-dispatch
|
||||
broadcast-stream-streams least-negative-normalized-double-float set-syntax-from-char
|
||||
built-in-class least-negative-normalized-long-float setf
|
||||
butlast least-negative-normalized-short-float setq
|
||||
byte least-negative-normalized-single-float seventh
|
||||
byte-position least-negative-short-float shadow
|
||||
byte-size least-negative-single-float shadowing-import
|
||||
call-arguments-limit least-positive-double-float shared-initialize
|
||||
call-method least-positive-long-float shiftf
|
||||
call-next-method least-positive-normalized-double-float short-float
|
||||
capitalize least-positive-normalized-long-float short-float-epsilon
|
||||
car least-positive-normalized-short-float short-float-negative-epsilon
|
||||
case least-positive-normalized-single-float short-site-name
|
||||
catch least-positive-short-float signal
|
||||
ccase least-positive-single-float signed-byte
|
||||
cdr length signum
|
||||
ceiling let simle-condition
|
||||
cell-error let* simple-array
|
||||
cell-error-name lisp simple-base-string
|
||||
cerror lisp-implementation-type simple-bit-vector
|
||||
change-class lisp-implementation-version simple-bit-vector-p
|
||||
char list simple-condition-format-arguments
|
||||
char-bit list* simple-condition-format-control
|
||||
char-bits list-all-packages simple-error
|
||||
char-bits-limit list-length simple-string
|
||||
char-code listen simple-string-p
|
||||
char-code-limit listp simple-type-error
|
||||
char-control-bit load simple-vector
|
||||
char-downcase load-logical-pathname-translations simple-vector-p
|
||||
char-equal load-time-value simple-warning
|
||||
char-font locally sin
|
||||
char-font-limit log single-flaot-epsilon
|
||||
char-greaterp logand single-float
|
||||
char-hyper-bit logandc1 single-float-epsilon
|
||||
char-int logandc2 single-float-negative-epsilon
|
||||
char-lessp logbitp sinh
|
||||
char-meta-bit logcount sixth
|
||||
char-name logeqv sleep
|
||||
char-not-equal logical-pathname slot-boundp
|
||||
char-not-greaterp logical-pathname-translations slot-exists-p
|
||||
char-not-lessp logior slot-makunbound
|
||||
char-super-bit lognand slot-missing
|
||||
char-upcase lognor slot-unbound
|
||||
char/= lognot slot-value
|
||||
char< logorc1 software-type
|
||||
char<= logorc2 software-version
|
||||
char= logtest some
|
||||
char> logxor sort
|
||||
char>= long-float space
|
||||
character long-float-epsilon special
|
||||
characterp long-float-negative-epsilon special-form-p
|
||||
check-type long-site-name special-operator-p
|
||||
cis loop speed
|
||||
class loop-finish sqrt
|
||||
class-name lower-case-p stable-sort
|
||||
class-of machine-instance standard
|
||||
clear-input machine-type standard-char
|
||||
clear-output machine-version standard-char-p
|
||||
close macro-function standard-class
|
||||
clrhash macroexpand standard-generic-function
|
||||
code-char macroexpand-1 standard-method
|
||||
coerce macroexpand-l standard-object
|
||||
commonp macrolet step
|
||||
compilation-speed make-array storage-condition
|
||||
compile make-array store-value
|
||||
compile-file make-broadcast-stream stream
|
||||
compile-file-pathname make-char stream-element-type
|
||||
compiled-function make-concatenated-stream stream-error
|
||||
compiled-function-p make-condition stream-error-stream
|
||||
compiler-let make-dispatch-macro-character stream-external-format
|
||||
compiler-macro make-echo-stream streamp
|
||||
compiler-macro-function make-hash-table streamup
|
||||
complement make-instance string
|
||||
complex make-instances-obsolete string-capitalize
|
||||
complexp make-list string-char
|
||||
compute-applicable-methods make-load-form string-char-p
|
||||
compute-restarts make-load-form-saving-slots string-downcase
|
||||
concatenate make-method string-equal
|
||||
concatenated-stream make-package string-greaterp
|
||||
concatenated-stream-streams make-pathname string-left-trim
|
||||
cond make-random-state string-lessp
|
||||
condition make-sequence string-not-equal
|
||||
conjugate make-string string-not-greaterp
|
||||
cons make-string-input-stream string-not-lessp
|
||||
consp make-string-output-stream string-right-strim
|
||||
constantly make-symbol string-right-trim
|
||||
constantp make-synonym-stream string-stream
|
||||
continue make-two-way-stream string-trim
|
||||
control-error makunbound string-upcase
|
||||
copy-alist map string/=
|
||||
copy-list map-into string<
|
||||
copy-pprint-dispatch mapc string<=
|
||||
copy-readtable mapcan string=
|
||||
copy-seq mapcar string>
|
||||
copy-structure mapcon string>=
|
||||
copy-symbol maphash stringp
|
||||
copy-tree mapl structure
|
||||
cos maplist structure-class
|
||||
cosh mask-field structure-object
|
||||
count max style-warning
|
||||
count-if member sublim
|
||||
count-if-not member-if sublis
|
||||
ctypecase member-if-not subseq
|
||||
debug merge subsetp
|
||||
decf merge-pathname subst
|
||||
declaim merge-pathnames subst-if
|
||||
declaration method subst-if-not
|
||||
declare method-combination substitute
|
||||
decode-float method-combination-error substitute-if
|
||||
decode-universal-time method-qualifiers substitute-if-not
|
||||
defclass min subtypep
|
||||
defconstant minusp svref
|
||||
defgeneric mismatch sxhash
|
||||
define-compiler-macro mod symbol
|
||||
define-condition most-negative-double-float symbol-function
|
||||
define-method-combination most-negative-fixnum symbol-macrolet
|
||||
define-modify-macro most-negative-long-float symbol-name
|
||||
define-setf-expander most-negative-short-float symbol-package
|
||||
define-setf-method most-negative-single-float symbol-plist
|
||||
define-symbol-macro most-positive-double-float symbol-value
|
||||
defmacro most-positive-fixnum symbolp
|
||||
defmethod most-positive-long-float synonym-stream
|
||||
defpackage most-positive-short-float synonym-stream-symbol
|
||||
defparameter most-positive-single-float sys
|
||||
defsetf muffle-warning system
|
||||
defstruct multiple-value-bind t
|
||||
deftype multiple-value-call tagbody
|
||||
defun multiple-value-list tailp
|
||||
defvar multiple-value-prog1 tan
|
||||
delete multiple-value-seteq tanh
|
||||
delete-duplicates multiple-value-setq tenth
|
||||
delete-file multiple-values-limit terpri
|
||||
delete-if name-char the
|
||||
delete-if-not namestring third
|
||||
delete-package nbutlast throw
|
||||
denominator nconc time
|
||||
deposit-field next-method-p trace
|
||||
describe nil translate-logical-pathname
|
||||
describe-object nintersection translate-pathname
|
||||
destructuring-bind ninth tree-equal
|
||||
digit-char no-applicable-method truename
|
||||
digit-char-p no-next-method truncase
|
||||
directory not truncate
|
||||
directory-namestring notany two-way-stream
|
||||
disassemble notevery two-way-stream-input-stream
|
||||
division-by-zero notinline two-way-stream-output-stream
|
||||
do nreconc type
|
||||
do* nreverse type-error
|
||||
do-all-symbols nset-difference type-error-datum
|
||||
do-exeternal-symbols nset-exclusive-or type-error-expected-type
|
||||
do-external-symbols nstring type-of
|
||||
do-symbols nstring-capitalize typecase
|
||||
documentation nstring-downcase typep
|
||||
dolist nstring-upcase unbound-slot
|
||||
dotimes nsublis unbound-slot-instance
|
||||
double-float nsubst unbound-variable
|
||||
double-float-epsilon nsubst-if undefined-function
|
||||
double-float-negative-epsilon nsubst-if-not unexport
|
||||
dpb nsubstitute unintern
|
||||
dribble nsubstitute-if union
|
||||
dynamic-extent nsubstitute-if-not unless
|
||||
ecase nth unread
|
||||
echo-stream nth-value unread-char
|
||||
echo-stream-input-stream nthcdr unsigned-byte
|
||||
echo-stream-output-stream null untrace
|
||||
ed number unuse-package
|
||||
eighth numberp unwind-protect
|
||||
elt numerator update-instance-for-different-class
|
||||
encode-universal-time nunion update-instance-for-redefined-class
|
||||
end-of-file oddp upgraded-array-element-type
|
||||
endp open upgraded-complex-part-type
|
||||
enough-namestring open-stream-p upper-case-p
|
||||
ensure-directories-exist optimize use-package
|
||||
ensure-generic-function or use-value
|
||||
eq otherwise user
|
||||
eql output-stream-p user-homedir-pathname
|
||||
equal package values
|
||||
equalp package-error values-list
|
||||
error package-error-package vector
|
||||
etypecase package-name vector-pop
|
||||
eval package-nicknames vector-push
|
||||
eval-when package-shadowing-symbols vector-push-extend
|
||||
evalhook package-use-list vectorp
|
||||
evenp package-used-by-list warn
|
||||
every packagep warning
|
||||
exp pairlis when
|
||||
export parse-error wild-pathname-p
|
||||
expt parse-integer with-accessors
|
||||
extended-char parse-namestring with-compilation-unit
|
||||
fboundp pathname with-condition-restarts
|
||||
fceiling pathname-device with-hash-table-iterator
|
||||
fdefinition pathname-directory with-input-from-string
|
||||
ffloor pathname-host with-open-file
|
||||
fifth pathname-match-p with-open-stream
|
||||
file-author pathname-name with-output-to-string
|
||||
file-error pathname-type with-package-iterator
|
||||
file-error-pathname pathname-version with-simple-restart
|
||||
file-length pathnamep with-slots
|
||||
file-namestring peek-char with-standard-io-syntax
|
||||
file-position phase write
|
||||
file-stream pi write-byte
|
||||
file-string-length plusp write-char
|
||||
file-write-date pop write-line
|
||||
fill position write-sequence
|
||||
fill-pointer position-if write-string
|
||||
find position-if-not write-to-string
|
||||
find-all-symbols pprint y-or-n-p
|
||||
find-class pprint-dispatch yes-or-no-p
|
||||
find-if pprint-exit-if-list-exhausted zerop
|
||||
find-if-not pprint-fill
|
||||
|
||||
caar cadr cdar cddr
|
||||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||
caar cadr cdar cddr
|
||||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||
|
||||
*applyhook* *load-pathname* *print-pprint-dispatch*
|
||||
*break-on-signals* *load-print* *print-pprint-dispatch*
|
||||
*break-on-signals* *load-truename* *print-pretty*
|
||||
*break-on-warnings* *load-verbose* *print-radix*
|
||||
*compile-file-pathname* *macroexpand-hook* *print-readably*
|
||||
*compile-file-pathname* *modules* *print-right-margin*
|
||||
*compile-file-truename* *package* *print-right-margin*
|
||||
*compile-file-truename* *print-array* *query-io*
|
||||
*compile-print* *print-base* *random-state*
|
||||
*compile-verbose* *print-case* *read-base*
|
||||
*compile-verbose* *print-circle* *read-default-float-format*
|
||||
*debug-io* *print-escape* *read-eval*
|
||||
*debugger-hook* *print-gensym* *read-suppress*
|
||||
*default-pathname-defaults* *print-length* *readtable*
|
||||
*error-output* *print-level* *standard-input*
|
||||
*evalhook* *print-lines* *standard-output*
|
||||
*features* *print-miser-width* *terminal-io*
|
||||
*gensym-counter* *print-miser-width* *trace-output*")
|
||||
*applyhook* *load-pathname* *print-pprint-dispatch*
|
||||
*break-on-signals* *load-print* *print-pprint-dispatch*
|
||||
*break-on-signals* *load-truename* *print-pretty*
|
||||
*break-on-warnings* *load-verbose* *print-radix*
|
||||
*compile-file-pathname* *macroexpand-hook* *print-readably*
|
||||
*compile-file-pathname* *modules* *print-right-margin*
|
||||
*compile-file-truename* *package* *print-right-margin*
|
||||
*compile-file-truename* *print-array* *query-io*
|
||||
*compile-print* *print-base* *random-state*
|
||||
*compile-verbose* *print-case* *read-base*
|
||||
*compile-verbose* *print-circle* *read-default-float-format*
|
||||
*debug-io* *print-escape* *read-eval*
|
||||
*debugger-hook* *print-gensym* *read-suppress*
|
||||
*default-pathname-defaults* *print-length* *readtable*
|
||||
*error-output* *print-level* *standard-input*
|
||||
*evalhook* *print-lines* *standard-output*
|
||||
*features* *print-miser-width* *terminal-io*
|
||||
*gensym-counter* *print-miser-width* *trace-output*")
|
||||
|
||||
(defparameter *txtedit-lisp-kw2*
|
||||
":abort :from-end :overwrite
|
||||
:adjustable :gensym :predicate
|
||||
:append :host :preserve-whitespace
|
||||
:array :if-does-not-exist :pretty
|
||||
:base :if-exists :print
|
||||
:case :include :print-function
|
||||
:circle :index :probe
|
||||
:conc-name :inherited :radix
|
||||
:constructor :initial-contents :read-only
|
||||
:copier :initial-element :rehash-size
|
||||
:count :initial-offset :rehash-threshold
|
||||
:create :initial-value :rename
|
||||
:default :input :rename-and-delete
|
||||
:defaults :internal :size
|
||||
:device :io :start
|
||||
:direction :junk-allowed :start1
|
||||
:directory :key :start2
|
||||
:displaced-index-offset :length :stream
|
||||
:displaced-to :level :supersede
|
||||
:element-type :name :test
|
||||
:end :named :test-not
|
||||
:end1 :new-version :type
|
||||
:end2 :nicknames :use
|
||||
:error :output :verbose
|
||||
:escape :output-file :version
|
||||
:external :fill-pointer")
|
||||
":abort :from-end :overwrite
|
||||
:adjustable :gensym :predicate
|
||||
:append :host :preserve-whitespace
|
||||
:array :if-does-not-exist :pretty
|
||||
:base :if-exists :print
|
||||
:case :include :print-function
|
||||
:circle :index :probe
|
||||
:conc-name :inherited :radix
|
||||
:constructor :initial-contents :read-only
|
||||
:copier :initial-element :rehash-size
|
||||
:count :initial-offset :rehash-threshold
|
||||
:create :initial-value :rename
|
||||
:default :input :rename-and-delete
|
||||
:defaults :internal :size
|
||||
:device :io :start
|
||||
:direction :junk-allowed :start1
|
||||
:directory :key :start2
|
||||
:displaced-index-offset :length :stream
|
||||
:displaced-to :level :supersede
|
||||
:element-type :name :test
|
||||
:end :named :test-not
|
||||
:end1 :new-version :type
|
||||
:end2 :nicknames :use
|
||||
:error :output :verbose
|
||||
:escape :output-file :version
|
||||
:external :fill-pointer")
|
||||
|
||||
(defparameter *txtedit-decl-forms*
|
||||
'(defmacro defsetf deftype defun defmethod defgeneric lambda
|
||||
|
|
|
|||
|
|
@ -65,35 +65,35 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
(defun create-menus ()
|
||||
;(return *NULL*)
|
||||
(let ((bar (createmenu))
|
||||
(file_pop (createpopupmenu))
|
||||
(edit_pop (createpopupmenu))
|
||||
(win_pop (createpopupmenu))
|
||||
(help_pop (createpopupmenu)))
|
||||
(file_pop (createpopupmenu))
|
||||
(edit_pop (createpopupmenu))
|
||||
(win_pop (createpopupmenu))
|
||||
(help_pop (createpopupmenu)))
|
||||
;; File menu
|
||||
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "&File")
|
||||
(appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New Ctrl+N")
|
||||
(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_NEW+ "&New Ctrl+N")
|
||||
(appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open... Ctrl+O")
|
||||
(appendmenu file_pop *MF_STRING* +IDM_CLOSE+ "&Close Ctrl+W")
|
||||
(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_SEPARATOR* 0 "")
|
||||
(appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q")
|
||||
(appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q")
|
||||
;; Edit menu
|
||||
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "&Edit")
|
||||
(appendmenu 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_STRING* +IDM_CUT+ "&Cut Ctrl+X")
|
||||
(appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C")
|
||||
(appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V")
|
||||
(appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut Ctrl+X")
|
||||
(appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C")
|
||||
(appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V")
|
||||
(appendmenu edit_pop *MF_SEPARATOR* 0 "")
|
||||
(appendmenu edit_pop *MF_STRING* +IDM_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_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A")
|
||||
(appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A")
|
||||
;; Windows menu
|
||||
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam win_pop) "&Window")
|
||||
(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_NEXTWINDOW+ "&Next Ctrl+Right")
|
||||
(appendmenu win_pop *MF_STRING* +IDM_PREVWINDOW+ "&Previous Ctrl+Left")
|
||||
;; Help menu
|
||||
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam help_pop) "&Help")
|
||||
(appendmenu help_pop *MF_STRING* +IDM_ABOUT+ "&About...")
|
||||
|
|
@ -101,13 +101,13 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
|
||||
(defun create-accels ()
|
||||
(macrolet ((add-accel (key ID accTable pos)
|
||||
`(with-foreign-object (a 'ACCEL)
|
||||
(setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*))
|
||||
(setf (get-slot-value a 'ACCEL 'key) ,(if (characterp key) `(char-code ,key) key))
|
||||
(setf (get-slot-value a 'ACCEL 'cmd) ,ID)
|
||||
(setf (deref-array ,accTable '(* ACCEL) ,pos) a))))
|
||||
`(with-foreign-object (a 'ACCEL)
|
||||
(setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*))
|
||||
(setf (get-slot-value a 'ACCEL 'key) ,(if (characterp key) `(char-code ,key) key))
|
||||
(setf (get-slot-value a 'ACCEL 'cmd) ,ID)
|
||||
(setf (deref-array ,accTable '(* ACCEL) ,pos) a))))
|
||||
(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 #\N +IDM_NEW+ accTable 1)
|
||||
(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 #\F +IDM_FIND+ accTable 8)
|
||||
(when (= *txtedit-edit-class* 2)
|
||||
(add-accel #\D +IDM_MATCH_PAREN+ accTable 9))
|
||||
(add-accel #\D +IDM_MATCH_PAREN+ accTable 9))
|
||||
(prog1
|
||||
(createacceleratortable accTable accTableSize)
|
||||
(free-foreign-object accTable)))))
|
||||
(createacceleratortable accTable accTableSize)
|
||||
(free-foreign-object accTable)))))
|
||||
|
||||
(defun update-caption (hwnd)
|
||||
(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))
|
||||
(format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]"
|
||||
(and (txtedit-title editor) (funcall fun (txtedit-title editor)))
|
||||
(txtedit-dirty editor) final-char))
|
||||
(and (txtedit-title editor) (funcall fun (txtedit-title editor)))
|
||||
(txtedit-dirty editor) final-char))
|
||||
|
||||
(defun update-tab (idx)
|
||||
(let ((editor (nth idx *txtedit-edit*)))
|
||||
|
|
@ -146,37 +146,37 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
(defun set-current-editor (idx hwnd &optional force-p)
|
||||
(when (<= 0 idx (1- (length *txtedit-edit*)))
|
||||
(let ((old-ed (and *txtedit-current*
|
||||
(current-editor)))
|
||||
(new-ed (nth idx *txtedit-edit*)))
|
||||
(current-editor)))
|
||||
(new-ed (nth idx *txtedit-edit*)))
|
||||
(unless (and (null force-p)
|
||||
(eq old-ed new-ed))
|
||||
(setq *txtedit-current* idx)
|
||||
(setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*))
|
||||
(setfocus (txtedit-handle new-ed))
|
||||
(when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx)
|
||||
(sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0))
|
||||
(update-caption hwnd)))))
|
||||
(eq old-ed new-ed))
|
||||
(setq *txtedit-current* idx)
|
||||
(setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*))
|
||||
(setfocus (txtedit-handle new-ed))
|
||||
(when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx)
|
||||
(sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0))
|
||||
(update-caption hwnd)))))
|
||||
|
||||
(defun close-editor (idx hwnd)
|
||||
(let ((editor (nth idx *txtedit-edit*)))
|
||||
(if (or (null (txtedit-dirty editor))
|
||||
(and (set-current-editor idx hwnd) nil)
|
||||
(let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C"
|
||||
(txtedit-title editor) #\Null)
|
||||
"Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*))))
|
||||
(cond ((= m-result *IDNO*) t)
|
||||
((= m-result *IDCANCEL*) nil)
|
||||
((= m-result *IDYES*) (warn "Not implemented") nil))))
|
||||
(and (set-current-editor idx hwnd) nil)
|
||||
(let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C"
|
||||
(txtedit-title editor) #\Null)
|
||||
"Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*))))
|
||||
(cond ((= m-result *IDNO*) t)
|
||||
((= m-result *IDCANCEL*) nil)
|
||||
((= m-result *IDYES*) (warn "Not implemented") nil))))
|
||||
(progn
|
||||
(destroywindow (txtedit-handle editor))
|
||||
(sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0)
|
||||
(setq *txtedit-edit* (remove editor *txtedit-edit*))
|
||||
(when *txtedit-edit*
|
||||
(set-current-editor (min (1- (length *txtedit-edit*))
|
||||
(max *txtedit-current*
|
||||
0))
|
||||
hwnd t))
|
||||
t)
|
||||
(destroywindow (txtedit-handle editor))
|
||||
(sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0)
|
||||
(setq *txtedit-edit* (remove editor *txtedit-edit*))
|
||||
(when *txtedit-edit*
|
||||
(set-current-editor (min (1- (length *txtedit-edit*))
|
||||
(max *txtedit-current*
|
||||
0))
|
||||
hwnd t))
|
||||
t)
|
||||
nil)))
|
||||
|
||||
(ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int))
|
||||
|
|
@ -214,7 +214,7 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
(unless (boundp '*txtedit-lisp-kw*)
|
||||
(load "lisp-kw.lisp"))
|
||||
(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 1 (make-lparam kwList2)))
|
||||
;; Define margins
|
||||
|
|
@ -228,21 +228,21 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
(defun scintilla-indent-position (pos line hnd)
|
||||
(+ (sendmessage hnd 2127 line 0)
|
||||
(- pos
|
||||
(sendmessage hnd 2128 line 0))))
|
||||
(sendmessage hnd 2128 line 0))))
|
||||
|
||||
(defun scintilla-read-form (pos hnd)
|
||||
(read-from-string
|
||||
(with-output-to-string (s)
|
||||
(loop for k from pos
|
||||
with style = (sendmessage hnd 2010 pos 0)
|
||||
for ch = (code-char (sendmessage hnd 2007 k 0))
|
||||
for st = (sendmessage hnd 2010 k 0)
|
||||
if (and (= st style)
|
||||
(graphic-char-p ch)
|
||||
(not (eq ch #\Space)))
|
||||
do (write-char ch s)
|
||||
else
|
||||
return nil))
|
||||
with style = (sendmessage hnd 2010 pos 0)
|
||||
for ch = (code-char (sendmessage hnd 2007 k 0))
|
||||
for st = (sendmessage hnd 2010 k 0)
|
||||
if (and (= st style)
|
||||
(graphic-char-p ch)
|
||||
(not (eq ch #\Space)))
|
||||
do (write-char ch s)
|
||||
else
|
||||
return nil))
|
||||
nil nil))
|
||||
|
||||
(defun scintilla-declare-form-p (form)
|
||||
|
|
@ -250,73 +250,73 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
|
||||
(defun scintilla-compute-indentation (curPos curLine hnd)
|
||||
(loop for k from curPos downto 0
|
||||
for ch = (code-char (sendmessage hnd 2007 k 0))
|
||||
for st = (sendmessage hnd 2010 k 0)
|
||||
with depth = 0
|
||||
with lineIndent = 0
|
||||
with lastCharPos = nil
|
||||
with prevCharPos = nil
|
||||
when (= st 10)
|
||||
do (cond ((and (= depth 0) (eq ch #\())
|
||||
(if lastCharPos
|
||||
(let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0)))
|
||||
lastForm)
|
||||
(cond ((member lastChar (list #\( #\;))
|
||||
(return (scintilla-indent-position lastCharPos curLine hnd)))
|
||||
((and (setq lastForm (scintilla-read-form lastCharPos hnd))
|
||||
(scintilla-declare-form-p lastForm))
|
||||
(return (+ (scintilla-indent-position k curLine hnd) 2)))
|
||||
((and prevCharPos (not (eq prevCharPos lastCharPos)))
|
||||
(return (scintilla-indent-position prevCharPos curLine hnd)))
|
||||
(t
|
||||
(return (+ (scintilla-indent-position lastCharPos curLine hnd) 1)))))
|
||||
(progn
|
||||
(return (+ (scintilla-indent-position k curLine hnd) 1)))))
|
||||
((eq ch #\() (decf depth))
|
||||
((eq ch #\)) (incf depth)))
|
||||
if (and (graphic-char-p ch) (not (eq ch #\Space)))
|
||||
do (setq lastCharPos k)
|
||||
else
|
||||
do (setq prevCharPos lastCharPos)
|
||||
when (eq ch #\Newline)
|
||||
do (decf curLine) and
|
||||
do (case lineIndent
|
||||
(0 (incf lineIndent))
|
||||
(1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0)))))
|
||||
finally (return -1)))
|
||||
for ch = (code-char (sendmessage hnd 2007 k 0))
|
||||
for st = (sendmessage hnd 2010 k 0)
|
||||
with depth = 0
|
||||
with lineIndent = 0
|
||||
with lastCharPos = nil
|
||||
with prevCharPos = nil
|
||||
when (= st 10)
|
||||
do (cond ((and (= depth 0) (eq ch #\())
|
||||
(if lastCharPos
|
||||
(let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0)))
|
||||
lastForm)
|
||||
(cond ((member lastChar (list #\( #\;))
|
||||
(return (scintilla-indent-position lastCharPos curLine hnd)))
|
||||
((and (setq lastForm (scintilla-read-form lastCharPos hnd))
|
||||
(scintilla-declare-form-p lastForm))
|
||||
(return (+ (scintilla-indent-position k curLine hnd) 2)))
|
||||
((and prevCharPos (not (eq prevCharPos lastCharPos)))
|
||||
(return (scintilla-indent-position prevCharPos curLine hnd)))
|
||||
(t
|
||||
(return (+ (scintilla-indent-position lastCharPos curLine hnd) 1)))))
|
||||
(progn
|
||||
(return (+ (scintilla-indent-position k curLine hnd) 1)))))
|
||||
((eq ch #\() (decf depth))
|
||||
((eq ch #\)) (incf depth)))
|
||||
if (and (graphic-char-p ch) (not (eq ch #\Space)))
|
||||
do (setq lastCharPos k)
|
||||
else
|
||||
do (setq prevCharPos lastCharPos)
|
||||
when (eq ch #\Newline)
|
||||
do (decf curLine) and
|
||||
do (case lineIndent
|
||||
(0 (incf lineIndent))
|
||||
(1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0)))))
|
||||
finally (return -1)))
|
||||
|
||||
(defun scintilla-char-added (hnd ch)
|
||||
(cond ((eq ch #\Newline)
|
||||
(let* ((curPos (sendmessage hnd 2008 0 0))
|
||||
(curLine (sendmessage hnd 2166 curPos 0))
|
||||
(indent (scintilla-compute-indentation (1- curPos) curLine hnd)))
|
||||
(when (>= indent 0)
|
||||
(sendmessage hnd 2126 curLine indent)
|
||||
(sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0)
|
||||
)))
|
||||
;((eq ch #\()
|
||||
; (let ((curPos (1- (sendmessage hnd 2008 0 0))))
|
||||
; (when (scintilla-valid-brace-p curPos hnd)
|
||||
; (with-foreign-string (s ")")
|
||||
; (sendmessage hnd 2003 (1+ curPos) (make-lparam s))))))
|
||||
(t
|
||||
)))
|
||||
(let* ((curPos (sendmessage hnd 2008 0 0))
|
||||
(curLine (sendmessage hnd 2166 curPos 0))
|
||||
(indent (scintilla-compute-indentation (1- curPos) curLine hnd)))
|
||||
(when (>= indent 0)
|
||||
(sendmessage hnd 2126 curLine indent)
|
||||
(sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0)
|
||||
)))
|
||||
;((eq ch #\()
|
||||
; (let ((curPos (1- (sendmessage hnd 2008 0 0))))
|
||||
; (when (scintilla-valid-brace-p curPos hnd)
|
||||
; (with-foreign-string (s ")")
|
||||
; (sendmessage hnd 2003 (1+ curPos) (make-lparam s))))))
|
||||
(t
|
||||
)))
|
||||
|
||||
(defun scintilla-get-matching-braces (hnd &aux curPos)
|
||||
(when (>= (setq curPos (1- (sendmessage hnd 2008 0 0))) 0)
|
||||
(let ((ch (code-char (sendmessage hnd 2007 curPos 0))))
|
||||
(when (and (or (eq ch #\() (eq ch #\)))
|
||||
(= (sendmessage hnd 2010 curPos 0) 10))
|
||||
(let ((matchPos (sendmessage hnd 2353 curPos 0)))
|
||||
(return-from scintilla-get-matching-braces (values curPos matchPos))))))
|
||||
(= (sendmessage hnd 2010 curPos 0) 10))
|
||||
(let ((matchPos (sendmessage hnd 2353 curPos 0)))
|
||||
(return-from scintilla-get-matching-braces (values curPos matchPos))))))
|
||||
(values nil nil))
|
||||
|
||||
(defun scintilla-check-for-brace (hnd)
|
||||
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
|
||||
(if curPos
|
||||
(if (>= matchPos 0)
|
||||
(sendmessage hnd 2351 curPos matchPos)
|
||||
(sendmessage hnd 2352 curPos 0))
|
||||
(sendmessage hnd 2351 curPos matchPos)
|
||||
(sendmessage hnd 2352 curPos 0))
|
||||
(sendmessage hnd 2351 #xFFFFFFFF -1))))
|
||||
|
||||
(defun create-editor (parent &optional (set-current t))
|
||||
|
|
@ -324,38 +324,38 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
(getclientrect parent r)
|
||||
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
|
||||
(let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (txtedit-class-name) ""
|
||||
(logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS*
|
||||
*ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*)
|
||||
(get-slot-value r 'RECT 'left)
|
||||
(get-slot-value r 'RECT 'top)
|
||||
(- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
|
||||
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
|
||||
*txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*))))
|
||||
(logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS*
|
||||
*ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*)
|
||||
(get-slot-value r 'RECT 'left)
|
||||
(get-slot-value r 'RECT 'top)
|
||||
(- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
|
||||
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
|
||||
*txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*))))
|
||||
(sendmessage (txtedit-handle new-editor) *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0)
|
||||
(case *txtedit-edit-class*
|
||||
(1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*))
|
||||
(2 (init-scintilla-component (txtedit-handle new-editor))))
|
||||
(1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*))
|
||||
(2 (init-scintilla-component (txtedit-handle new-editor))))
|
||||
(with-foreign-object (tab 'TCITEM)
|
||||
(setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*)
|
||||
(setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor))
|
||||
(sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab)))
|
||||
(setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor))
|
||||
(sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab)))
|
||||
(setq *txtedit-edit* (append *txtedit-edit* (list new-editor)))
|
||||
(when set-current
|
||||
(set-current-editor (1- (length *txtedit-edit*)) parent))
|
||||
(set-current-editor (1- (length *txtedit-edit*)) parent))
|
||||
new-editor)))
|
||||
|
||||
(defun unix2dos (str)
|
||||
(let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0))
|
||||
(return-p nil)
|
||||
c)
|
||||
(return-p nil)
|
||||
c)
|
||||
(with-output-to-string (out new-str)
|
||||
(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))
|
||||
(#\Return (setq return-p t))
|
||||
(#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil))
|
||||
(t (setq return-p nil)))
|
||||
(write-char c out)))
|
||||
(#\Return (setq return-p t))
|
||||
(#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil))
|
||||
(t (setq return-p nil)))
|
||||
(write-char c out)))
|
||||
new-str))
|
||||
|
||||
(defun read-file (pn hwnd)
|
||||
|
|
@ -363,13 +363,13 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
(if pn
|
||||
(with-open-file (f pn)
|
||||
(let* ((len (file-length f))
|
||||
(buf (make-string len)))
|
||||
(read-sequence buf f)
|
||||
(setwindowtext (txtedit-handle (current-editor)) (unix2dos buf))
|
||||
(setf (txtedit-dirty (current-editor)) nil)
|
||||
(setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn)))
|
||||
(update-caption hwnd)
|
||||
(update-tab *txtedit-current*)))
|
||||
(buf (make-string len)))
|
||||
(read-sequence buf f)
|
||||
(setwindowtext (txtedit-handle (current-editor)) (unix2dos buf))
|
||||
(setf (txtedit-dirty (current-editor)) nil)
|
||||
(setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn)))
|
||||
(update-caption hwnd)
|
||||
(update-tab *txtedit-current*)))
|
||||
(messagebox hwnd "File does not exist." "Error" (logior *MB_OK* *MB_ICONERROR*))))
|
||||
|
||||
(defun save-file (pn hwnd)
|
||||
|
|
@ -390,224 +390,224 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
|
||||
(defun tab-proc (hwnd umsg wparam lparam)
|
||||
(cond ((or (= umsg *WM_COMMAND*)
|
||||
(= umsg *WM_NOTIFY*))
|
||||
(txtedit-proc (getparent hwnd) umsg wparam lparam))
|
||||
(t
|
||||
(callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam))))
|
||||
(= umsg *WM_NOTIFY*))
|
||||
(txtedit-proc (getparent hwnd) umsg wparam lparam))
|
||||
(t
|
||||
(callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam))))
|
||||
|
||||
(defvar *txtedit-level* 0)
|
||||
(defun txtedit-proc (hwnd umsg wparam lparam &aux (*txtedit-level* (1+ *txtedit-level*)))
|
||||
;(format t "txtedit-proc: ~D~%" *txtedit-level*)
|
||||
(cond ((= umsg *WM_DESTROY*)
|
||||
(postquitmessage 0)
|
||||
0)
|
||||
((= umsg *WM_CLOSE*)
|
||||
(if (do ((flag t))
|
||||
((not (and *txtedit-edit* flag)) flag)
|
||||
(setq flag (close-editor 0 hwnd)))
|
||||
(destroywindow hwnd)
|
||||
0))
|
||||
((= umsg *WM_CREATE*)
|
||||
(when (null-pointer-p (getmodulehandle "comctl32"))
|
||||
(initcommoncontrols))
|
||||
(setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* ""
|
||||
(logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0
|
||||
hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*))
|
||||
(setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc))
|
||||
(sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
|
||||
(create-editor hwnd)
|
||||
(with-cast-int-pointer (lparam CREATESTRUCT)
|
||||
(let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams)))
|
||||
(unless (null-pointer-p params)
|
||||
(read-file (convert-from-foreign-string params) hwnd))))
|
||||
0)
|
||||
((= umsg *WM_SIZE*)
|
||||
(unless (null-pointer-p *txtedit-tab*)
|
||||
(movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*)
|
||||
(with-foreign-object (r 'RECT)
|
||||
(setrect r 0 0 (loword lparam) (hiword lparam))
|
||||
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
|
||||
(dotimes (k (length *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 'right) (get-slot-value r 'RECT 'left))
|
||||
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
|
||||
(if (= k *txtedit-current*) *TRUE* *FALSE*)))))
|
||||
0)
|
||||
((= umsg *WM_SETFOCUS*)
|
||||
(unless (null-pointer-p (txtedit-handle (current-editor)))
|
||||
(setfocus (txtedit-handle (current-editor))))
|
||||
0)
|
||||
((= umsg *WM_NOTIFY*)
|
||||
(with-cast-int-pointer (lparam NMHDR)
|
||||
(let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom))
|
||||
(code (get-slot-value lparam 'NMHDR 'code))
|
||||
(hnd (get-slot-value lparam 'NMHDR 'hwndFrom)))
|
||||
(cond ((= ctrl-ID +TABCTL_ID+)
|
||||
(cond ((= code *TCN_SELCHANGE*)
|
||||
(set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd))
|
||||
(t
|
||||
)))
|
||||
((and (= *txtedit-edit-class* 2)
|
||||
(= code 2001))
|
||||
(with-cast-pointer (lparam SCNotification)
|
||||
(scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch)))))
|
||||
((and (= *txtedit-edit-class* 2)
|
||||
(= code 2007))
|
||||
(scintilla-check-for-brace hnd))
|
||||
(t
|
||||
))))
|
||||
0)
|
||||
((= umsg *WM_CONTEXTMENU*)
|
||||
(let ((hnd (make-handle wparam))
|
||||
(x (get-x-lparam lparam))
|
||||
(y (get-y-lparam lparam)))
|
||||
(cond ((equal hnd *txtedit-tab*)
|
||||
(with-foreign-objects ((ht 'TCHITTESTINFO)
|
||||
(pt 'POINT))
|
||||
(setf (get-slot-value pt 'POINT 'x) x)
|
||||
(setf (get-slot-value pt 'POINT 'y) y)
|
||||
(screentoclient *txtedit-tab* pt)
|
||||
(setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt)
|
||||
(let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht))))
|
||||
(when (>= tab 0)
|
||||
(let ((hMenu (createpopupmenu))
|
||||
menu-ID)
|
||||
(appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close")
|
||||
(when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0)
|
||||
(close-or-exit tab hwnd))
|
||||
(destroymenu hMenu))))))))
|
||||
0)
|
||||
((= umsg *WM_INITMENUPOPUP*)
|
||||
(case (loword lparam)
|
||||
(2 (let* ((wMenu (make-handle wparam))
|
||||
(nPos (loword lparam))
|
||||
(nItems (getmenuitemcount wMenu)))
|
||||
(dotimes (j (- nItems 2))
|
||||
(deletemenu wMenu 2 *MF_BYPOSITION*))
|
||||
(when *txtedit-edit*
|
||||
(appendmenu wMenu *MF_SEPARATOR* 0 "")
|
||||
(loop for e in *txtedit-edit*
|
||||
for k from 0
|
||||
do (progn
|
||||
(appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e))
|
||||
(when (= k *txtedit-current*)
|
||||
(checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*))))))
|
||||
(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*))
|
||||
))
|
||||
)
|
||||
0)
|
||||
((= umsg *WM_COMMAND*)
|
||||
(let ((ctrl-ID (loword wparam))
|
||||
(nmsg (hiword wparam))
|
||||
(hnd (make-pointer lparam 'HANDLE)))
|
||||
(cond ((= ctrl-ID +EDITCTL_ID+)
|
||||
(cond ((= nmsg *EN_CHANGE*)
|
||||
(unless (txtedit-dirty (current-editor))
|
||||
(setf (txtedit-dirty (current-editor)) t)
|
||||
(update-caption hwnd)
|
||||
(update-tab *txtedit-current*)))
|
||||
(t
|
||||
)))
|
||||
((= ctrl-ID +IDM_QUIT+)
|
||||
(sendmessage hwnd *WM_CLOSE* 0 0))
|
||||
((= ctrl-ID +IDM_OPEN+)
|
||||
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
|
||||
("All Files (*)" . "*")))))
|
||||
(when pn
|
||||
(create-editor hwnd)
|
||||
(read-file pn hwnd))))
|
||||
((and (= ctrl-ID +IDM_SAVE+)
|
||||
(txtedit-title (current-editor)))
|
||||
(save-file nil hwnd))
|
||||
((or (= ctrl-ID +IDM_SAVEAS+)
|
||||
(and (= ctrl-ID +IDM_SAVE+)
|
||||
(null (txtedit-title (current-editor)))))
|
||||
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
|
||||
("All Files (*)" . "*"))
|
||||
:dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*)))
|
||||
(when pn
|
||||
(save-file pn hwnd))))
|
||||
((= ctrl-ID +IDM_NEW+)
|
||||
(create-editor hwnd))
|
||||
((= ctrl-ID +IDM_CUT+)
|
||||
(sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0))
|
||||
((= ctrl-ID +IDM_COPY+)
|
||||
(sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0))
|
||||
((= ctrl-ID +IDM_PASTE+)
|
||||
(sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0))
|
||||
((= ctrl-ID +IDM_UNDO+)
|
||||
(unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0)
|
||||
(sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0)))
|
||||
((= ctrl-ID +IDM_SELECTALL+)
|
||||
(sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1))
|
||||
((= ctrl-ID +IDM_ABOUT+)
|
||||
(messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*)))
|
||||
((= ctrl-ID +IDM_NEXTWINDOW+)
|
||||
(unless (>= (1+ *txtedit-current*) (length *txtedit-edit*))
|
||||
(set-current-editor (1+ *txtedit-current*) hwnd)))
|
||||
((= ctrl-ID +IDM_PREVWINDOW+)
|
||||
(unless (= *txtedit-current* 0)
|
||||
(set-current-editor (1- *txtedit-current*) hwnd)))
|
||||
((= ctrl-ID +IDM_CLOSE+)
|
||||
(close-or-exit *txtedit-current* hwnd))
|
||||
((= ctrl-ID +IDM_MATCH_PAREN+)
|
||||
(let ((hnd (txtedit-handle (current-editor))))
|
||||
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
|
||||
(when (and curPos (>= matchPos 0))
|
||||
(sendmessage hnd 2025 (1+ matchPos) 0)))))
|
||||
((= ctrl-ID +IDM_FIND+)
|
||||
(let* ((fr (allocate-foreign-object 'FINDREPLACE))
|
||||
(str (make-string 1024 :initial-element #\Null)))
|
||||
(zeromemory fr (size-of-foreign-type 'FINDREPLACE))
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE))
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd)
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str)
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024)
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*)
|
||||
(setq *txtedit-dlg-handle* (findtext fr))))
|
||||
((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+)
|
||||
(set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd)
|
||||
0)
|
||||
(t
|
||||
)))
|
||||
0)
|
||||
((= uMsg (1+ *WM_USER*))
|
||||
(print "Open file request received")
|
||||
(let ((fname (pop *txtedit-files*)))
|
||||
(when fname
|
||||
(create-editor hwnd)
|
||||
(read-file fname hwnd)))
|
||||
0)
|
||||
((= uMsg *txtedit-findreplace-msg*)
|
||||
(with-cast-int-pointer (lparam FINDREPLACE)
|
||||
(let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags))
|
||||
(hnd (txtedit-handle (current-editor))))
|
||||
(cond ((/= 0 (logand flags *FR_DIALOGTERM*))
|
||||
(free-foreign-object lparam)
|
||||
(setq *txtedit-dlg-handle* *NULL*))
|
||||
((/= 0 (logand flags *FR_FINDNEXT*))
|
||||
(let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat))
|
||||
pos
|
||||
(down (/= (logand flags *FR_DOWN*) 0)))
|
||||
(cond ((= *txtedit-edit-class* 2)
|
||||
(let ((selStart (sendmessage hnd 2143 0 0))
|
||||
(selEnd (sendmessage hnd 2145 0 0)))
|
||||
(sendmessage hnd 2025 (if down selEnd selStart) 0)
|
||||
(sendmessage hnd 2366 0 0)
|
||||
(with-foreign-string (s str)
|
||||
(if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1)
|
||||
(sendmessage hnd 2169 0 0)
|
||||
(progn
|
||||
(messagebox *txtedit-dlg-handle* "Finished searching the document"
|
||||
"Find" (logior *MB_OK* *MB_ICONINFORMATION*))
|
||||
(sendmessage hnd 2160 selStart selEnd))))))
|
||||
)))
|
||||
)))
|
||||
0)
|
||||
(t
|
||||
(defwindowproc hwnd umsg wparam lparam))
|
||||
(postquitmessage 0)
|
||||
0)
|
||||
((= umsg *WM_CLOSE*)
|
||||
(if (do ((flag t))
|
||||
((not (and *txtedit-edit* flag)) flag)
|
||||
(setq flag (close-editor 0 hwnd)))
|
||||
(destroywindow hwnd)
|
||||
0))
|
||||
((= umsg *WM_CREATE*)
|
||||
(when (null-pointer-p (getmodulehandle "comctl32"))
|
||||
(initcommoncontrols))
|
||||
(setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* ""
|
||||
(logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0
|
||||
hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*))
|
||||
(setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc))
|
||||
(sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
|
||||
(create-editor hwnd)
|
||||
(with-cast-int-pointer (lparam CREATESTRUCT)
|
||||
(let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams)))
|
||||
(unless (null-pointer-p params)
|
||||
(read-file (convert-from-foreign-string params) hwnd))))
|
||||
0)
|
||||
((= umsg *WM_SIZE*)
|
||||
(unless (null-pointer-p *txtedit-tab*)
|
||||
(movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*)
|
||||
(with-foreign-object (r 'RECT)
|
||||
(setrect r 0 0 (loword lparam) (hiword lparam))
|
||||
(sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
|
||||
(dotimes (k (length *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 'right) (get-slot-value r 'RECT 'left))
|
||||
(- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
|
||||
(if (= k *txtedit-current*) *TRUE* *FALSE*)))))
|
||||
0)
|
||||
((= umsg *WM_SETFOCUS*)
|
||||
(unless (null-pointer-p (txtedit-handle (current-editor)))
|
||||
(setfocus (txtedit-handle (current-editor))))
|
||||
0)
|
||||
((= umsg *WM_NOTIFY*)
|
||||
(with-cast-int-pointer (lparam NMHDR)
|
||||
(let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom))
|
||||
(code (get-slot-value lparam 'NMHDR 'code))
|
||||
(hnd (get-slot-value lparam 'NMHDR 'hwndFrom)))
|
||||
(cond ((= ctrl-ID +TABCTL_ID+)
|
||||
(cond ((= code *TCN_SELCHANGE*)
|
||||
(set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd))
|
||||
(t
|
||||
)))
|
||||
((and (= *txtedit-edit-class* 2)
|
||||
(= code 2001))
|
||||
(with-cast-pointer (lparam SCNotification)
|
||||
(scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch)))))
|
||||
((and (= *txtedit-edit-class* 2)
|
||||
(= code 2007))
|
||||
(scintilla-check-for-brace hnd))
|
||||
(t
|
||||
))))
|
||||
0)
|
||||
((= umsg *WM_CONTEXTMENU*)
|
||||
(let ((hnd (make-handle wparam))
|
||||
(x (get-x-lparam lparam))
|
||||
(y (get-y-lparam lparam)))
|
||||
(cond ((equal hnd *txtedit-tab*)
|
||||
(with-foreign-objects ((ht 'TCHITTESTINFO)
|
||||
(pt 'POINT))
|
||||
(setf (get-slot-value pt 'POINT 'x) x)
|
||||
(setf (get-slot-value pt 'POINT 'y) y)
|
||||
(screentoclient *txtedit-tab* pt)
|
||||
(setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt)
|
||||
(let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht))))
|
||||
(when (>= tab 0)
|
||||
(let ((hMenu (createpopupmenu))
|
||||
menu-ID)
|
||||
(appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close")
|
||||
(when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0)
|
||||
(close-or-exit tab hwnd))
|
||||
(destroymenu hMenu))))))))
|
||||
0)
|
||||
((= umsg *WM_INITMENUPOPUP*)
|
||||
(case (loword lparam)
|
||||
(2 (let* ((wMenu (make-handle wparam))
|
||||
(nPos (loword lparam))
|
||||
(nItems (getmenuitemcount wMenu)))
|
||||
(dotimes (j (- nItems 2))
|
||||
(deletemenu wMenu 2 *MF_BYPOSITION*))
|
||||
(when *txtedit-edit*
|
||||
(appendmenu wMenu *MF_SEPARATOR* 0 "")
|
||||
(loop for e in *txtedit-edit*
|
||||
for k from 0
|
||||
do (progn
|
||||
(appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e))
|
||||
(when (= k *txtedit-current*)
|
||||
(checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*))))))
|
||||
(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*))
|
||||
))
|
||||
)
|
||||
0)
|
||||
((= umsg *WM_COMMAND*)
|
||||
(let ((ctrl-ID (loword wparam))
|
||||
(nmsg (hiword wparam))
|
||||
(hnd (make-pointer lparam 'HANDLE)))
|
||||
(cond ((= ctrl-ID +EDITCTL_ID+)
|
||||
(cond ((= nmsg *EN_CHANGE*)
|
||||
(unless (txtedit-dirty (current-editor))
|
||||
(setf (txtedit-dirty (current-editor)) t)
|
||||
(update-caption hwnd)
|
||||
(update-tab *txtedit-current*)))
|
||||
(t
|
||||
)))
|
||||
((= ctrl-ID +IDM_QUIT+)
|
||||
(sendmessage hwnd *WM_CLOSE* 0 0))
|
||||
((= ctrl-ID +IDM_OPEN+)
|
||||
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
|
||||
("All Files (*)" . "*")))))
|
||||
(when pn
|
||||
(create-editor hwnd)
|
||||
(read-file pn hwnd))))
|
||||
((and (= ctrl-ID +IDM_SAVE+)
|
||||
(txtedit-title (current-editor)))
|
||||
(save-file nil hwnd))
|
||||
((or (= ctrl-ID +IDM_SAVEAS+)
|
||||
(and (= ctrl-ID +IDM_SAVE+)
|
||||
(null (txtedit-title (current-editor)))))
|
||||
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
|
||||
("All Files (*)" . "*"))
|
||||
:dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*)))
|
||||
(when pn
|
||||
(save-file pn hwnd))))
|
||||
((= ctrl-ID +IDM_NEW+)
|
||||
(create-editor hwnd))
|
||||
((= ctrl-ID +IDM_CUT+)
|
||||
(sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0))
|
||||
((= ctrl-ID +IDM_COPY+)
|
||||
(sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0))
|
||||
((= ctrl-ID +IDM_PASTE+)
|
||||
(sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0))
|
||||
((= ctrl-ID +IDM_UNDO+)
|
||||
(unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0)
|
||||
(sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0)))
|
||||
((= ctrl-ID +IDM_SELECTALL+)
|
||||
(sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1))
|
||||
((= ctrl-ID +IDM_ABOUT+)
|
||||
(messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*)))
|
||||
((= ctrl-ID +IDM_NEXTWINDOW+)
|
||||
(unless (>= (1+ *txtedit-current*) (length *txtedit-edit*))
|
||||
(set-current-editor (1+ *txtedit-current*) hwnd)))
|
||||
((= ctrl-ID +IDM_PREVWINDOW+)
|
||||
(unless (= *txtedit-current* 0)
|
||||
(set-current-editor (1- *txtedit-current*) hwnd)))
|
||||
((= ctrl-ID +IDM_CLOSE+)
|
||||
(close-or-exit *txtedit-current* hwnd))
|
||||
((= ctrl-ID +IDM_MATCH_PAREN+)
|
||||
(let ((hnd (txtedit-handle (current-editor))))
|
||||
(multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
|
||||
(when (and curPos (>= matchPos 0))
|
||||
(sendmessage hnd 2025 (1+ matchPos) 0)))))
|
||||
((= ctrl-ID +IDM_FIND+)
|
||||
(let* ((fr (allocate-foreign-object 'FINDREPLACE))
|
||||
(str (make-string 1024 :initial-element #\Null)))
|
||||
(zeromemory fr (size-of-foreign-type 'FINDREPLACE))
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE))
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd)
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str)
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024)
|
||||
(setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*)
|
||||
(setq *txtedit-dlg-handle* (findtext fr))))
|
||||
((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+)
|
||||
(set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd)
|
||||
0)
|
||||
(t
|
||||
)))
|
||||
0)
|
||||
((= uMsg (1+ *WM_USER*))
|
||||
(print "Open file request received")
|
||||
(let ((fname (pop *txtedit-files*)))
|
||||
(when fname
|
||||
(create-editor hwnd)
|
||||
(read-file fname hwnd)))
|
||||
0)
|
||||
((= uMsg *txtedit-findreplace-msg*)
|
||||
(with-cast-int-pointer (lparam FINDREPLACE)
|
||||
(let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags))
|
||||
(hnd (txtedit-handle (current-editor))))
|
||||
(cond ((/= 0 (logand flags *FR_DIALOGTERM*))
|
||||
(free-foreign-object lparam)
|
||||
(setq *txtedit-dlg-handle* *NULL*))
|
||||
((/= 0 (logand flags *FR_FINDNEXT*))
|
||||
(let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat))
|
||||
pos
|
||||
(down (/= (logand flags *FR_DOWN*) 0)))
|
||||
(cond ((= *txtedit-edit-class* 2)
|
||||
(let ((selStart (sendmessage hnd 2143 0 0))
|
||||
(selEnd (sendmessage hnd 2145 0 0)))
|
||||
(sendmessage hnd 2025 (if down selEnd selStart) 0)
|
||||
(sendmessage hnd 2366 0 0)
|
||||
(with-foreign-string (s str)
|
||||
(if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1)
|
||||
(sendmessage hnd 2169 0 0)
|
||||
(progn
|
||||
(messagebox *txtedit-dlg-handle* "Finished searching the document"
|
||||
"Find" (logior *MB_OK* *MB_ICONINFORMATION*))
|
||||
(sendmessage hnd 2160 selStart selEnd))))))
|
||||
)))
|
||||
)))
|
||||
0)
|
||||
(t
|
||||
(defwindowproc hwnd umsg wparam lparam))
|
||||
))
|
||||
|
||||
(defun txtedit-class-name ()
|
||||
|
|
@ -620,16 +620,16 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
(unless *txtedit-class-registered*
|
||||
(case *txtedit-edit-class*
|
||||
(-1 (or (and (not (null-pointer-p (loadlibrary "SciLexer.dll")))
|
||||
(setq *txtedit-edit-class* 2))
|
||||
(and (not (null-pointer-p (loadlibrary "riched20.dll")))
|
||||
(setq *txtedit-edit-class* 1))
|
||||
(setq *txtedit-edit-class* 0)))
|
||||
(setq *txtedit-edit-class* 2))
|
||||
(and (not (null-pointer-p (loadlibrary "riched20.dll")))
|
||||
(setq *txtedit-edit-class* 1))
|
||||
(setq *txtedit-edit-class* 0)))
|
||||
(1 (and (null-pointer-p (loadlibrary "riched20.dll"))
|
||||
(error "Cannot load WIN32 library: riched20.dll")))
|
||||
(error "Cannot load WIN32 library: riched20.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"
|
||||
:lpfnWndProc #'txtedit-proc)
|
||||
:lpfnWndProc #'txtedit-proc)
|
||||
(setq *txtedit-class-registered* t)))
|
||||
|
||||
(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))
|
||||
(register-txtedit-class)
|
||||
(let* ((fname-str (if fname
|
||||
(convert-to-foreign-string (coerce fname 'simple-string))
|
||||
*NULL*))
|
||||
(w (createwindow "SimpleTextEditor"
|
||||
*txtedit-default-title*
|
||||
(logior *WS_OVERLAPPEDWINDOW*)
|
||||
*CW_USEDEFAULT* *CW_USEDEFAULT*
|
||||
*txtedit-width* *txtedit-height*
|
||||
*NULL* (create-menus) *NULL* fname-str))
|
||||
(accTable (create-accels)))
|
||||
(convert-to-foreign-string (coerce fname 'simple-string))
|
||||
*NULL*))
|
||||
(w (createwindow "SimpleTextEditor"
|
||||
*txtedit-default-title*
|
||||
(logior *WS_OVERLAPPEDWINDOW*)
|
||||
*CW_USEDEFAULT* *CW_USEDEFAULT*
|
||||
*txtedit-width* *txtedit-height*
|
||||
*NULL* (create-menus) *NULL* fname-str))
|
||||
(accTable (create-accels)))
|
||||
(setq *txtedit-handle* w)
|
||||
(showwindow w *SW_SHOWNORMAL*)
|
||||
(updatewindow w)
|
||||
|
|
@ -669,9 +669,9 @@ Copyright (c) 2005, Michael Goffioul.")
|
|||
(if (or detach-p *txtedit-process*)
|
||||
(if (member :threads *features*)
|
||||
(if *txtedit-process*
|
||||
(progn
|
||||
(push fname *txtedit-files*)
|
||||
(postmessage *txtedit-handle* (1+ *WM_USER*) 0 0))
|
||||
#+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class)))))
|
||||
(progn
|
||||
(push fname *txtedit-files*)
|
||||
(postmessage *txtedit-handle* (1+ *WM_USER*) 0 0))
|
||||
#+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class)))))
|
||||
(error "No multi-threading environment detected."))
|
||||
(txtedit fname :class class)))
|
||||
|
|
|
|||
|
|
@ -37,291 +37,291 @@
|
|||
(define-win-constant *TRUE* 1)
|
||||
(define-win-constant *FALSE* 0)
|
||||
|
||||
(define-win-constant *WM_CLOSE* #x0010)
|
||||
(define-win-constant *WM_COMMAND* #x0111)
|
||||
(define-win-constant *WM_CONTEXTMENU* #x007b)
|
||||
(define-win-constant *WM_COPY* #x0301)
|
||||
(define-win-constant *WM_CREATE* #x0001)
|
||||
(define-win-constant *WM_CUT* #x0300)
|
||||
(define-win-constant *WM_DESTROY* #x0002)
|
||||
(define-win-constant *WM_GETFONT* #x0031)
|
||||
(define-win-constant *WM_GETMINMAXINFO* #x0024)
|
||||
(define-win-constant *WM_INITMENU* #x0116)
|
||||
(define-win-constant *WM_INITMENUPOPUP* #x0117)
|
||||
(define-win-constant *WM_NCPAINT* #x0085)
|
||||
(define-win-constant *WM_NOTIFY* #x004e)
|
||||
(define-win-constant *WM_PAINT* #x000f)
|
||||
(define-win-constant *WM_PASTE* #x0302)
|
||||
(define-win-constant *WM_QUIT* #x0012)
|
||||
(define-win-constant *WM_SETFOCUS* #x0007)
|
||||
(define-win-constant *WM_SETFONT* #x0030)
|
||||
(define-win-constant *WM_SIZE* #x0005)
|
||||
(define-win-constant *WM_UNDO* #x0304)
|
||||
(define-win-constant *WM_USER* #x0400)
|
||||
(define-win-constant *WM_CLOSE* #x0010)
|
||||
(define-win-constant *WM_COMMAND* #x0111)
|
||||
(define-win-constant *WM_CONTEXTMENU* #x007b)
|
||||
(define-win-constant *WM_COPY* #x0301)
|
||||
(define-win-constant *WM_CREATE* #x0001)
|
||||
(define-win-constant *WM_CUT* #x0300)
|
||||
(define-win-constant *WM_DESTROY* #x0002)
|
||||
(define-win-constant *WM_GETFONT* #x0031)
|
||||
(define-win-constant *WM_GETMINMAXINFO* #x0024)
|
||||
(define-win-constant *WM_INITMENU* #x0116)
|
||||
(define-win-constant *WM_INITMENUPOPUP* #x0117)
|
||||
(define-win-constant *WM_NCPAINT* #x0085)
|
||||
(define-win-constant *WM_NOTIFY* #x004e)
|
||||
(define-win-constant *WM_PAINT* #x000f)
|
||||
(define-win-constant *WM_PASTE* #x0302)
|
||||
(define-win-constant *WM_QUIT* #x0012)
|
||||
(define-win-constant *WM_SETFOCUS* #x0007)
|
||||
(define-win-constant *WM_SETFONT* #x0030)
|
||||
(define-win-constant *WM_SIZE* #x0005)
|
||||
(define-win-constant *WM_UNDO* #x0304)
|
||||
(define-win-constant *WM_USER* #x0400)
|
||||
|
||||
(define-win-constant *WS_BORDER* #x00800000)
|
||||
(define-win-constant *WS_CHILD* #x40000000)
|
||||
(define-win-constant *WS_CLIPCHILDREN* #x02000000)
|
||||
(define-win-constant *WS_CLIPSIBLINGS* #x04000000)
|
||||
(define-win-constant *WS_DLGFRAME* #x00400000)
|
||||
(define-win-constant *WS_DISABLED* #x08000000)
|
||||
(define-win-constant *WS_HSCROLL* #x00100000)
|
||||
(define-win-constant *WS_OVERLAPPEDWINDOW* #x00CF0000)
|
||||
(define-win-constant *WS_VISIBLE* #x10000000)
|
||||
(define-win-constant *WS_VSCROLL* #x00200000)
|
||||
(define-win-constant *WS_BORDER* #x00800000)
|
||||
(define-win-constant *WS_CHILD* #x40000000)
|
||||
(define-win-constant *WS_CLIPCHILDREN* #x02000000)
|
||||
(define-win-constant *WS_CLIPSIBLINGS* #x04000000)
|
||||
(define-win-constant *WS_DLGFRAME* #x00400000)
|
||||
(define-win-constant *WS_DISABLED* #x08000000)
|
||||
(define-win-constant *WS_HSCROLL* #x00100000)
|
||||
(define-win-constant *WS_OVERLAPPEDWINDOW* #x00CF0000)
|
||||
(define-win-constant *WS_VISIBLE* #x10000000)
|
||||
(define-win-constant *WS_VSCROLL* #x00200000)
|
||||
|
||||
(define-win-constant *WS_EX_CLIENTEDGE* #x00000200)
|
||||
(define-win-constant *WS_EX_CLIENTEDGE* #x00000200)
|
||||
|
||||
(define-win-constant *RICHEDIT_CLASS* "RichEdit20A")
|
||||
(define-win-constant *WC_LISTVIEW* "SysListView32")
|
||||
(define-win-constant *WC_TABCONTROL* "SysTabControl32")
|
||||
(define-win-constant *RICHEDIT_CLASS* "RichEdit20A")
|
||||
(define-win-constant *WC_LISTVIEW* "SysListView32")
|
||||
(define-win-constant *WC_TABCONTROL* "SysTabControl32")
|
||||
|
||||
(define-win-constant *HWND_BOTTOM* (make-pointer 1 'HANDLE))
|
||||
(define-win-constant *HWND_NOTOPMOST* (make-pointer -2 'HANDLE))
|
||||
(define-win-constant *HWND_TOP* (make-pointer 0 'HANDLE))
|
||||
(define-win-constant *HWND_TOPMOST* (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_TOP* (make-pointer 0 'HANDLE))
|
||||
(define-win-constant *HWND_TOPMOST* (make-pointer -1 'HANDLE))
|
||||
|
||||
(define-win-constant *SWP_DRAWFRAME* #x0020)
|
||||
(define-win-constant *SWP_HIDEWINDOW* #x0080)
|
||||
(define-win-constant *SWP_NOMOVE* #x0002)
|
||||
(define-win-constant *SWP_NOOWNERZORDER* #x0200)
|
||||
(define-win-constant *SWP_NOREDRAW* #x0008)
|
||||
(define-win-constant *SWP_NOREPOSITION* #x0200)
|
||||
(define-win-constant *SWP_NOSIZE* #x0001)
|
||||
(define-win-constant *SWP_NOZORDER* #x0004)
|
||||
(define-win-constant *SWP_SHOWWINDOW* #x0040)
|
||||
(define-win-constant *SWP_DRAWFRAME* #x0020)
|
||||
(define-win-constant *SWP_HIDEWINDOW* #x0080)
|
||||
(define-win-constant *SWP_NOMOVE* #x0002)
|
||||
(define-win-constant *SWP_NOOWNERZORDER* #x0200)
|
||||
(define-win-constant *SWP_NOREDRAW* #x0008)
|
||||
(define-win-constant *SWP_NOREPOSITION* #x0200)
|
||||
(define-win-constant *SWP_NOSIZE* #x0001)
|
||||
(define-win-constant *SWP_NOZORDER* #x0004)
|
||||
(define-win-constant *SWP_SHOWWINDOW* #x0040)
|
||||
|
||||
(define-win-constant *BS_DEFPUSHBUTTON* #x00000000)
|
||||
(define-win-constant *BS_PUSHBUTTON* #x00000001)
|
||||
(define-win-constant *BS_DEFPUSHBUTTON* #x00000000)
|
||||
(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_AUTOVSCROLL* #x0040)
|
||||
(define-win-constant *ES_LEFT* #x0000)
|
||||
(define-win-constant *ES_MULTILINE* #x0004)
|
||||
(define-win-constant *ES_AUTOHSCROLL* #x0080)
|
||||
(define-win-constant *ES_AUTOVSCROLL* #x0040)
|
||||
(define-win-constant *ES_LEFT* #x0000)
|
||||
(define-win-constant *ES_MULTILINE* #x0004)
|
||||
|
||||
(define-win-constant *EM_CANUNDO* #x00c6)
|
||||
(define-win-constant *EM_SETEVENTMASK* (+ *WM_USER* 69))
|
||||
(define-win-constant *EM_SETSEL* #x00b1)
|
||||
(define-win-constant *EM_UNDO* #x00c7)
|
||||
(define-win-constant *EN_CHANGE* #x0300)
|
||||
(define-win-constant *ENM_CHANGE* #x00000001)
|
||||
(define-win-constant *EM_CANUNDO* #x00c6)
|
||||
(define-win-constant *EM_SETEVENTMASK* (+ *WM_USER* 69))
|
||||
(define-win-constant *EM_SETSEL* #x00b1)
|
||||
(define-win-constant *EM_UNDO* #x00c7)
|
||||
(define-win-constant *EN_CHANGE* #x0300)
|
||||
(define-win-constant *ENM_CHANGE* #x00000001)
|
||||
|
||||
(define-win-constant *TCIF_IMAGE* #x0002)
|
||||
(define-win-constant *TCIF_PARAM* #x0008)
|
||||
(define-win-constant *TCIF_RTLREADING* #x0004)
|
||||
(define-win-constant *TCIF_STATE* #x0010)
|
||||
(define-win-constant *TCIF_TEXT* #x0001)
|
||||
(define-win-constant *TCIF_IMAGE* #x0002)
|
||||
(define-win-constant *TCIF_PARAM* #x0008)
|
||||
(define-win-constant *TCIF_RTLREADING* #x0004)
|
||||
(define-win-constant *TCIF_STATE* #x0010)
|
||||
(define-win-constant *TCIF_TEXT* #x0001)
|
||||
|
||||
(define-win-constant *TCHT_NOWHERE* #x0001)
|
||||
(define-win-constant *TCHT_ONITEM* #x0006)
|
||||
(define-win-constant *TCHT_ONITEMICON* #x0002)
|
||||
(define-win-constant *TCHT_ONITEMLABEL* #x0004)
|
||||
(define-win-constant *TCHT_NOWHERE* #x0001)
|
||||
(define-win-constant *TCHT_ONITEM* #x0006)
|
||||
(define-win-constant *TCHT_ONITEMICON* #x0002)
|
||||
(define-win-constant *TCHT_ONITEMLABEL* #x0004)
|
||||
|
||||
(define-win-constant *TCM_FIRST* #x1300)
|
||||
(define-win-constant *TCN_FIRST* #xfffffdda)
|
||||
(define-win-constant *TCM_ADJUSTRECT* (+ *TCM_FIRST* 40))
|
||||
(define-win-constant *TCM_DELETEITEM* (+ *TCM_FIRST* 8))
|
||||
(define-win-constant *TCM_GETCURSEL* (+ *TCM_FIRST* 11))
|
||||
(define-win-constant *TCM_HITTEST* (+ *TCM_FIRST* 13))
|
||||
(define-win-constant *TCM_INSERTITEM* (+ *TCM_FIRST* 7))
|
||||
(define-win-constant *TCM_SETCURSEL* (+ *TCM_FIRST* 12))
|
||||
(define-win-constant *TCM_SETITEM* (+ *TCM_FIRST* 6))
|
||||
(define-win-constant *TCN_SELCHANGE* (- *TCN_FIRST* 1))
|
||||
(define-win-constant *TCM_FIRST* #x1300)
|
||||
(define-win-constant *TCN_FIRST* #xfffffdda)
|
||||
(define-win-constant *TCM_ADJUSTRECT* (+ *TCM_FIRST* 40))
|
||||
(define-win-constant *TCM_DELETEITEM* (+ *TCM_FIRST* 8))
|
||||
(define-win-constant *TCM_GETCURSEL* (+ *TCM_FIRST* 11))
|
||||
(define-win-constant *TCM_HITTEST* (+ *TCM_FIRST* 13))
|
||||
(define-win-constant *TCM_INSERTITEM* (+ *TCM_FIRST* 7))
|
||||
(define-win-constant *TCM_SETCURSEL* (+ *TCM_FIRST* 12))
|
||||
(define-win-constant *TCM_SETITEM* (+ *TCM_FIRST* 6))
|
||||
(define-win-constant *TCN_SELCHANGE* (- *TCN_FIRST* 1))
|
||||
|
||||
(define-win-constant *NM_FIRST* #x100000000)
|
||||
(define-win-constant *NM_CLICK* (- *NM_FIRST* 1))
|
||||
(define-win-constant *NM_RCLICK* (- *NM_FIRST* 5))
|
||||
(define-win-constant *NM_FIRST* #x100000000)
|
||||
(define-win-constant *NM_CLICK* (- *NM_FIRST* 1))
|
||||
(define-win-constant *NM_RCLICK* (- *NM_FIRST* 5))
|
||||
|
||||
(define-win-constant *SW_HIDE* 0)
|
||||
(define-win-constant *SW_SHOW* 5)
|
||||
(define-win-constant *SW_SHOWNORMAL* 1)
|
||||
(define-win-constant *SW_HIDE* 0)
|
||||
(define-win-constant *SW_SHOW* 5)
|
||||
(define-win-constant *SW_SHOWNORMAL* 1)
|
||||
|
||||
(define-win-constant *RDW_ERASE* #x0004)
|
||||
(define-win-constant *RDW_FRAME* #x0400)
|
||||
(define-win-constant *RDW_INTERNALPAINT* #x0002)
|
||||
(define-win-constant *RDW_INVALIDATE* #x0001)
|
||||
(define-win-constant *RDW_NOERASE* #x0020)
|
||||
(define-win-constant *RDW_NOFRAME* #x0800)
|
||||
(define-win-constant *RDW_NOINTERNALPAINT* #x0010)
|
||||
(define-win-constant *RDW_VALIDATE* #x0008)
|
||||
(define-win-constant *RDW_ERASENOW* #x0200)
|
||||
(define-win-constant *RDW_UPDATENOW* #x0100)
|
||||
(define-win-constant *RDW_ALLCHILDREN* #x0080)
|
||||
(define-win-constant *RDW_NOCHILDREN* #x0040)
|
||||
(define-win-constant *RDW_ERASE* #x0004)
|
||||
(define-win-constant *RDW_FRAME* #x0400)
|
||||
(define-win-constant *RDW_INTERNALPAINT* #x0002)
|
||||
(define-win-constant *RDW_INVALIDATE* #x0001)
|
||||
(define-win-constant *RDW_NOERASE* #x0020)
|
||||
(define-win-constant *RDW_NOFRAME* #x0800)
|
||||
(define-win-constant *RDW_NOINTERNALPAINT* #x0010)
|
||||
(define-win-constant *RDW_VALIDATE* #x0008)
|
||||
(define-win-constant *RDW_ERASENOW* #x0200)
|
||||
(define-win-constant *RDW_UPDATENOW* #x0100)
|
||||
(define-win-constant *RDW_ALLCHILDREN* #x0080)
|
||||
(define-win-constant *RDW_NOCHILDREN* #x0040)
|
||||
|
||||
(define-win-constant *CW_USEDEFAULT* (- #x80000000))
|
||||
(define-win-constant *CW_USEDEFAULT* (- #x80000000))
|
||||
|
||||
(define-win-constant *IDC_ARROW* 32512)
|
||||
(define-win-constant *IDI_APPLICATION* 32512)
|
||||
(define-win-constant *IDC_ARROW* 32512)
|
||||
(define-win-constant *IDI_APPLICATION* 32512)
|
||||
|
||||
(define-win-constant *COLOR_BACKGROUND* 1)
|
||||
(define-win-constant *DEFAULT_GUI_FONT* 17)
|
||||
(define-win-constant *OEM_FIXED_FONT* 10)
|
||||
(define-win-constant *SYSTEM_FONT* 13)
|
||||
(define-win-constant *SYSTEM_FIXED_FONT* 16)
|
||||
(define-win-constant *COLOR_BACKGROUND* 1)
|
||||
(define-win-constant *DEFAULT_GUI_FONT* 17)
|
||||
(define-win-constant *OEM_FIXED_FONT* 10)
|
||||
(define-win-constant *SYSTEM_FONT* 13)
|
||||
(define-win-constant *SYSTEM_FIXED_FONT* 16)
|
||||
|
||||
(define-win-constant *MB_HELP* #x00004000)
|
||||
(define-win-constant *MB_OK* #x00000000)
|
||||
(define-win-constant *MB_OKCANCEL* #x00000001)
|
||||
(define-win-constant *MB_YESNO* #x00000004)
|
||||
(define-win-constant *MB_YESNOCANCEL* #x00000003)
|
||||
(define-win-constant *MB_ICONEXCLAMATION* #x00000030)
|
||||
(define-win-constant *MB_ICONWARNING* #x00000020)
|
||||
(define-win-constant *MB_ICONERROR* #x00000010)
|
||||
(define-win-constant *MB_ICONINFORMATION* #x00000040)
|
||||
(define-win-constant *MB_ICONQUESTION* #x00000020)
|
||||
(define-win-constant *MB_HELP* #x00004000)
|
||||
(define-win-constant *MB_OK* #x00000000)
|
||||
(define-win-constant *MB_OKCANCEL* #x00000001)
|
||||
(define-win-constant *MB_YESNO* #x00000004)
|
||||
(define-win-constant *MB_YESNOCANCEL* #x00000003)
|
||||
(define-win-constant *MB_ICONEXCLAMATION* #x00000030)
|
||||
(define-win-constant *MB_ICONWARNING* #x00000020)
|
||||
(define-win-constant *MB_ICONERROR* #x00000010)
|
||||
(define-win-constant *MB_ICONINFORMATION* #x00000040)
|
||||
(define-win-constant *MB_ICONQUESTION* #x00000020)
|
||||
|
||||
(define-win-constant *IDCANCEL* 2)
|
||||
(define-win-constant *IDNO* 7)
|
||||
(define-win-constant *IDOK* 1)
|
||||
(define-win-constant *IDYES* 6)
|
||||
(define-win-constant *IDCANCEL* 2)
|
||||
(define-win-constant *IDNO* 7)
|
||||
(define-win-constant *IDOK* 1)
|
||||
(define-win-constant *IDYES* 6)
|
||||
|
||||
(define-win-constant *MF_BYCOMMAND* #x00000000)
|
||||
(define-win-constant *MF_BYPOSITION* #x00000400)
|
||||
(define-win-constant *MF_CHECKED* #x00000008)
|
||||
(define-win-constant *MF_DISABLED* #x00000002)
|
||||
(define-win-constant *MF_ENABLED* #x00000000)
|
||||
(define-win-constant *MF_GRAYED* #x00000001)
|
||||
(define-win-constant *MF_MENUBREAK* #x00000040)
|
||||
(define-win-constant *MF_POPUP* #x00000010)
|
||||
(define-win-constant *MF_SEPARATOR* #x00000800)
|
||||
(define-win-constant *MF_STRING* #x00000000)
|
||||
(define-win-constant *MF_UNCHECKED* #x00000000)
|
||||
(define-win-constant *MF_BYCOMMAND* #x00000000)
|
||||
(define-win-constant *MF_BYPOSITION* #x00000400)
|
||||
(define-win-constant *MF_CHECKED* #x00000008)
|
||||
(define-win-constant *MF_DISABLED* #x00000002)
|
||||
(define-win-constant *MF_ENABLED* #x00000000)
|
||||
(define-win-constant *MF_GRAYED* #x00000001)
|
||||
(define-win-constant *MF_MENUBREAK* #x00000040)
|
||||
(define-win-constant *MF_POPUP* #x00000010)
|
||||
(define-win-constant *MF_SEPARATOR* #x00000800)
|
||||
(define-win-constant *MF_STRING* #x00000000)
|
||||
(define-win-constant *MF_UNCHECKED* #x00000000)
|
||||
|
||||
(define-win-constant *TPM_CENTERALIGN* #x0004)
|
||||
(define-win-constant *TPM_LEFTALIGN* #x0000)
|
||||
(define-win-constant *TPM_RIGHTALIGN* #x0008)
|
||||
(define-win-constant *TPM_BOTTOMALIGN* #x0020)
|
||||
(define-win-constant *TPM_TOPALIGN* #x0000)
|
||||
(define-win-constant *TPM_VCENTERALIGN* #x0010)
|
||||
(define-win-constant *TPM_NONOTIFY* #x0080)
|
||||
(define-win-constant *TPM_RETURNCMD* #x0100)
|
||||
(define-win-constant *TPM_LEFTBUTTON* #x0000)
|
||||
(define-win-constant *TPM_RIGHTBUTTON* #x0002)
|
||||
(define-win-constant *TPM_CENTERALIGN* #x0004)
|
||||
(define-win-constant *TPM_LEFTALIGN* #x0000)
|
||||
(define-win-constant *TPM_RIGHTALIGN* #x0008)
|
||||
(define-win-constant *TPM_BOTTOMALIGN* #x0020)
|
||||
(define-win-constant *TPM_TOPALIGN* #x0000)
|
||||
(define-win-constant *TPM_VCENTERALIGN* #x0010)
|
||||
(define-win-constant *TPM_NONOTIFY* #x0080)
|
||||
(define-win-constant *TPM_RETURNCMD* #x0100)
|
||||
(define-win-constant *TPM_LEFTBUTTON* #x0000)
|
||||
(define-win-constant *TPM_RIGHTBUTTON* #x0002)
|
||||
|
||||
(define-win-constant *OFN_FILEMUSTEXIST* #x00001000)
|
||||
(define-win-constant *OFN_OVERWRITEPROMPT* #x00000002)
|
||||
(define-win-constant *OFN_PATHMUSTEXIST* #x00000800)
|
||||
(define-win-constant *OFN_READONLY* #x00000001)
|
||||
(define-win-constant *OFN_FILEMUSTEXIST* #x00001000)
|
||||
(define-win-constant *OFN_OVERWRITEPROMPT* #x00000002)
|
||||
(define-win-constant *OFN_PATHMUSTEXIST* #x00000800)
|
||||
(define-win-constant *OFN_READONLY* #x00000001)
|
||||
|
||||
(define-win-constant *FVIRTKEY* *TRUE*)
|
||||
(define-win-constant *FNOINVERT* #x02)
|
||||
(define-win-constant *FSHIFT* #x04)
|
||||
(define-win-constant *FCONTROL* #x08)
|
||||
(define-win-constant *FALT* #x10)
|
||||
(define-win-constant *FVIRTKEY* *TRUE*)
|
||||
(define-win-constant *FNOINVERT* #x02)
|
||||
(define-win-constant *FSHIFT* #x04)
|
||||
(define-win-constant *FCONTROL* #x08)
|
||||
(define-win-constant *FALT* #x10)
|
||||
|
||||
(define-win-constant *VK_F1* #x70)
|
||||
(define-win-constant *VK_LEFT* #x25)
|
||||
(define-win-constant *VK_RIGHT* #x27)
|
||||
(define-win-constant *VK_F1* #x70)
|
||||
(define-win-constant *VK_LEFT* #x25)
|
||||
(define-win-constant *VK_RIGHT* #x27)
|
||||
|
||||
(define-win-constant *GWL_EXSTYLE* -20)
|
||||
(define-win-constant *GWL_HINSTANCE* -6)
|
||||
(define-win-constant *GWL_HWNDPARENT* -8)
|
||||
(define-win-constant *GWL_ID* -12)
|
||||
(define-win-constant *GWL_STYLE* -16)
|
||||
(define-win-constant *GWL_WNDPROC* -4)
|
||||
(define-win-constant *GWL_EXSTYLE* -20)
|
||||
(define-win-constant *GWL_HINSTANCE* -6)
|
||||
(define-win-constant *GWL_HWNDPARENT* -8)
|
||||
(define-win-constant *GWL_ID* -12)
|
||||
(define-win-constant *GWL_STYLE* -16)
|
||||
(define-win-constant *GWL_WNDPROC* -4)
|
||||
|
||||
(define-win-constant *FINDMSGSTRING* "commdlg_FindReplace")
|
||||
(define-win-constant *HELPMSGSTRING* "commdlg_help")
|
||||
|
||||
(define-win-constant *FR_DIALOGTERM* #x00000040)
|
||||
(define-win-constant *FR_DOWN* #x00000001)
|
||||
(define-win-constant *FR_FINDNEXT* #x00000008)
|
||||
(define-win-constant *FR_HIDEUPDOWN* #x00004000)
|
||||
(define-win-constant *FR_HIDEMATCHCASE* #x00008000)
|
||||
(define-win-constant *FR_HIDEWHOLEWORD* #x00010000)
|
||||
(define-win-constant *FR_MATCHCASE* #x00000004)
|
||||
(define-win-constant *FR_NOMATCHCASE* #x00000800)
|
||||
(define-win-constant *FR_NOUPDOWN* #x00000400)
|
||||
(define-win-constant *FR_NOWHOLEWORD* #x00001000)
|
||||
(define-win-constant *FR_REPLACE* #x00000010)
|
||||
(define-win-constant *FR_REPLACEALL* #x00000020)
|
||||
(define-win-constant *FR_SHOWHELP* #x00000080)
|
||||
(define-win-constant *FR_WHOLEWORD* #x00000002)
|
||||
(define-win-constant *FR_DIALOGTERM* #x00000040)
|
||||
(define-win-constant *FR_DOWN* #x00000001)
|
||||
(define-win-constant *FR_FINDNEXT* #x00000008)
|
||||
(define-win-constant *FR_HIDEUPDOWN* #x00004000)
|
||||
(define-win-constant *FR_HIDEMATCHCASE* #x00008000)
|
||||
(define-win-constant *FR_HIDEWHOLEWORD* #x00010000)
|
||||
(define-win-constant *FR_MATCHCASE* #x00000004)
|
||||
(define-win-constant *FR_NOMATCHCASE* #x00000800)
|
||||
(define-win-constant *FR_NOUPDOWN* #x00000400)
|
||||
(define-win-constant *FR_NOWHOLEWORD* #x00001000)
|
||||
(define-win-constant *FR_REPLACE* #x00000010)
|
||||
(define-win-constant *FR_REPLACEALL* #x00000020)
|
||||
(define-win-constant *FR_SHOWHELP* #x00000080)
|
||||
(define-win-constant *FR_WHOLEWORD* #x00000002)
|
||||
|
||||
(defconstant *NULL* (make-null-pointer :void))
|
||||
|
||||
;; Windows structures
|
||||
|
||||
(def-struct WNDCLASS
|
||||
(style :unsigned-int)
|
||||
(lpfnWndProc WNDPROC)
|
||||
(cbClsExtra :int)
|
||||
(cbWndExtra :int)
|
||||
(hInstance HANDLE)
|
||||
(hIcon HANDLE)
|
||||
(hCursor HANDLE)
|
||||
(hbrBackground HANDLE)
|
||||
(lpszMenuName :cstring)
|
||||
(lpszClassName :cstring))
|
||||
(style :unsigned-int)
|
||||
(lpfnWndProc WNDPROC)
|
||||
(cbClsExtra :int)
|
||||
(cbWndExtra :int)
|
||||
(hInstance HANDLE)
|
||||
(hIcon HANDLE)
|
||||
(hCursor HANDLE)
|
||||
(hbrBackground HANDLE)
|
||||
(lpszMenuName :cstring)
|
||||
(lpszClassName :cstring))
|
||||
(defun make-wndclass (name &key (style 0) (lpfnWndProc nil) (cbClsExtra 0) (cbWndExtra 0) (hInstance *NULL*)
|
||||
(hIcon (default-icon)) (hCursor (default-cursor)) (hbrBackground (default-background))
|
||||
(lpszMenuName ""))
|
||||
(hIcon (default-icon)) (hCursor (default-cursor)) (hbrBackground (default-background))
|
||||
(lpszMenuName ""))
|
||||
(with-foreign-object (cls 'WNDCLASS)
|
||||
(setf (get-slot-value cls 'WNDCLASS 'style) style
|
||||
(get-slot-value cls 'WNDCLASS 'lpfnWndProc) (callback 'wndproc-proxy)
|
||||
(get-slot-value cls 'WNDCLASS 'cbClsExtra) cbClsExtra
|
||||
(get-slot-value cls 'WNDCLASS 'cbWndExtra) cbWndExtra
|
||||
(get-slot-value cls 'WNDCLASS 'hInstance) hInstance
|
||||
(get-slot-value cls 'WNDCLASS 'hIcon) hIcon
|
||||
(get-slot-value cls 'WNDCLASS 'hCursor) hCursor
|
||||
(get-slot-value cls 'WNDCLASS 'hbrBackground) hbrBackground
|
||||
(get-slot-value cls 'WNDCLASS 'lpszMenuName) lpszMenuName
|
||||
(get-slot-value cls 'WNDCLASS 'lpszClassName) (string name))
|
||||
(get-slot-value cls 'WNDCLASS 'lpfnWndProc) (callback 'wndproc-proxy)
|
||||
(get-slot-value cls 'WNDCLASS 'cbClsExtra) cbClsExtra
|
||||
(get-slot-value cls 'WNDCLASS 'cbWndExtra) cbWndExtra
|
||||
(get-slot-value cls 'WNDCLASS 'hInstance) hInstance
|
||||
(get-slot-value cls 'WNDCLASS 'hIcon) hIcon
|
||||
(get-slot-value cls 'WNDCLASS 'hCursor) hCursor
|
||||
(get-slot-value cls 'WNDCLASS 'hbrBackground) hbrBackground
|
||||
(get-slot-value cls 'WNDCLASS 'lpszMenuName) lpszMenuName
|
||||
(get-slot-value cls 'WNDCLASS 'lpszClassName) (string name))
|
||||
(register-wndproc (string name) lpfnWndProc)
|
||||
(registerclass cls)))
|
||||
(def-struct POINT
|
||||
(x :int)
|
||||
(y :int))
|
||||
(x :int)
|
||||
(y :int))
|
||||
(def-struct MSG
|
||||
(hwnd HANDLE)
|
||||
(message :unsigned-int)
|
||||
(wParam :unsigned-int)
|
||||
(lParam :int)
|
||||
(time :unsigned-int)
|
||||
(pt POINT))
|
||||
(hwnd HANDLE)
|
||||
(message :unsigned-int)
|
||||
(wParam :unsigned-int)
|
||||
(lParam :int)
|
||||
(time :unsigned-int)
|
||||
(pt POINT))
|
||||
(def-struct CREATESTRUCT
|
||||
(lpCreateParams :pointer-void)
|
||||
(hInstance HANDLE)
|
||||
(hMenu HANDLE)
|
||||
(hwndParent HANDLE)
|
||||
(cx :int)
|
||||
(cy :int)
|
||||
(x :int)
|
||||
(y :int)
|
||||
(style :long)
|
||||
(lpszName :cstring)
|
||||
(lpszClass :cstring)
|
||||
(dwExStyle :unsigned-int))
|
||||
(lpCreateParams :pointer-void)
|
||||
(hInstance HANDLE)
|
||||
(hMenu HANDLE)
|
||||
(hwndParent HANDLE)
|
||||
(cx :int)
|
||||
(cy :int)
|
||||
(x :int)
|
||||
(y :int)
|
||||
(style :long)
|
||||
(lpszName :cstring)
|
||||
(lpszClass :cstring)
|
||||
(dwExStyle :unsigned-int))
|
||||
(def-struct MINMAXINFO
|
||||
(ptReserved POINT)
|
||||
(ptMaxSize POINT)
|
||||
(ptMaxPosition POINT)
|
||||
(ptMinTrackSize POINT)
|
||||
(ptMaxTrackSize POINT))
|
||||
(ptReserved POINT)
|
||||
(ptMaxSize POINT)
|
||||
(ptMaxPosition POINT)
|
||||
(ptMinTrackSize POINT)
|
||||
(ptMaxTrackSize POINT))
|
||||
(def-struct TEXTMETRIC (tmHeight :long) (tmAscent :long) (tmDescent :long) (tmInternalLeading :long) (tmExternalLeading :long)
|
||||
(tmAveCharWidth :long) (tmMaxCharWidth :long) (tmWeight :long) (tmOverhang :long) (tmDigitizedAspectX :long)
|
||||
(tmDigitizedAspectY :long) (tmFirstChar :char) (tmLastChar :char) (tmDefaultChar :char) (tmBreakChar :char)
|
||||
(tmItalic :byte) (tmUnderlined :byte) (tmStruckOut :byte) (tmPitchAndFamily :byte) (tmCharSet :byte))
|
||||
(tmAveCharWidth :long) (tmMaxCharWidth :long) (tmWeight :long) (tmOverhang :long) (tmDigitizedAspectX :long)
|
||||
(tmDigitizedAspectY :long) (tmFirstChar :char) (tmLastChar :char) (tmDefaultChar :char) (tmBreakChar :char)
|
||||
(tmItalic :byte) (tmUnderlined :byte) (tmStruckOut :byte) (tmPitchAndFamily :byte) (tmCharSet :byte))
|
||||
(def-struct SIZE (cx :long) (cy :long))
|
||||
(def-struct RECT (left :long) (top :long) (right :long) (bottom :long))
|
||||
(def-struct TITLEBARINFO (cbSize :unsigned-int) (rcTitlebar RECT) (rgstate (:array :unsigned-int 6)))
|
||||
(def-struct OPENFILENAME (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (lpstrFilter LPCSTR) (lpstrCustomFilter LPCSTR)
|
||||
(nMaxFilter :unsigned-int) (nFilterIndex :unsigned-int) (lpstrFile LPCSTR) (nMaxFile :unsigned-int) (lpstrFileTitle LPCSTR)
|
||||
(nMaxFileTitle :unsigned-int) (lpstrInitialDir LPCSTR) (lpstrTitle LPCSTR) (Flags :unsigned-int) (nFileOffset :unsigned-short)
|
||||
(nFileExtension :unsigned-short) (lpstrDefExt LPCSTR) (lCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR)
|
||||
#|(pvReserved :pointer-void) (dwReserved :unsigned-int) (FlagsEx :unsigned-int)|#)
|
||||
(nMaxFilter :unsigned-int) (nFilterIndex :unsigned-int) (lpstrFile LPCSTR) (nMaxFile :unsigned-int) (lpstrFileTitle LPCSTR)
|
||||
(nMaxFileTitle :unsigned-int) (lpstrInitialDir LPCSTR) (lpstrTitle LPCSTR) (Flags :unsigned-int) (nFileOffset :unsigned-short)
|
||||
(nFileExtension :unsigned-short) (lpstrDefExt LPCSTR) (lCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR)
|
||||
#|(pvReserved :pointer-void) (dwReserved :unsigned-int) (FlagsEx :unsigned-int)|#)
|
||||
(def-struct ACCEL (fVirt :byte) (key :unsigned-short) (cmd :unsigned-short))
|
||||
(def-struct TCITEM (mask :unsigned-int) (dwState :unsigned-int) (dwStateMask :unsigned-int)
|
||||
(pszText :cstring) (cchTextMax :int) (iImage :int) (lParam :long))
|
||||
(pszText :cstring) (cchTextMax :int) (iImage :int) (lParam :long))
|
||||
(def-struct NMHDR (hwndFrom HANDLE) (idFrom :unsigned-int) (code :unsigned-int))
|
||||
(def-struct TCHITTESTINFO (pt POINT) (flag :unsigned-int))
|
||||
(def-struct TPMPARAMS (cbSize :unsigned-int) (rcExclude RECT))
|
||||
(def-struct FINDREPLACE (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (Flags DWORD)
|
||||
(lpstrFindWhat LPCSTR) (lpstrReplaceWith LPCSTR) (wFindWhatLen WORD) (wReplaceWithLen WORD)
|
||||
(lpCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR))
|
||||
(lpstrFindWhat LPCSTR) (lpstrReplaceWith LPCSTR) (wFindWhatLen WORD) (wReplaceWithLen WORD)
|
||||
(lpCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR))
|
||||
|
||||
;; Windows functions
|
||||
|
||||
|
|
@ -337,9 +337,9 @@
|
|||
old-proc)))
|
||||
(defun get-wndproc (obj)
|
||||
(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
|
||||
(cdr entry))))
|
||||
(cdr entry))))
|
||||
(defcallback (wndproc-proxy :stdcall) :int ((hnd :pointer-void) (umsg :unsigned-int) (wparam :unsigned-int) (lparam :int))
|
||||
(let* ((wndproc (get-wndproc hnd)))
|
||||
(unless wndproc
|
||||
|
|
@ -395,16 +395,16 @@
|
|||
(with-foreign-object (s `(:array :char ,max-length))
|
||||
(let ((n (getclassname-i hnd s max-length)))
|
||||
(when (= n 0)
|
||||
(error "Unable to get class name for ~A" hnd))
|
||||
(error "Unable to get class name for ~A" hnd))
|
||||
(convert-from-foreign-string s :length n))))
|
||||
(def-win32-function ("RegisterClassA" registerclass) ((lpWndClass (* WNDCLASS))) :returning :int :module "user32")
|
||||
(def-win32-function ("UnregisterClassA" unregisterclass) ((lpClassName :cstring) (hInstance HANDLE)) :returning :int :module "user32")
|
||||
(def-win32-function ("GetWindowLongA" getwindowlong) ((hWnd HANDLE) (nIndex :int)) :returning :long :module "user32")
|
||||
(def-win32-function ("SetWindowLongA" setwindowlong) ((hWnd HANDLE) (nIndex :int) (dwNewLong :long)) :returning :long :module "user32")
|
||||
(def-win32-function ("CreateWindowExA" createwindowex) ((dwExStyle :unsigned-int) (lpClassName :cstring) (lpWindowName :cstring) (dwStyle :unsigned-int)
|
||||
(x :int) (y :int) (nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE)
|
||||
(lpParam :pointer-void))
|
||||
:returning HANDLE :module "user32")
|
||||
(x :int) (y :int) (nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE)
|
||||
(lpParam :pointer-void))
|
||||
:returning HANDLE :module "user32")
|
||||
(defun createwindow (&rest args)
|
||||
(apply #'createwindowex 0 args))
|
||||
(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 ("MoveWindow" movewindow) ((hWnd HANDLE) (x :int) (y :int) (nWidth :int) (nHeight :int) (bRepaint :int)) :returning :int :module "user32")
|
||||
(def-win32-function ("SetWindowPos" setwindowpos) ((hWnd HANDLE) (hWndInsertAfter HANDLE) (x :int)
|
||||
(y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int :module "user32")
|
||||
(y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int :module "user32")
|
||||
(def-win32-function ("BringWindowToTop" bringwindowtotop) ((hWnd HANDLE)) :returning :int :module "user32")
|
||||
(def-win32-function ("GetWindowTextA" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int :module "user32")
|
||||
(defun getwindowtext (hnd)
|
||||
|
|
@ -461,9 +461,9 @@
|
|||
(def-win32-function ("CheckMenuItem" checkmenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32")
|
||||
(def-win32-function ("EnableMenuItem" enablemenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32")
|
||||
(def-win32-function ("TrackPopupMenu" trackpopupmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (x :int) (y :int)
|
||||
(nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32")
|
||||
(nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32")
|
||||
(def-win32-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int)
|
||||
(hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32")
|
||||
(hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32")
|
||||
(def-win32-function ("CreateAcceleratorTableA" createacceleratortable) ((lpaccl (* ACCEL)) (cEntries :int)) :returning HANDLE :module "user32")
|
||||
(def-win32-function ("TranslateAcceleratorA" translateaccelerator) ((hWnd HANDLE) (hAccTable HANDLE) (lpMsg (* MSG))) :returning :int :module "user32")
|
||||
(def-win32-function ("DestroyAcceleratorTable" destroyacceleratortable) ((hAccTable HANDLE)) :returning :int :module "user32")
|
||||
|
|
@ -472,19 +472,19 @@
|
|||
(defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*) (dlgSym nil))
|
||||
(with-foreign-object (msg 'MSG)
|
||||
(loop for bRet = (getmessage msg *NULL* 0 0)
|
||||
when (= bRet 0) return bRet
|
||||
if (= bRet -1)
|
||||
do (error "GetMessage failed!!!")
|
||||
else
|
||||
do (or (and (not (null-pointer-p accelTable))
|
||||
(not (null-pointer-p accelMain))
|
||||
(/= (translateaccelerator accelMain accelTable msg) 0))
|
||||
(and dlgSym
|
||||
(not (null-pointer-p (symbol-value dlgSym)))
|
||||
(/= (isdialogmessage (symbol-value dlgSym) msg) 0))
|
||||
(progn
|
||||
(translatemessage msg)
|
||||
(dispatchmessage msg))))))
|
||||
when (= bRet 0) return bRet
|
||||
if (= bRet -1)
|
||||
do (error "GetMessage failed!!!")
|
||||
else
|
||||
do (or (and (not (null-pointer-p accelTable))
|
||||
(not (null-pointer-p accelMain))
|
||||
(/= (translateaccelerator accelMain accelTable msg) 0))
|
||||
(and dlgSym
|
||||
(not (null-pointer-p (symbol-value dlgSym)))
|
||||
(/= (isdialogmessage (symbol-value dlgSym) msg) 0))
|
||||
(progn
|
||||
(translatemessage msg)
|
||||
(dispatchmessage msg))))))
|
||||
|
||||
(defun y-or-no-p (&optional control &rest args)
|
||||
(let ((s (coerce (apply #'format nil control args) 'simple-string)))
|
||||
|
|
@ -492,24 +492,24 @@
|
|||
*IDYES*)))
|
||||
|
||||
(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))))
|
||||
(concatenate 'string xx (string #\Null) yy)))
|
||||
(concatenate 'string xx (string #\Null) yy)))
|
||||
(when filter
|
||||
(setq filter (format nil "~A~C~C" (reduce #'null-concat (mapcar #'null-concat filter)) #\Null #\Null)))
|
||||
(with-foreign-object (ofn 'OPENFILENAME)
|
||||
(with-cstrings ((fn (make-string max-fn-size :initial-element #\Null))
|
||||
(filter filter))
|
||||
(filter filter))
|
||||
(zeromemory ofn (size-of-foreign-type 'OPENFILENAME))
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'lStructSize) (size-of-foreign-type 'OPENFILENAME))
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'hwndOwner) owner)
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'lpstrFile) fn)
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'nMaxFile) max-fn-size)
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'Flags) flags)
|
||||
(when filter
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'lpstrFilter) filter))
|
||||
(unless (= (funcall dlgfn ofn) 0)
|
||||
(pathname (string-trim (string #\Null) fn)))))))
|
||||
(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 'lpstrFile) fn)
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'nMaxFile) max-fn-size)
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'Flags) flags)
|
||||
(when filter
|
||||
(setf (get-slot-value ofn 'OPENFILENAME 'lpstrFilter) filter))
|
||||
(unless (= (funcall dlgfn ofn) 0)
|
||||
(pathname (string-trim (string #\Null) fn)))))))
|
||||
|
||||
(defun find-text (&key (owner *NULL*) &aux (max-txt-size 1024))
|
||||
(with-foreign-object (fr 'FINDREPLACE)
|
||||
|
|
@ -520,13 +520,13 @@
|
|||
(setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) max-txt-size)
|
||||
;(setf (get-slot-value fr 'FINDREPLACE 'Flags) 1)
|
||||
(let ((result (findtext fr)))
|
||||
(print result)
|
||||
txt))))
|
||||
(print result)
|
||||
txt))))
|
||||
|
||||
#|
|
||||
(defun set-wndproc (obj fun)
|
||||
(let ((cb (si:make-dynamic-callback fun (read-from-string (format nil "~A-WNDPROC" (gensym))) :int '(:pointer-void :unsigned-int :unsigned-int :int)))
|
||||
(old-wndproc (make-pointer (getwindowlong obj *GWL_WNDPROC*) 'HANDLE)))
|
||||
(old-wndproc (make-pointer (getwindowlong obj *GWL_WNDPROC*) 'HANDLE)))
|
||||
(setwindowlong obj *GWL_WNDPROC* (make-lparam cb))
|
||||
old-wndproc))
|
||||
|#
|
||||
|
|
@ -543,17 +543,17 @@
|
|||
|
||||
(defun button-min-size (hnd)
|
||||
(let ((fnt (make-pointer (sendmessage hnd *WM_GETFONT* 0 0) :pointer-void))
|
||||
(hdc (getdc hnd))
|
||||
(txt (getwindowtext hnd)))
|
||||
(hdc (getdc hnd))
|
||||
(txt (getwindowtext hnd)))
|
||||
(unless (null-pointer-p fnt)
|
||||
(selectobject hdc fnt))
|
||||
(with-foreign-objects ((sz 'SIZE)
|
||||
(tm 'TEXTMETRIC))
|
||||
(tm 'TEXTMETRIC))
|
||||
(gettextextentpoint32 hdc txt (length txt) sz)
|
||||
(gettextmetrics hdc tm)
|
||||
(releasedc hnd hdc)
|
||||
(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)
|
||||
(with-foreign-object (ti 'TITLEBARINFO)
|
||||
|
|
@ -561,74 +561,74 @@
|
|||
(gettitlebarinfo hnd ti)
|
||||
(let ((rc (get-slot-value ti 'TITLEBARINFO 'rcTitlebar)))
|
||||
(list (get-slot-value rc 'RECT 'left)
|
||||
(get-slot-value rc 'RECT 'top)
|
||||
(get-slot-value rc 'RECT 'right)
|
||||
(get-slot-value rc 'RECT 'bottom)))))
|
||||
(get-slot-value rc 'RECT 'top)
|
||||
(get-slot-value rc 'RECT 'right)
|
||||
(get-slot-value rc 'RECT 'bottom)))))
|
||||
|
||||
(defun test-wndproc (hwnd umsg wparam lparam)
|
||||
(cond ((= umsg *WM_DESTROY*)
|
||||
(setq hBtn nil hOk nil)
|
||||
(postquitmessage 0)
|
||||
0)
|
||||
((= umsg *WM_CREATE*)
|
||||
(setq hBtn (createwindowex 0 "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
|
||||
0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*))
|
||||
(setq hOk (createwindowex 0 "BUTTON" "Close" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
|
||||
0 0 50 20 hwnd (make-ID *OK_ID*) *NULL* *NULL*))
|
||||
(sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
|
||||
(sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
|
||||
0)
|
||||
((= umsg *WM_SIZE*)
|
||||
(let* ((new-w (loword lparam))
|
||||
(new-h (hiword lparam))
|
||||
(wb (- new-w 20))
|
||||
(hb (/ (- new-h 30) 2)))
|
||||
(movewindow hBtn 10 10 wb hb *TRUE*)
|
||||
(movewindow hOk 10 (+ 20 hb) wb hb *TRUE*))
|
||||
0)
|
||||
((= umsg *WM_GETMINMAXINFO*)
|
||||
(let* ((btn1-sz (and hBtn (button-min-size hBtn)))
|
||||
(btn2-sz (and hOk (button-min-size hOk)))
|
||||
#|(rc (get-titlebar-rect hWnd))|#
|
||||
(titleH #|(1+ (- (fourth rc) (second rc)))|# 30))
|
||||
(when (and btn1-sz btn2-sz (> titleH 0))
|
||||
(with-foreign-object (minSz 'POINT)
|
||||
(setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20))
|
||||
(setf (get-slot-value minSz 'POINT 'y) (+ (second btn1-sz) (second btn2-sz) 30 titleH))
|
||||
(with-cast-int-pointer (lparam MINMAXINFO)
|
||||
(setf (get-slot-value lparam 'MINMAXINFO 'ptMinTrackSize) minSz)))))
|
||||
0)
|
||||
((= umsg *WM_COMMAND*)
|
||||
(let ((n (hiword wparam))
|
||||
(id (loword wparam)))
|
||||
(cond ((= n *BN_CLICKED*)
|
||||
(cond ((= id *HELLO_ID*)
|
||||
(format t "~&Hellow World!~%")
|
||||
(get-open-filename :owner hwnd))
|
||||
((= id *OK_ID*)
|
||||
(destroywindow hwnd))))
|
||||
(t
|
||||
(format t "~&Un-handled notification: ~D~%" n))))
|
||||
0)
|
||||
(t
|
||||
(defwindowproc hwnd umsg wparam lparam))))
|
||||
(setq hBtn nil hOk nil)
|
||||
(postquitmessage 0)
|
||||
0)
|
||||
((= umsg *WM_CREATE*)
|
||||
(setq hBtn (createwindowex 0 "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
|
||||
0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*))
|
||||
(setq hOk (createwindowex 0 "BUTTON" "Close" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
|
||||
0 0 50 20 hwnd (make-ID *OK_ID*) *NULL* *NULL*))
|
||||
(sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
|
||||
(sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
|
||||
0)
|
||||
((= umsg *WM_SIZE*)
|
||||
(let* ((new-w (loword lparam))
|
||||
(new-h (hiword lparam))
|
||||
(wb (- new-w 20))
|
||||
(hb (/ (- new-h 30) 2)))
|
||||
(movewindow hBtn 10 10 wb hb *TRUE*)
|
||||
(movewindow hOk 10 (+ 20 hb) wb hb *TRUE*))
|
||||
0)
|
||||
((= umsg *WM_GETMINMAXINFO*)
|
||||
(let* ((btn1-sz (and hBtn (button-min-size hBtn)))
|
||||
(btn2-sz (and hOk (button-min-size hOk)))
|
||||
#|(rc (get-titlebar-rect hWnd))|#
|
||||
(titleH #|(1+ (- (fourth rc) (second rc)))|# 30))
|
||||
(when (and btn1-sz btn2-sz (> titleH 0))
|
||||
(with-foreign-object (minSz 'POINT)
|
||||
(setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20))
|
||||
(setf (get-slot-value minSz 'POINT 'y) (+ (second btn1-sz) (second btn2-sz) 30 titleH))
|
||||
(with-cast-int-pointer (lparam MINMAXINFO)
|
||||
(setf (get-slot-value lparam 'MINMAXINFO 'ptMinTrackSize) minSz)))))
|
||||
0)
|
||||
((= umsg *WM_COMMAND*)
|
||||
(let ((n (hiword wparam))
|
||||
(id (loword wparam)))
|
||||
(cond ((= n *BN_CLICKED*)
|
||||
(cond ((= id *HELLO_ID*)
|
||||
(format t "~&Hellow World!~%")
|
||||
(get-open-filename :owner hwnd))
|
||||
((= id *OK_ID*)
|
||||
(destroywindow hwnd))))
|
||||
(t
|
||||
(format t "~&Un-handled notification: ~D~%" n))))
|
||||
0)
|
||||
(t
|
||||
(defwindowproc hwnd umsg wparam lparam))))
|
||||
|
||||
(defun do-test ()
|
||||
(make-wndclass "MyClass"
|
||||
:lpfnWndProc #'test-wndproc)
|
||||
(let* ((hwnd (createwindowex
|
||||
0
|
||||
"MyClass"
|
||||
"ECL/Win32 test"
|
||||
*WS_OVERLAPPEDWINDOW*
|
||||
*CW_USEDEFAULT*
|
||||
*CW_USEDEFAULT*
|
||||
130
|
||||
120
|
||||
*NULL*
|
||||
*NULL*
|
||||
*NULL*
|
||||
*NULL*)))
|
||||
0
|
||||
"MyClass"
|
||||
"ECL/Win32 test"
|
||||
*WS_OVERLAPPEDWINDOW*
|
||||
*CW_USEDEFAULT*
|
||||
*CW_USEDEFAULT*
|
||||
130
|
||||
120
|
||||
*NULL*
|
||||
*NULL*
|
||||
*NULL*
|
||||
*NULL*)))
|
||||
(when (si::null-pointer-p hwnd)
|
||||
(error "Unable to create window"))
|
||||
(showwindow hwnd *SW_SHOWNORMAL*)
|
||||
|
|
|
|||
|
|
@ -92,5 +92,5 @@ Executing standalone file 'example'
|
|||
;;;
|
||||
|
||||
(mapc #'delete-file (append (directory "*.o")
|
||||
(directory "*.obj")
|
||||
(directory "example-mono*")))
|
||||
(directory "*.obj")
|
||||
(directory "example-mono*")))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; See file '../Copyright' for full details.
|
||||
;;; See file '../Copyright' for full details.
|
||||
|
||||
(ffi::clines "extern const char *hello_string;")
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
* License as published by the Free Software Foundation; either
|
||||
* version 2 of the License, or (at your option) any later version.
|
||||
*
|
||||
* See file '../Copyright' for full details.
|
||||
* See file '../Copyright' for full details.
|
||||
*/
|
||||
|
||||
const char *hello_string = "Hello world!";
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; See file '../Copyright' for full details.
|
||||
;;; See file '../Copyright' for full details.
|
||||
|
||||
;;;
|
||||
;;; DESCRIPTION:
|
||||
|
|
@ -14,15 +14,15 @@
|
|||
;;; file called hello_aux.c. Both hello.lisp and hello_aux.c are
|
||||
;;; compiled and linked into either
|
||||
;;;
|
||||
;;; 1) a FASL file (see build_fasl.lisp)
|
||||
;;; 2) a shared library (see build_dll.lisp)
|
||||
;;; 3) or a standalone executable file. (build_exe.lisp)
|
||||
;;; 1) a FASL file (see build_fasl.lisp)
|
||||
;;; 2) a shared library (see build_dll.lisp)
|
||||
;;; 3) or a standalone executable file. (build_exe.lisp)
|
||||
;;;
|
||||
;;; USE:
|
||||
;;;
|
||||
;;; Launch a copy of ECL and load this file in it
|
||||
;;;
|
||||
;;; (load "readme.lisp")
|
||||
;;; (load "readme.lisp")
|
||||
;;;
|
||||
|
||||
(format t "
|
||||
|
|
@ -46,10 +46,10 @@
|
|||
(defconstant +compound-fasl+ (compile-file-pathname "compound" :type :fasl))
|
||||
|
||||
(c::build-fasl +compound-fasl+
|
||||
:lisp-files
|
||||
(list (compile-file-pathname "hello.lisp" :type :object))
|
||||
:ld-flags
|
||||
(list (namestring (compile-file-pathname "hello_aux.c" :type :object))))
|
||||
:lisp-files
|
||||
(list (compile-file-pathname "hello.lisp" :type :object))
|
||||
:ld-flags
|
||||
(list (namestring (compile-file-pathname "hello_aux.c" :type :object))))
|
||||
|
||||
;;;
|
||||
;;; * We load both files
|
||||
|
|
@ -73,12 +73,12 @@
|
|||
(defconstant +standalone-exe+ (compile-file-pathname "standalone" :type :program))
|
||||
|
||||
(c::build-program +standalone-exe+
|
||||
:lisp-files
|
||||
(list (compile-file-pathname "hello.lisp" :type :object))
|
||||
:ld-flags
|
||||
(list (namestring (compile-file-pathname "hello_aux.c" :type :object)))
|
||||
:epilogue-code
|
||||
'(si::quit))
|
||||
:lisp-files
|
||||
(list (compile-file-pathname "hello.lisp" :type :object))
|
||||
:ld-flags
|
||||
(list (namestring (compile-file-pathname "hello_aux.c" :type :object)))
|
||||
:epilogue-code
|
||||
'(si::quit))
|
||||
|
||||
;;
|
||||
;; * Test the program
|
||||
|
|
|
|||
|
|
@ -18,13 +18,13 @@
|
|||
#include <pthread.h>
|
||||
|
||||
/*
|
||||
* GOAL: To execute lisp code from threads which have not
|
||||
* been generated by our lisp environment.
|
||||
* GOAL: To execute lisp code from threads which have not
|
||||
* been generated by our lisp environment.
|
||||
*
|
||||
* ASSUMES: ECL has been configured with threads (--enable-threads)
|
||||
* and installed somewhere on the path.
|
||||
* ASSUMES: ECL has been configured with threads (--enable-threads)
|
||||
* 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
|
||||
|
|
@ -51,70 +51,70 @@
|
|||
static void *
|
||||
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.
|
||||
* These threads have no valid lisp environment. The following
|
||||
* routine initializes the lisp and makes it ready for working
|
||||
* in this thread.
|
||||
*/
|
||||
ecl_import_current_thread(Cnil, Cnil);
|
||||
/*
|
||||
* This is the entry point of the threads we have created.
|
||||
* These threads have no valid lisp environment. The following
|
||||
* routine initializes the lisp and makes it ready for working
|
||||
* in this thread.
|
||||
*/
|
||||
ecl_import_current_thread(Cnil, Cnil);
|
||||
|
||||
/*
|
||||
* Here we execute some lisp code code.
|
||||
*/
|
||||
cl_eval(form);
|
||||
/*
|
||||
* Here we execute some lisp code code.
|
||||
*/
|
||||
cl_eval(form);
|
||||
|
||||
/*
|
||||
* Finally, when we exit the thread we have to release the
|
||||
* resources allocated by the lisp environment.
|
||||
*/
|
||||
ecl_release_current_thread();
|
||||
return NULL;
|
||||
/*
|
||||
* Finally, when we exit the thread we have to release the
|
||||
* resources allocated by the lisp environment.
|
||||
*/
|
||||
ecl_release_current_thread();
|
||||
return NULL;
|
||||
}
|
||||
|
||||
|
||||
int main(int narg, char **argv)
|
||||
{
|
||||
pthread_t child_thread;
|
||||
int i, code;
|
||||
pthread_t child_thread;
|
||||
int i, code;
|
||||
|
||||
/*
|
||||
* First of all, we have to initialize the ECL environment.
|
||||
* This should be done from the main thread.
|
||||
*/
|
||||
cl_boot(narg, argv);
|
||||
/*
|
||||
* First of all, we have to initialize the ECL environment.
|
||||
* This should be done from the main thread.
|
||||
*/
|
||||
cl_boot(narg, argv);
|
||||
|
||||
/*
|
||||
* Here we spawn 10 threads using the OS functions. The
|
||||
* current version is for Unix and uses pthread_create.
|
||||
* Since we have included <gc.h>, pthread_create will be
|
||||
* replaced with the appropiate routine from the garbage
|
||||
* collector.
|
||||
*/
|
||||
cl_object sym_print = c_string_to_object("PRINT");
|
||||
/*
|
||||
* Here we spawn 10 threads using the OS functions. The
|
||||
* current version is for Unix and uses pthread_create.
|
||||
* Since we have included <gc.h>, pthread_create will be
|
||||
* replaced with the appropiate routine from the garbage
|
||||
* collector.
|
||||
*/
|
||||
cl_object sym_print = c_string_to_object("PRINT");
|
||||
|
||||
/*
|
||||
* This array will keep the forms we want to evaluate from
|
||||
* being garbage collected.
|
||||
*/
|
||||
volatile cl_object forms[4];
|
||||
/*
|
||||
* This array will keep the forms we want to evaluate from
|
||||
* being garbage collected.
|
||||
*/
|
||||
volatile cl_object forms[4];
|
||||
|
||||
for (i = 0; i < 4; i++) {
|
||||
forms[i] = cl_list(2, sym_print, MAKE_FIXNUM(i));
|
||||
code = pthread_create(&child_thread, NULL, thread_entry_point,
|
||||
(void*)forms[i]);
|
||||
if (code) {
|
||||
printf("Unable to create thread\n");
|
||||
exit(1);
|
||||
}
|
||||
}
|
||||
for (i = 0; i < 4; i++) {
|
||||
forms[i] = cl_list(2, sym_print, MAKE_FIXNUM(i));
|
||||
code = pthread_create(&child_thread, NULL, thread_entry_point,
|
||||
(void*)forms[i]);
|
||||
if (code) {
|
||||
printf("Unable to create thread\n");
|
||||
exit(1);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Here we wait for the last thread to finish.
|
||||
*/
|
||||
pthread_join(child_thread, NULL);
|
||||
/*
|
||||
* Here we wait for the last thread to finish.
|
||||
*/
|
||||
pthread_join(child_thread, NULL);
|
||||
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -20,13 +20,13 @@
|
|||
#endif
|
||||
|
||||
/*
|
||||
* GOAL: To execute lisp code from threads which have not
|
||||
* been generated by our lisp environment.
|
||||
* GOAL: To execute lisp code from threads which have not
|
||||
* been generated by our lisp environment.
|
||||
*
|
||||
* ASSUMES: ECL has been configured with threads (--enable-threads)
|
||||
* and installed somewhere on the path.
|
||||
* ASSUMES: ECL has been configured with threads (--enable-threads)
|
||||
* 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
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
#define SUCCESS 1
|
||||
|
||||
#ifdef FD_SETSIZE
|
||||
#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */
|
||||
#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */
|
||||
#else
|
||||
#define NUMBER_OF_FDS 32
|
||||
#endif
|
||||
|
|
@ -45,8 +45,8 @@ int fd_wait_for_input(fd, timeout)
|
|||
int checkfds[CHECKLEN];
|
||||
|
||||
if (fd < 0 || fd >= NUMBER_OF_FDS) {
|
||||
fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd);
|
||||
fflush(stderr);
|
||||
fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd);
|
||||
fflush(stderr);
|
||||
}
|
||||
|
||||
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)));
|
||||
|
||||
if (timeout) {
|
||||
timer.tv_sec = timeout;
|
||||
timer.tv_usec = 0;
|
||||
i = select(32, checkfds, (int *)0, (int *)0, &timer);
|
||||
timer.tv_sec = timeout;
|
||||
timer.tv_usec = 0;
|
||||
i = select(32, checkfds, (int *)0, (int *)0, &timer);
|
||||
} else
|
||||
i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0);
|
||||
|
||||
if (i < 0)
|
||||
/* error condition */
|
||||
if (errno == EINTR)
|
||||
return (INTERRUPT);
|
||||
return (INTERRUPT);
|
||||
else
|
||||
return (ERROR);
|
||||
return (ERROR);
|
||||
else if (i == 0)
|
||||
return (TIMEOUT);
|
||||
else
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue