#: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")
;;; from a grammar and then compile parser. To do this one
;;; would create a module with components that looked
;;; something like this:
-;;; ((:module cc :components ("compiler-compiler"))
-;;; (:module gr :compiler 'cc :loader #'ignore
-;;; :source-extension "gra"
-;;; :binary-extension "lisp"
-;;; :depends-on (cc)
-;;; :components ("sample-grammar"))
-;;; (:module parser :depends-on (gr)
-;;; :components ("sample-grammar")))
+;;; ((:module cc :components ("compiler-compiler"))
+;;; (:module gr :compiler 'cc :loader #'ignore
+;;; :source-extension "gra"
+;;; :binary-extension "lisp"
+;;; :depends-on (cc)
+;;; :components ("sample-grammar"))
+;;; (:module parser :depends-on (gr)
+;;; :components ("sample-grammar")))
;;; Defsystem would then compile and load the compiler, use
;;; it (the function cc) to compile the grammar into a parser,
;;; and then compile the parser. The only tricky part is
(and allegro-version>= (version>= 4 1)))
(eval-when #-(or :lucid)
(:compile-toplevel :load-toplevel :execute)
- #+(or :lucid)
+ #+(or :lucid)
(compile load eval)
(unless (or (fboundp 'lisp::require)
- (fboundp 'user::require)
+ (fboundp 'user::require)
- #+(and :excl (and allegro-version>= (version>= 4 0)))
- (fboundp 'cltl1::require)
+ #+(and :excl (and allegro-version>= (version>= 4 0)))
+ (fboundp 'cltl1::require)
- #+:lispworks
- (fboundp 'system::require))
+ #+:lispworks
+ (fboundp 'system::require))
#-:lispworks
(in-package "LISP")
;; their packages -- it is intended that *central-registry* is
;; set by the user, while *library* is set by the lisp.
- (defvar *library* nil ; "/usr/local/lisp/Modules/"
+ (defvar *library* nil ; "/usr/local/lisp/Modules/"
"Directory within the file system containing files, where the name
of a file is the same as the name of the module it contains.")
(defmacro defmodule (name &rest files)
"Defines a module NAME to load the specified FILES in order."
`(setf (gethash (canonicalize-module-name ,name) *module-files*)
- ',files))
+ ',files))
(defun module-files (name)
(gethash name *module-files*))
while symbols are treated like lowercase strings. Returns T if
NAME was not already present, NIL otherwise."
(let ((module (canonicalize-module-name name)))
- (unless (find module *modules* :test #'string=)
- ;; Module not present. Add it and return T to signify that it
- ;; was added.
- (push module *modules*)
- t)))
+ (unless (find module *modules* :test #'string=)
+ ;; Module not present. Add it and return T to signify that it
+ ;; was added.
+ (push module *modules*)
+ t)))
(defun require (name &optional pathname)
"Tests whether a module is already present. If the module is not
it looks in the library directory for a file with name the same
as that of the module. Returns T if it loads the module."
(let ((module (canonicalize-module-name name)))
- (unless (find module *modules* :test #'string=)
- ;; Module is not already present.
- (when (and pathname (not (listp pathname)))
- ;; If there's a pathname or pathnames, ensure that it's a list.
- (setf pathname (list pathname)))
- (unless pathname
- ;; If there's no pathname, try for a defmodule definition.
- (setf pathname (module-files module)))
- (unless pathname
- ;; If there's still no pathname, try the library directory.
- (when *library*
- (setf pathname (concatenate 'string *library* module))
- ;; Test if the file exists.
- ;; We assume that the lisp will default the file type
- ;; appropriately. If it doesn't, use #+".fasl" or some
- ;; such in the concatenate form above.
- (if (probe-file pathname)
- ;; If it exists, ensure we've got a list
- (setf pathname (list pathname))
- ;; If the library file doesn't exist, we don't want
- ;; a load error.
- (setf pathname nil))))
- ;; Now that we've got the list of pathnames, let's load them.
- (dolist (pname pathname t)
- (load pname :verbose nil))))))
+ (unless (find module *modules* :test #'string=)
+ ;; Module is not already present.
+ (when (and pathname (not (listp pathname)))
+ ;; If there's a pathname or pathnames, ensure that it's a list.
+ (setf pathname (list pathname)))
+ (unless pathname
+ ;; If there's no pathname, try for a defmodule definition.
+ (setf pathname (module-files module)))
+ (unless pathname
+ ;; If there's still no pathname, try the library directory.
+ (when *library*
+ (setf pathname (concatenate 'string *library* module))
+ ;; Test if the file exists.
+ ;; We assume that the lisp will default the file type
+ ;; appropriately. If it doesn't, use #+".fasl" or some
+ ;; such in the concatenate form above.
+ (if (probe-file pathname)
+ ;; If it exists, ensure we've got a list
+ (setf pathname (list pathname))
+ ;; If the library file doesn't exist, we don't want
+ ;; a load error.
+ (setf pathname nil))))
+ ;; Now that we've got the list of pathnames, let's load them.
+ (dolist (pname pathname t)
+ (load pname :verbose nil))))))
) ; eval-when
;;; ********************************
;;; For CLtL2 compatible lisps...
#+(and :excl :allegro-v4.0 :cltl2)
(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)
- (:import-from cltl1 *modules* provide require))
+ (:import-from cltl1 *modules* provide require))
;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
;;; In Allegro 4.1, 'provide' and 'require' are not external in
#+:lispworks
(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
- (:import-from system *modules* provide require)
- (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
- "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"))
+ (:import-from system *modules* provide require)
+ (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
+ "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"))
#+:mcl
(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
;;; believe this is wrong, since CMUCL comes with its own defpackage.
;;; I added the extra :CMU in the 'or'.
#+(and :cltl2 (not (or :cmu :clisp :sbcl
- (and :excl (or :allegro-v4.0 :allegro-v4.1))
- :mcl)))
+ (and :excl (or :allegro-v4.0 :allegro-v4.1))
+ :mcl)))
(eval-when (compile load eval)
(unless (find-package "MAKE")
(make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))))
#+cormanlisp
(defun compile-file-pathname (pathname-designator)
(merge-pathnames (make-pathname :type "fasl")
- (etypecase pathname-designator
- (pathname pathname-designator)
- (string (parse-namestring pathname-designator))
- ;; We need FILE-STREAM here as well.
- )))
+ (etypecase pathname-designator
+ (pathname pathname-designator)
+ (string (parse-namestring pathname-designator))
+ ;; We need FILE-STREAM here as well.
+ )))
#+cormanlisp
(defun file-namestring (pathname-designator)
(let ((p (etypecase pathname-designator
- (pathname pathname-designator)
- (string (parse-namestring pathname-designator))
- ;; We need FILE-STREAM here as well.
- )))
+ (pathname pathname-designator)
+ (string (parse-namestring pathname-designator))
+ ;; We need FILE-STREAM here as well.
+ )))
(namestring (make-pathname :directory ()
- :name (pathname-name p)
- :type (pathname-type p)
- :version (pathname-version p)))))
+ :name (pathname-name p)
+ :type (pathname-type p)
+ :version (pathname-version p)))))
;;; The external interface consists of *exports* and *other-exports*.
#-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
(eval-when (compile load eval)
(import *exports* #-(or :cltl2 :lispworks) "USER"
- #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
+ #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
(import *special-exports* #-(or :cltl2 :lispworks) "USER"
- #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
+ #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
#+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
(eval-when (compile load eval)
(import *exports* #-(or :cltl2 :lispworks) "USER"
- #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
+ #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
(shadowing-import *special-exports*
- #-(or :cltl2 :lispworks) "USER"
- #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
+ #-(or :cltl2 :lispworks) "USER"
+ #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
|#
#-(or :PCL :CLOS :scl)
#-cormanlisp
(defun home-subdirectory (directory)
(concatenate 'string
- #+(or :sbcl :cmu :scl)
- "home:"
- #-(or :sbcl :cmu :scl)
- (let ((homedir (user-homedir-pathname)))
- (or (and homedir (namestring homedir))
- "~/"))
- directory))
+ #+(or :sbcl :cmu :scl)
+ "home:"
+ #-(or :sbcl :cmu :scl)
+ (let ((homedir (user-homedir-pathname)))
+ (or (and homedir (namestring homedir))
+ "~/"))
+ directory))
#+cormanlisp
"This function grabs the value of the DEFSYSPATH environment variable
and breaks the search path into a list of paths."
(remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:)
- :test #'string-equal))
+ :test #'string-equal))
;;; Change this variable to set up the location of a central
;; Same for Allegro.
#+(and :lispworks (not :lispworks4))
,(multiple-value-bind (major minor)
- #-:lispworks-personal-edition
- (system::lispworks-version)
- #+:lispworks-personal-edition
- (values system::*major-version-number*
- system::*minor-version-number*)
+ #-:lispworks-personal-edition
+ (system::lispworks-version)
+ #+:lispworks-personal-edition
+ (values system::*major-version-number*
+ system::*minor-version-number*)
(if (or (> major 3)
- (and (= major 3) (> minor 2))
- (and (= major 3) (= minor 2)
- (equal (lisp-implementation-version) "3.2.1")))
- `(make-pathname :directory
- ,(find-symbol "*CURRENT-WORKING-DIRECTORY*"
- (find-package "SYSTEM")))
+ (and (= major 3) (> minor 2))
+ (and (= major 3) (= minor 2)
+ (equal (lisp-implementation-version) "3.2.1")))
+ `(make-pathname :directory
+ ,(find-symbol "*CURRENT-WORKING-DIRECTORY*"
+ (find-package "SYSTEM")))
(find-symbol "*CURRENT-WORKING-DIRECTORY*"
(find-package "LW"))))
#+:lispworks4
(car `(#+(and Symbolics Lispm) ("lisp" . "bin")
#+(and dec common vax (not ultrix)) ("LSP" . "FAS")
#+(and dec common vax ultrix) ("lsp" . "fas")
- #+ACLPC ("lsp" . "fsl")
- #+CLISP ("lisp" . "fas")
+ #+ACLPC ("lsp" . "fsl")
+ #+CLISP ("lisp" . "fas")
#+KCL ("lsp" . "o")
#+ECL ("lsp" . "fas")
- #+IBCL ("lsp" . "o")
+ #+IBCL ("lsp" . "o")
#+Xerox ("lisp" . "dfasl")
- ;; Lucid on Silicon Graphics
- #+(and Lucid MIPS) ("lisp" . "mbin")
- ;; the entry for (and lucid hp300) must precede
- ;; that of (and lucid mc68000) for hp9000/300's running lucid,
- ;; since *features* on hp9000/300's also include the :mc68000
- ;; feature.
- #+(and lucid hp300) ("lisp" . "6bin")
+ ;; Lucid on Silicon Graphics
+ #+(and Lucid MIPS) ("lisp" . "mbin")
+ ;; the entry for (and lucid hp300) must precede
+ ;; that of (and lucid mc68000) for hp9000/300's running lucid,
+ ;; since *features* on hp9000/300's also include the :mc68000
+ ;; feature.
+ #+(and lucid hp300) ("lisp" . "6bin")
#+(and Lucid MC68000) ("lisp" . "lbin")
#+(and Lucid Vax) ("lisp" . "vbin")
#+(and Lucid Prime) ("lisp" . "pbin")
#+(and Lucid SUNRise) ("lisp" . "sbin")
#+(and Lucid SPARC) ("lisp" . "sbin")
#+(and Lucid :IBM-RT-PC) ("lisp" . "bbin")
- ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
- #+(and Lucid PA) ("lisp" . "hbin")
+ ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
+ #+(and Lucid PA) ("lisp" . "hbin")
#+excl ("cl" . ,(pathname-type (compile-file-pathname "foo.cl")))
#+(or :cmu :scl) ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
-; #+(and :CMU (not (or :sgi :sparc))) ("lisp" . "fasl")
+; #+(and :CMU (not (or :sgi :sparc))) ("lisp" . "fasl")
; #+(and :CMU :sgi) ("lisp" . "sgif")
; #+(and :CMU :sparc) ("lisp" . "sparcf")
- #+PRIME ("lisp" . "pbin")
+ #+PRIME ("lisp" . "pbin")
#+HP ("l" . "b")
#+TI ("lisp" . #.(string (si::local-binary-file-type)))
#+:gclisp ("LSP" . "F2S")
#+pyramid ("clisp" . "o")
- ;; Harlequin LispWorks
- #+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
+ ;; Harlequin LispWorks
+ #+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
; #+(and :sun4 :lispworks) ("lisp" . "wfasl")
; #+(and :mips :lispworks) ("lisp" . "mfasl")
#+:mcl ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
(defun operating-system-version ()
#+(and :sgi :excl)
(let* ((full-version (software-version))
- (blank-pos (search " " full-version))
- (os (subseq full-version 0 blank-pos))
- (version-rest (subseq full-version
- (1+ blank-pos)))
- os-version)
+ (blank-pos (search " " full-version))
+ (os (subseq full-version 0 blank-pos))
+ (version-rest (subseq full-version
+ (1+ blank-pos)))
+ os-version)
(setq blank-pos (search " " version-rest))
(setq version-rest (subseq version-rest
- (1+ blank-pos)))
+ (1+ blank-pos)))
(setq blank-pos (search " " version-rest))
(setq os-version (subseq version-rest 0 blank-pos))
(setq version-rest (subseq version-rest
- (1+ blank-pos)))
+ (1+ blank-pos)))
(setq blank-pos (search " " version-rest))
(setq version-rest (subseq version-rest
- (1+ blank-pos)))
+ (1+ blank-pos)))
(concatenate 'string
os " " os-version)) ; " " version-rest
#+(and :sgi :cmu :sbcl)
(if (equalp soft-type "IRIX5")
(progn
(foreign:call-system
- (format nil "versions ~A | sed -e ~A > ~A"
+ (format nil "versions ~A | sed -e ~A > ~A"
"eoe1"
*find-irix-version-script*
"irix-version")
- "/bin/csh")
+ "/bin/csh")
(with-open-file (s "irix-version")
(format nil "IRIX ~S"
- (read s))))
+ (read s))))
soft-type))
#-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix))
(software-type))
(defun compiler-version ()
#+:lispworks (concatenate 'string
- "lispworks" " " (lisp-implementation-version))
+ "lispworks" " " (lisp-implementation-version))
#+excl (concatenate 'string
- "excl" " " excl::*common-lisp-version-number*)
+ "excl" " " excl::*common-lisp-version-number*)
#+sbcl (concatenate 'string
- "sbcl" " " (lisp-implementation-version))
+ "sbcl" " " (lisp-implementation-version))
#+cmu (concatenate 'string
- "cmu" " " (lisp-implementation-version))
+ "cmu" " " (lisp-implementation-version))
#+scl (concatenate 'string
- "scl" " " (lisp-implementation-version))
+ "scl" " " (lisp-implementation-version))
#+kcl "kcl"
#+IBCL "ibcl"
;; to :binary-pathname in defsystem. For example,
;; :binary-pathname (afs-binary-directory "scanner/")
(let ((machine (machine-type-translation
- #-(and :sgi :allegro-version>= (version>= 4 2))
- (machine-type)
- #+(and :sgi :allegro-version>= (version>= 4 2))
- (machine-version)))
- (software (software-type-translation
- #-(and :sgi (or :cmu :sbcl :scl
- (and :allegro-version>= (version>= 4 2))))
- (software-type)
- #+(and :sgi (or :cmu :sbcl :scl
- (and :allegro-version>= (version>= 4 2))))
- (operating-system-version)))
- (lisp (compiler-type-translation (compiler-version))))
+ #-(and :sgi :allegro-version>= (version>= 4 2))
+ (machine-type)
+ #+(and :sgi :allegro-version>= (version>= 4 2))
+ (machine-version)))
+ (software (software-type-translation
+ #-(and :sgi (or :cmu :sbcl :scl
+ (and :allegro-version>= (version>= 4 2))))
+ (software-type)
+ #+(and :sgi (or :cmu :sbcl :scl
+ (and :allegro-version>= (version>= 4 2))))
+ (operating-system-version)))
+ (lisp (compiler-type-translation (compiler-version))))
;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach
(setq root-directory (namestring root-directory))
(setq root-directory (ensure-trailing-slash root-directory))
(format nil "~A~@[~A~]~@[~A/~]"
- root-directory
- *bin-subdir*
- (if *multiple-lisp-support*
- (afs-component machine software lisp)
- (afs-component machine software)))))
+ root-directory
+ *bin-subdir*
+ (if *multiple-lisp-support*
+ (afs-component machine software lisp)
+ (afs-component machine software)))))
(defun afs-source-directory (root-directory &optional version-flag)
;; Function for obtaining the directory AFS's @sys feature would have
(defun ensure-trailing-slash (dir)
(if (and dir
- (not (null-string dir))
- (not (char= (char dir
- (1- (length dir)))
- #\/))
- (not (char= (char dir
- (1- (length dir)))
- #\\))
- )
+ (not (null-string dir))
+ (not (char= (char dir
+ (1- (length dir)))
+ #\/))
+ (not (char= (char dir
+ (1- (length dir)))
+ #\\))
+ )
(concatenate 'string dir "/")
dir))
(defun afs-component (machine software &optional lisp)
(format nil "~@[~A~]~@[_~A~]~@[_~A~]"
- machine
- (or software "mach")
- lisp))
+ machine
+ (or software "mach")
+ lisp))
(defvar *machine-type-alist* (make-hash-table :test #'equal)
#+:lucid
(software-type-translation "Unix"
- #+:lcl4.0 "4.0"
- #+(and :lcl3.0 (not :lcl4.0)) "3.0")
+ #+:lcl4.0 "4.0"
+ #+(and :lcl3.0 (not :lcl4.0)) "3.0")
(defvar *compiler-type-alist* (make-hash-table :test #'equal)
#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (or (find :case-sensitive common-lisp:*features*)
- (find :case-insensitive common-lisp:*features*))
+ (find :case-insensitive common-lisp:*features*))
(if (or (eq excl:*current-case-mode* :case-sensitive-lower)
- (eq excl:*current-case-mode* :case-sensitive-upper))
- (push :case-sensitive common-lisp:*features*)
+ (eq excl:*current-case-mode* :case-sensitive-upper))
+ (push :case-sensitive common-lisp:*features*)
(push :case-insensitive common-lisp:*features*))))
"Returns a list of defined systems."
(let ((result nil))
(maphash #'(lambda (key value)
- (declare (ignore key))
- (push value result))
- *defined-systems*)
+ (declare (ignore key))
+ (push value result))
+ *defined-systems*)
result))
;;; Merge-pathnames works for VMS systems. In VMS systems, the directory
;;; part is enclosed in square brackets, e.g.,
-;;; "[root.child.child_child]" or "[root.][child.][child_child]"
+;;; "[root.child.child_child]" or "[root.][child.][child_child]"
;;; To concatenate directories merge-pathnames works as follows:
-;;; (merge-pathnames "" "[root]") ==> "[root]"
-;;; (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext"
-;;; (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext"
-;;; (merge-pathnames "[root]file.ext" "[son]") ==> "[root]file.ext"
+;;; (merge-pathnames "" "[root]") ==> "[root]"
+;;; (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext"
+;;; (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext"
+;;; (merge-pathnames "[root]file.ext" "[son]") ==> "[root]file.ext"
;;; Thus the problem with the #-VMS code was that it was merging x y into
;;; [[x]][y] instead of [x][y] or [x]y.
;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100),
;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0.
(setf absolute-dir (or absolute-dir "")
- relative-dir (or relative-dir ""))
+ relative-dir (or relative-dir ""))
(let* ((abs-dir (pathname absolute-dir))
- (rel-dir (pathname relative-dir))
- (host (pathname-host abs-dir))
- (device (if (null-string absolute-dir) ; fix for CMU CL old compiler
- (pathname-device rel-dir)
- (pathname-device abs-dir)))
- (abs-directory (directory-to-list (pathname-directory abs-dir)))
- (abs-keyword (when (keywordp (car abs-directory))
- (pop abs-directory)))
- ;; Stig (July 2001):
- ;; Somehow CLISP dies on the next line, but NIL is ok.
- (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name
- (rel-directory (directory-to-list (pathname-directory rel-dir)))
- (rel-keyword (when (keywordp (car rel-directory))
- (pop rel-directory)))
+ (rel-dir (pathname relative-dir))
+ (host (pathname-host abs-dir))
+ (device (if (null-string absolute-dir) ; fix for CMU CL old compiler
+ (pathname-device rel-dir)
+ (pathname-device abs-dir)))
+ (abs-directory (directory-to-list (pathname-directory abs-dir)))
+ (abs-keyword (when (keywordp (car abs-directory))
+ (pop abs-directory)))
+ ;; Stig (July 2001):
+ ;; Somehow CLISP dies on the next line, but NIL is ok.
+ (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name
+ (rel-directory (directory-to-list (pathname-directory rel-dir)))
+ (rel-keyword (when (keywordp (car rel-directory))
+ (pop rel-directory)))
#-(or :MCL :sbcl :clisp) (rel-file (file-namestring rel-dir))
- ;; Stig (July 2001);
- ;; These values seems to help clisp as well
- #+(or :MCL :sbcl :clisp) (rel-name (pathname-name rel-dir))
- #+(or :MCL :sbcl :clisp) (rel-type (pathname-type rel-dir))
- (directory nil))
+ ;; Stig (July 2001);
+ ;; These values seems to help clisp as well
+ #+(or :MCL :sbcl :clisp) (rel-name (pathname-name rel-dir))
+ #+(or :MCL :sbcl :clisp) (rel-type (pathname-type rel-dir))
+ (directory nil))
;; TI Common Lisp pathnames can return garbage for file names because
;; of bizarreness in the merging of defaults. The following code makes
;; the necessary case conversion. TI maps upper back into lower case
;; for unix files!
#+TI (if (search (pathname-name abs-dir) abs-name :test #'string-equal)
- (setf abs-name (string-right-trim ".\17" (string-upcase abs-name)))
- (setf abs-name nil))
+ (setf abs-name (string-right-trim ".\17" (string-upcase abs-name)))
+ (setf abs-name nil))
#+TI (if (search (pathname-name rel-dir) rel-file :test #'string-equal)
- (setf rel-file (string-right-trim ".\17" (string-upcase rel-file)))
- (setf rel-file nil))
+ (setf rel-file (string-right-trim ".\17" (string-upcase rel-file)))
+ (setf rel-file nil))
;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root)
;; and filename "foo". The namestring of a pathname with
;; directory '(:absolute :root "foo") ignores everything after the
(when (and abs-name (not (null-string abs-name))) ; was abs-name
(cond ((and (null abs-directory) (null abs-keyword))
- #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative)
- (setf abs-directory (list abs-name)))
- (t
- (setf abs-directory (append abs-directory (list abs-name))))))
+ #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative)
+ (setf abs-directory (list abs-name)))
+ (t
+ (setf abs-directory (append abs-directory (list abs-name))))))
(when (and (null abs-directory)
- (or (null abs-keyword)
- ;; In Lucid, an abs-dir of nil gets a keyword of
- ;; :relative since (pathname-directory (pathname ""))
- ;; returns (:relative) instead of nil.
- #+:lucid (eq abs-keyword :relative))
- rel-keyword)
+ (or (null abs-keyword)
+ ;; In Lucid, an abs-dir of nil gets a keyword of
+ ;; :relative since (pathname-directory (pathname ""))
+ ;; returns (:relative) instead of nil.
+ #+:lucid (eq abs-keyword :relative))
+ rel-keyword)
;; The following feature switches seem necessary in CMUCL
;; Marco Antoniotti 19990707
#+(or :sbcl :CMU)
(if (typep abs-dir 'logical-pathname)
- (setf abs-keyword :absolute)
- (setf abs-keyword rel-keyword))
+ (setf abs-keyword :absolute)
+ (setf abs-keyword rel-keyword))
#-(or :sbcl :CMU)
(setf abs-keyword rel-keyword))
(setf directory (append abs-directory rel-directory))
(when abs-keyword (setf directory (cons abs-keyword directory)))
(namestring
(make-pathname :host host
- :device device
+ :device device
:directory
directory
- :name
- #-(or :sbcl :MCL :clisp) rel-file
- #+(or :sbcl :MCL :clisp) rel-name
+ :name
+ #-(or :sbcl :MCL :clisp) rel-file
+ #+(or :sbcl :MCL :clisp) rel-name
- #+(or :sbcl :MCL :clisp) :type
- #+(or :sbcl :MCL :clisp) rel-type
- ))))
+ #+(or :sbcl :MCL :clisp) :type
+ #+(or :sbcl :MCL :clisp) rel-type
+ ))))
(defun directory-to-list (directory)
;; The directory should be a list, but nonstandard implementations have
;; been known to use a vector or even a string.
(cond ((listp directory)
- directory)
- ((stringp directory)
- (cond ((find #\; directory)
- ;; It's probably a logical pathname, so split at the
- ;; semicolons:
- (split-string directory :item #\;))
+ directory)
+ ((stringp directory)
+ (cond ((find #\; directory)
+ ;; It's probably a logical pathname, so split at the
+ ;; semicolons:
+ (split-string directory :item #\;))
#+MCL
- ((and (find #\: directory)
- (not (find #\/ directory)))
- ;; It's probably a MCL pathname, so split at the colons.
- (split-string directory :item #\:))
- (t
- ;; It's probably a unix pathname, so split at the slash.
- (split-string directory :item #\/))))
- (t
- (coerce directory 'list))))
+ ((and (find #\: directory)
+ (not (find #\/ directory)))
+ ;; It's probably a MCL pathname, so split at the colons.
+ (split-string directory :item #\:))
+ (t
+ ;; It's probably a unix pathname, so split at the slash.
+ (split-string directory :item #\/))))
+ (t
+ (coerce directory 'list))))
(defparameter *append-dirs-tests*
(defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*))
(do* ((dir-list test-dirs (cddr dir-list))
- (abs-dir (car dir-list) (car dir-list))
- (rel-dir (cadr dir-list) (cadr dir-list)))
+ (abs-dir (car dir-list) (car dir-list))
+ (rel-dir (cadr dir-list) (cadr dir-list)))
((null dir-list) (values))
(format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S"
- abs-dir rel-dir (new-append-directories abs-dir rel-dir))))
+ abs-dir rel-dir (new-append-directories abs-dir rel-dir))))
#||
;; as being logical unless its logical host is already defined.
#+(or (and allegro-version>= (version>= 4 1))
- :logical-pathnames-mk)
+ :logical-pathnames-mk)
((and absolute-directory
- (logical-pathname-p absolute-directory)
- relative-directory)
+ (logical-pathname-p absolute-directory)
+ relative-directory)
;; For use with logical pathnames package.
(append-logical-directories-mk absolute-directory relative-directory))
|#
;; In VMS, merge-pathnames actually does what we want!!!
#+:VMS
(namestring (merge-pathnames (or absolute-directory "")
- (or relative-directory "")))
+ (or relative-directory "")))
#+:macl1.3.2
(namestring (make-pathname :directory absolute-directory
- :name relative-directory))
+ :name relative-directory))
;; Cross your fingers and pray.
#-(or :VMS :macl1.3.2)
(new-append-directories absolute-directory relative-directory)))))
(translate-logical-pathname
(make-pathname
:host (or (pathname-host absolute-dir)
- (pathname-host relative-dir))
+ (pathname-host relative-dir))
:directory (append (pathname-directory absolute-dir)
- (cdr (pathname-directory relative-dir)))
+ (cdr (pathname-directory relative-dir)))
:name (or (pathname-name absolute-dir)
- (pathname-name relative-dir))
+ (pathname-name relative-dir))
:type (or (pathname-type absolute-dir)
- (pathname-type relative-dir))
+ (pathname-type relative-dir))
:version (or (pathname-version absolute-dir)
- (pathname-version relative-dir)))))
+ (pathname-version relative-dir)))))
;; Old version
#+(and (and allegro-version>= (version>= 4 1))
(defun append-logical-directories-mk (absolute-dir relative-dir)
(when (or absolute-dir relative-dir)
(setq absolute-dir (logical-pathname (or absolute-dir ""))
- relative-dir (logical-pathname (or relative-dir "")))
+ relative-dir (logical-pathname (or relative-dir "")))
(translate-logical-pathname
(make-pathname
:host (or (pathname-host absolute-dir)
- (pathname-host relative-dir))
+ (pathname-host relative-dir))
:directory (append (pathname-directory absolute-dir)
- (cdr (pathname-directory relative-dir)))
+ (cdr (pathname-directory relative-dir)))
:name (or (pathname-name absolute-dir)
- (pathname-name relative-dir))
+ (pathname-name relative-dir))
:type (or (pathname-type absolute-dir)
- (pathname-type relative-dir))
+ (pathname-type relative-dir))
:version (or (pathname-version absolute-dir)
- (pathname-version relative-dir))))))
+ (pathname-version relative-dir))))))
|#
;;; determines if string or pathname object is logical
#+clisp ; CLisp has non conformant Logical Pathnames.
(pathname (pathname-logical-p (namestring thing)))
(string (and (= 1 (count #\: thing)) ; Shortcut.
- (ignore-errors (translate-logical-pathname thing))
- t))
+ (ignore-errors (translate-logical-pathname thing))
+ t))
(t nil)))
;;; This affects only one thing.
(defun append-logical-pnames (absolute relative)
(declare (type (or null string pathname) absolute relative))
(let ((abs (if absolute
- #-clisp (namestring absolute)
- #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string
- ""))
- (rel (if relative (namestring relative) ""))
- )
+ #-clisp (namestring absolute)
+ #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string
+ ""))
+ (rel (if relative (namestring relative) ""))
+ )
;; Make sure the absolute directory ends with a semicolon unless
;; the pieces are null strings
(unless (or (null-string abs) (null-string rel)
- (char= (char abs (1- (length abs)))
- #\;))
+ (char= (char abs (1- (length abs)))
+ #\;))
(setq abs (concatenate 'string abs ";")))
;; Return the concatenate pathnames
(concatenate 'string abs rel)))
:name nil
:type nil)
))
- (rel (if relative
+ (rel (if relative
(pathname relative)
(make-pathname :directory (list :relative)
:name nil
:type nil)
))
- )
+ )
;; The following is messed up because CMUCL and LW use different
;; defaults for host (in particular LW uses NIL). Thus
;; MERGE-PATHNAMES has legitimate different behaviors on both
(etypecase abs
(logical-pathname
(etypecase rel
- (logical-pathname
- (namestring (merge-pathnames rel abs)))
- (pathname
- ;; The following potentially translates the logical pathname
- ;; very early, but we cannot avoid it.
- (namestring (merge-pathnames rel (translate-logical-pathname abs))))
- ))
+ (logical-pathname
+ (namestring (merge-pathnames rel abs)))
+ (pathname
+ ;; The following potentially translates the logical pathname
+ ;; very early, but we cannot avoid it.
+ (namestring (merge-pathnames rel (translate-logical-pathname abs))))
+ ))
(pathname
(namestring (merge-pathnames rel abs)))
)))
(when absolute-directory
(setq absolute-directory (pathname-directory absolute-directory)))
(concatenate 'string
- (or absolute-directory "")
- (or relative-directory "")))
+ (or absolute-directory "")
+ (or relative-directory "")))
||#
#||
(defstruct (component (:include topological-sort-node)
(:print-function print-component))
(type :file ; to pacify the CMUCL compiler (:type is alway supplied)
- :type (member :defsystem
- :system
- :subsystem
- :module
- :file
- :private-file
- ))
+ :type (member :defsystem
+ :system
+ :subsystem
+ :module
+ :file
+ :private-file
+ ))
(name nil :type (or symbol string))
- (indent 0 :type (mod 1024)) ; Number of characters of indent in
- ; verbose output to the user.
- host ; The pathname host (i.e., "/../a").
- device ; The pathname device.
- source-root-dir ; Relative or absolute (starts
- ; with "/"), directory or file
- ; (ends with "/").
+ (indent 0 :type (mod 1024)) ; Number of characters of indent in
+ ; verbose output to the user.
+ host ; The pathname host (i.e., "/../a").
+ device ; The pathname device.
+ source-root-dir ; Relative or absolute (starts
+ ; with "/"), directory or file
+ ; (ends with "/").
(source-pathname *source-pathname-default*)
- source-extension ; A string, e.g., "lisp"
- ; if NIL, inherit
+ source-extension ; A string, e.g., "lisp"
+ ; if NIL, inherit
(binary-pathname *binary-pathname-default*)
binary-root-dir
- binary-extension ; A string, e.g., "fasl". If
- ; NIL, uses default for
- ; machine-type.
- package ; Package for use-package.
+ binary-extension ; A string, e.g., "fasl". If
+ ; NIL, uses default for
+ ; machine-type.
+ package ; Package for use-package.
;; The following three slots are used to provide for alternate compilation
;; and loading functions for the files contained within a component. If
(language nil :type (or null symbol))
(compiler nil :type (or null symbol function))
(loader nil :type (or null symbol function))
- (compiler-options nil :type list) ; A list of compiler options to
+ (compiler-options nil :type list) ; A list of compiler options to
; use for compiling this
; component. These must be
; keyword options supported by
; the compiler.
- (components () :type list) ; A list of components
- ; comprising this component's
- ; definition.
- (depends-on () :type list) ; A list of the components
- ; this one depends on. may
- ; refer only to the components
- ; at the same level as this
- ; one.
- proclamations ; Compiler options, such as
- ; '(optimize (safety 3)).
+ (components () :type list) ; A list of components
+ ; comprising this component's
+ ; definition.
+ (depends-on () :type list) ; A list of the components
+ ; this one depends on. may
+ ; refer only to the components
+ ; at the same level as this
+ ; one.
+ proclamations ; Compiler options, such as
+ ; '(optimize (safety 3)).
(initially-do (lambda () nil)) ; Form to evaluate before the
- ; operation.
- (finally-do (lambda () nil)) ; Form to evaluate after the operation.
+ ; operation.
+ (finally-do (lambda () nil)) ; Form to evaluate after the operation.
(compile-form (lambda () nil)) ; For foreign libraries.
(load-form (lambda () nil)) ; For foreign libraries.
- ;; load-time ; The file-write-date of the
- ; binary/source file loaded.
+ ;; load-time ; The file-write-date of the
+ ; binary/source file loaded.
;; If load-only is T, will not compile the file on operation :compile.
;; In other words, for files which are :load-only T, loading the file
;; satisfies any demand to recompile.
- load-only ; If T, will not compile this
- ; file on operation :compile.
+ load-only ; If T, will not compile this
+ ; file on operation :compile.
;; If compile-only is T, will not load the file on operation :compile.
;; Either compiles or loads the file, but not both. In other words,
;; compiling the file satisfies the demand to load it. This is useful
;; for PCL defmethod and defclass definitions, which wrap a
;; (eval-when (compile load eval) ...) around the body of the definition.
;; This saves time in some lisps.
- compile-only ; If T, will not load this
- ; file on operation :compile.
+ compile-only ; If T, will not load this
+ ; file on operation :compile.
#|| ISI Extension ||#
- load-always ; If T, will force loading
- ; even if file has not
- ; changed.
+ load-always ; If T, will force loading
+ ; even if file has not
+ ; changed.
;; PVE: add banner
(banner nil :type (or null string))
(version nil :type (or null string))
;; Added NON-REQUIRED-P slot. Useful for optional items.
- (non-required-p nil :type boolean) ; If T a missing file or
- ; sub-directory will not cause
- ; an error.
+ (non-required-p nil :type boolean) ; If T a missing file or
+ ; sub-directory will not cause
+ ; an error.
)
)
#-gcl (:default-initargs :component nil)
(:report (lambda (mmc stream)
- (format stream "MK:DEFSYSTEM: missing component ~S for ~S."
+ (format stream "MK:DEFSYSTEM: missing component ~S for ~S."
(missing-component-name mmc)
(missing-component-component mmc))))
)
(define-condition missing-module (missing-component)
()
(:report (lambda (mmc stream)
- (format stream "MK:DEFSYSTEM: missing module ~S for ~S."
+ (format stream "MK:DEFSYSTEM: missing module ~S for ~S."
(missing-component-name mmc)
(missing-component-component mmc))))
)
(define-condition missing-system (missing-module)
()
(:report (lambda (msc stream)
- (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]."
+ (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]."
(missing-component-name msc)
(missing-component-component msc))))
)
(pathname (gethash (namestring component) *file-load-time-table*))
(component
(ecase (component-type component)
- (:defsystem
- (let* ((name (component-name component))
- (path (when name (compute-system-path name nil))))
- (declare (type (or string pathname null) path))
- (when path
- (gethash (namestring path) *file-load-time-table*))))
- ((:file :private-file)
- ;; Use only :source pathname to identify component's
- ;; load time.
- (let ((path (component-full-pathname component :source)))
- (when path
- (gethash path *file-load-time-table*)))))))))
+ (:defsystem
+ (let* ((name (component-name component))
+ (path (when name (compute-system-path name nil))))
+ (declare (type (or string pathname null) path))
+ (when path
+ (gethash (namestring path) *file-load-time-table*))))
+ ((:file :private-file)
+ ;; Use only :source pathname to identify component's
+ ;; load time.
+ (let ((path (component-full-pathname component :source)))
+ (when path
+ (gethash path *file-load-time-table*)))))))))
#-(or :cmu)
(defsetf component-load-time (component) (value)
(etypecase ,component
(string (setf (gethash ,component *file-load-time-table*) ,value))
(pathname (setf (gethash (namestring (the pathname ,component))
- *file-load-time-table*)
- ,value))
+ *file-load-time-table*)
+ ,value))
(component
(ecase (component-type ,component)
- (:defsystem
- (let* ((name (component-name ,component))
- (path (when name (compute-system-path name nil))))
- (declare (type (or string pathname null) path))
- (when path
- (setf (gethash (namestring path) *file-load-time-table*)
- ,value))))
- ((:file :private-file)
- ;; Use only :source pathname to identify file.
- (let ((path (component-full-pathname ,component :source)))
- (when path
- (setf (gethash path *file-load-time-table*)
- ,value)))))))
+ (:defsystem
+ (let* ((name (component-name ,component))
+ (path (when name (compute-system-path name nil))))
+ (declare (type (or string pathname null) path))
+ (when path
+ (setf (gethash (namestring path) *file-load-time-table*)
+ ,value))))
+ ((:file :private-file)
+ ;; Use only :source pathname to identify file.
+ (let ((path (component-full-pathname ,component :source)))
+ (when path
+ (setf (gethash path *file-load-time-table*)
+ ,value)))))))
,value))
#+(or :cmu)
(etypecase component
(string (setf (gethash component *file-load-time-table*) value))
(pathname (setf (gethash (namestring (the pathname component))
- *file-load-time-table*)
- value))
+ *file-load-time-table*)
+ value))
(component
(ecase (component-type component)
- (:defsystem
- (let* ((name (component-name component))
- (path (when name (compute-system-path name nil))))
- (declare (type (or string pathname null) path))
- (when path
- (setf (gethash (namestring path) *file-load-time-table*)
- value))))
- ((:file :private-file)
- ;; Use only :source pathname to identify file.
- (let ((path (component-full-pathname component :source)))
- (when path
- (setf (gethash path *file-load-time-table*)
- value)))))))
+ (:defsystem
+ (let* ((name (component-name component))
+ (path (when name (compute-system-path name nil))))
+ (declare (type (or string pathname null) path))
+ (when path
+ (setf (gethash (namestring path) *file-load-time-table*)
+ value))))
+ ((:file :private-file)
+ ;; Use only :source pathname to identify file.
+ (let ((path (component-full-pathname component :source)))
+ (when path
+ (setf (gethash path *file-load-time-table*)
+ value)))))))
value))
(string module-name)))
(file-pathname
- (make-pathname :name module-string-name
- :type *system-extension*))
+ (make-pathname :name module-string-name
+ :type *system-extension*))
(lib-file-pathname
- (make-pathname :directory (list :relative module-string-name)
+ (make-pathname :directory (list :relative module-string-name)
:name module-string-name
- :type *system-extension*))
+ :type *system-extension*))
)
- (or (when definition-pname ; given pathname for system def
- (probe-file definition-pname))
- ;; Then the central registry. Note that we also check the current
- ;; directory in the registry, but the above check is hard-coded.
- (cond (*central-registry*
- (if (listp *central-registry*)
- (dolist (registry *central-registry*)
- (let* ((reg-path (registry-pathname registry))
+ (or (when definition-pname ; given pathname for system def
+ (probe-file definition-pname))
+ ;; Then the central registry. Note that we also check the current
+ ;; directory in the registry, but the above check is hard-coded.
+ (cond (*central-registry*
+ (if (listp *central-registry*)
+ (dolist (registry *central-registry*)
+ (let* ((reg-path (registry-pathname registry))
(file (or (probe-file
(append-directories
reg-path file-pathname))
(probe-file
(append-directories
reg-path lib-file-pathname)))))
- (when file (return file))))
- (or (probe-file (append-directories *central-registry*
- file-pathname))
+ (when file (return file))))
+ (or (probe-file (append-directories *central-registry*
+ file-pathname))
(probe-file (append-directories *central-registry*
- lib-file-pathname))
+ lib-file-pathname))
))
)
- (t
- ;; No central registry. Assume current working directory.
- ;; Maybe this should be an error?
- (or (probe-file file-pathname)
+ (t
+ ;; No central registry. Assume current working directory.
+ ;; Maybe this should be an error?
+ (or (probe-file file-pathname)
(probe-file lib-file-pathname)))))
))
(if system
(let ((system-def-pathname
(make-pathname
- :type "system"
- :defaults (pathname (component-full-pathname system :source))))
+ :type "system"
+ :defaults (pathname (component-full-pathname system :source))))
)
(values system-def-pathname
(probe-file system-def-pathname)))
(defun compute-system-path (module-name definition-pname)
(let* ((filename (format nil "~A.~A"
- (if (symbolp module-name)
- (string-downcase (string module-name))
- module-name)
- *system-extension*)))
- (or (when definition-pname ; given pathname for system def
- (probe-file definition-pname))
- ;; Then the central registry. Note that we also check the current
- ;; directory in the registry, but the above check is hard-coded.
- (cond (*central-registry*
- (if (listp *central-registry*)
- (dolist (registry *central-registry*)
- (let ((file (probe-file
- (append-directories
+ (if (symbolp module-name)
+ (string-downcase (string module-name))
+ module-name)
+ *system-extension*)))
+ (or (when definition-pname ; given pathname for system def
+ (probe-file definition-pname))
+ ;; Then the central registry. Note that we also check the current
+ ;; directory in the registry, but the above check is hard-coded.
+ (cond (*central-registry*
+ (if (listp *central-registry*)
+ (dolist (registry *central-registry*)
+ (let ((file (probe-file
+ (append-directories
(registry-pathname registry) filename))))
- (when file (return file))))
- (probe-file (append-directories *central-registry*
- filename))))
- (t
- ;; No central registry. Assume current working directory.
- ;; Maybe this should be an error?
- (probe-file filename))))))
+ (when file (return file))))
+ (probe-file (append-directories *central-registry*
+ filename))))
+ (t
+ ;; No central registry. Assume current working directory.
+ ;; Maybe this should be an error?
+ (probe-file filename))))))
|#
(ecase mode
(:ask
(or (get-system system-name)
- (when (y-or-n-p-wait
- #\y 20
- "System ~A not loaded. Shall I try loading it? "
- system-name)
- (find-system system-name :load definition-pname))))
+ (when (y-or-n-p-wait
+ #\y 20
+ "System ~A not loaded. Shall I try loading it? "
+ system-name)
+ (find-system system-name :load definition-pname))))
(:error
(or (get-system system-name)
- (error 'missing-system :name system-name)))
+ (error 'missing-system :name system-name)))
(:load-or-nil
(let ((system (get-system system-name)))
;; (break "System ~S ~S." system-name system)
(or (unless *reload-systems-from-disk* system)
- ;; If SYSTEM-NAME is a symbol, it will lowercase the
- ;; symbol's string.
- ;; If SYSTEM-NAME is a string, it doesn't change the case of the
- ;; string. So if case matters in the filename, use strings, not
- ;; symbols, wherever the system is named.
+ ;; If SYSTEM-NAME is a symbol, it will lowercase the
+ ;; symbol's string.
+ ;; If SYSTEM-NAME is a string, it doesn't change the case of the
+ ;; string. So if case matters in the filename, use strings, not
+ ;; symbols, wherever the system is named.
(when (foreign-system-p system)
(warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM."
- system)
+ system)
(return-from find-system nil))
- (let ((path (compute-system-path system-name definition-pname)))
- (when (and path
- (or (null system)
- (null (component-load-time path))
- (< (component-load-time path)
- (file-write-date path))))
- (tell-user-generic
- (format nil "Loading system ~A from file ~A"
- system-name
- path))
- (load path)
- (setf system (get-system system-name))
- (when system
- (setf (component-load-time path)
- (file-write-date path))))
- system)
- system)))
+ (let ((path (compute-system-path system-name definition-pname)))
+ (when (and path
+ (or (null system)
+ (null (component-load-time path))
+ (< (component-load-time path)
+ (file-write-date path))))
+ (tell-user-generic
+ (format nil "Loading system ~A from file ~A"
+ system-name
+ path))
+ (load path)
+ (setf system (get-system system-name))
+ (when system
+ (setf (component-load-time path)
+ (file-write-date path))))
+ system)
+ system)))
(:load
(or (unless *reload-systems-from-disk* (get-system system-name))
(when (foreign-system-p (get-system system-name))
(warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM."
- (get-system system-name))
+ (get-system system-name))
(return-from find-system nil))
- (or (find-system system-name :load-or-nil definition-pname)
- (error "Can't find system named ~s." system-name))))))
+ (or (find-system system-name :load-or-nil definition-pname)
+ (error "Can't find system named ~s." system-name))))))
(defun print-component (component stream depth)
~& Source: ~@[~A~] ~@[~A~] ~@[~A~]~
~& Binary: ~@[~A~] ~@[~A~] ~@[~A~]~
~@[~& Depends On: ~A ~]~& Components:~{~15T~A~&~}"
- (component-type system)
- (component-name system)
- (component-host system)
- (component-device system)
- (component-package system)
- (component-root-dir system :source)
- (component-pathname system :source)
- (component-extension system :source)
- (component-root-dir system :binary)
- (component-pathname system :binary)
- (component-extension system :binary)
- (component-depends-on system)
- (component-components system))
+ (component-type system)
+ (component-name system)
+ (component-host system)
+ (component-device system)
+ (component-package system)
+ (component-root-dir system :source)
+ (component-pathname system :source)
+ (component-extension system :source)
+ (component-root-dir system :binary)
+ (component-pathname system :binary)
+ (component-extension system :binary)
+ (component-depends-on system)
+ (component-components system))
#||(when recursive
(dolist (component (component-components system))
- (describe-system component stream recursive)))||#
+ (describe-system component stream recursive)))||#
system))
;; names are often constructed from component names, and unix
;; prefers lowercase as a default.
(setf (component-name component)
- (string-downcase (string (component-name component))))))
+ (string-downcase (string (component-name component))))))
(defun component-pathname (component type)
(case type
(:source
(let ((old (gethash component *source-pathnames-table*)))
- (or old
- (let ((new (component-full-pathname-i component type version)))
- (setf (gethash component *source-pathnames-table*) new)
- new))))
+ (or old
+ (let ((new (component-full-pathname-i component type version)))
+ (setf (gethash component *source-pathnames-table*) new)
+ new))))
(:binary
(let ((old (gethash component *binary-pathnames-table*)))
- (or old
- (let ((new (component-full-pathname-i component type version)))
- (setf (gethash component *binary-pathnames-table*) new)
- new))))
+ (or old
+ (let ((new (component-full-pathname-i component type version)))
+ (setf (gethash component *binary-pathnames-table*) new)
+ new))))
(otherwise
(component-full-pathname-i component type version)))))
(defun component-full-pathname-i (component type
&optional (version *version*)
- &aux version-dir version-replace)
+ &aux version-dir version-replace)
;; If the pathname-type is :binary and the root pathname is null,
;; distribute the binaries among the sources (= use :source pathname).
;; This assumes that the component's :source pathname has been set
;; before the :binary one.
(if version
(multiple-value-setq (version-dir version-replace)
- (translate-version version))
+ (translate-version version))
(setq version-dir *version-dir* version-replace *version-replace*))
;; (format *trace-output* "~&>>>> VERSION COMPUTED ~S ~S~%" version-dir version-replace)
(let ((pathname
- (append-directories
- (if version-replace
- version-dir
- (append-directories (component-root-dir component type)
- version-dir))
- (component-pathname component type))))
+ (append-directories
+ (if version-replace
+ version-dir
+ (append-directories (component-root-dir component type)
+ version-dir))
+ (component-pathname component type))))
;; When a logical pathname is used, it must first be translated to
;; a physical pathname. This isn't strictly correct. What should happen
;; PATHNAME-NAME is NIL.
(cond ((pathname-logical-p pathname) ; See definition of test above.
- (setf pathname
- (merge-pathnames pathname
- (make-pathname
- :name (component-name component)
- :type (component-extension component
- type))))
- (namestring (translate-logical-pathname pathname)))
- (t
- (namestring
- (make-pathname :host (or (component-host component)
- (pathname-host pathname))
-
- :directory (pathname-directory pathname
- #+scl :case
- #+scl :common
- )
-
- :name (or (pathname-name pathname
+ (setf pathname
+ (merge-pathnames pathname
+ (make-pathname
+ :name (component-name component)
+ :type (component-extension component
+ type))))
+ (namestring (translate-logical-pathname pathname)))
+ (t
+ (namestring
+ (make-pathname :host (or (component-host component)
+ (pathname-host pathname))
+
+ :directory (pathname-directory pathname
+ #+scl :case
+ #+scl :common
+ )
+
+ :name (or (pathname-name pathname
#+scl :case
#+scl :common
)
(component-name component))
- :type
- #-scl (component-extension component type)
- #+scl (string-upcase
- (component-extension component type))
+ :type
+ #-scl (component-extension component type)
+ #+scl (string-upcase
+ (component-extension component type))
- :device
- #+sbcl
- :unspecific
- #-(or :sbcl)
- (or (component-device component)
- (pathname-device pathname
- #+scl :case
- #+scl :common
- ))
- ;; :version :newest
- ))))))
+ :device
+ #+sbcl
+ :unspecific
+ #-(or :sbcl)
+ (or (component-device component)
+ (pathname-device pathname
+ #+scl :case
+ #+scl :common
+ ))
+ ;; :version :newest
+ ))))))
#-lispworks
;; specifies a subdirectory of the root, or
;; a string, which replaces the root.
(cond ((null version)
- (values "" nil))
- ((symbolp version)
- (values (let ((sversion (string version)))
- (if (find-if #'lower-case-p sversion)
- sversion
- (string-downcase sversion)))
- nil))
- ((stringp version)
- (values version t))
- (t (error "~&; Illegal version ~S" version))))
+ (values "" nil))
+ ((symbolp version)
+ (values (let ((sversion (string version)))
+ (if (find-if #'lower-case-p sversion)
+ sversion
+ (string-downcase sversion)))
+ nil))
+ ((stringp version)
+ (values version t))
+ (t (error "~&; Illegal version ~S" version))))
;;; Looks like LW has a bug in MERGE-PATHNAMES.
;; specifies a subdirectory of the root, or
;; a string, which replaces the root.
(cond ((null version)
- (values (pathname "") nil))
- ((symbolp version)
- (values (let ((sversion (string version)))
- (if (find-if #'lower-case-p sversion)
- (pathname sversion)
- (pathname (string-downcase sversion))))
- nil))
- ((stringp version)
- (values (pathname version) t))
- (t (error "~&; Illegal version ~S" version))))
+ (values (pathname "") nil))
+ ((symbolp version)
+ (values (let ((sversion (string version)))
+ (if (find-if #'lower-case-p sversion)
+ (pathname sversion)
+ (pathname (string-downcase sversion))))
+ nil))
+ ((stringp version)
+ (values (pathname version) t))
+ (t (error "~&; Illegal version ~S" version))))
(defun component-extension (component type &key local)
(ecase type
(:source (or (component-source-extension component)
- (unless local
- (default-source-extension component)) ; system default
+ (unless local
+ (default-source-extension component)) ; system default
;; (and (component-language component))
))
(:binary (or (component-binary-extension component)
- (unless local
- (default-binary-extension component)) ; system default
+ (unless local
+ (default-binary-extension component)) ; system default
;; (and (component-language component))
))
(:error *compile-error-file-type*)))
(defun create-component (type name definition-body &optional parent (indent 0))
(let ((component (apply #'make-component
- :type type
- :name name
- :indent indent
- definition-body)))
+ :type type
+ :name name
+ :indent indent
+ definition-body)))
;; Set up :load-only attribute
(unless (find :load-only definition-body)
;; If the :load-only attribute wasn't specified,
;; inherit it from the parent. If no parent, default it to nil.
(setf (component-load-only component)
- (when parent
- (component-load-only parent))))
+ (when parent
+ (component-load-only parent))))
;; Set up :compile-only attribute
(unless (find :compile-only definition-body)
;; If the :compile-only attribute wasn't specified,
;; inherit it from the parent. If no parent, default it to nil.
(setf (component-compile-only component)
- (when parent
- (component-compile-only parent))))
+ (when parent
+ (component-compile-only parent))))
;; Set up :compiler-options attribute
(unless (find :compiler-options definition-body)
;; If the :compiler-option attribute wasn't specified,
;; inherit it from the parent. If no parent, default it to NIL.
(setf (component-compiler-options component)
- (when parent
- (component-compiler-options parent))))
+ (when parent
+ (component-compiler-options parent))))
#|| ISI Extension ||#
;; Set up :load-always attribute
;; If the :load-always attribute wasn't specified,
;; inherit it from the parent. If no parent, default it to nil.
(setf (component-load-always component)
- (when parent
- (component-load-always parent))))
+ (when parent
+ (component-load-always parent))))
;; Initializations/after makes
(canonicalize-component-name component)
;; Inherit package from parent if not specified.
(setf (component-package component)
- (or (component-package component)
- (when parent (component-package parent))))
+ (or (component-package component)
+ (when parent (component-package parent))))
;; Type specific setup:
(when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
(setf (get-system name) component)
#|(unless (component-language component)
- (setf (component-language component) :lisp))|#)
+ (setf (component-language component) :lisp))|#)
;; Set up the component's pathname
(create-component-pathnames component parent)
(defun preprocess-component-definition (definition-body)
`(list* ,@(loop for slot in *component-evaluated-slots*
- for value = (getf definition-body slot)
- when value
+ for value = (getf definition-body slot)
+ when value
do (remf definition-body slot)
and nconc `(,slot ,value))
- ,@(loop for slot in *component-form-slots*
- do (remf definition-body slot)
+ ,@(loop for slot in *component-form-slots*
+ do (remf definition-body slot)
nconc `(,slot (lambda ()
,(getf definition-body slot))))
- ',definition-body))
+ ',definition-body))
;;; defsystem --
(defmacro defsystem (name &rest definition-body)
(unless (find :source-pathname definition-body)
(setf definition-body
- (list* :source-pathname
- '(when #-gcl *load-pathname* #+gcl si::*load-pathname*
+ (list* :source-pathname
+ '(when #-gcl *load-pathname* #+gcl si::*load-pathname*
(make-pathname :name nil
:type nil
:defaults
#-gcl *load-pathname*
#+gcl si::*load-pathname*
))
- definition-body)))
+ definition-body)))
`(create-component :defsystem ',name
,(preprocess-component-definition definition-body)
nil
;; Set up language-specific defaults
(setf (component-language component)
- (or (component-language component) ; for local defaulting
- (when parent ; parent's default
- (component-language parent))))
+ (or (component-language component) ; for local defaulting
+ (when parent ; parent's default
+ (component-language parent))))
(setf (component-compiler component)
- (or (component-compiler component) ; for local defaulting
- (when parent ; parent's default
- (component-compiler parent))))
+ (or (component-compiler component) ; for local defaulting
+ (when parent ; parent's default
+ (component-compiler parent))))
(setf (component-loader component)
- (or (component-loader component) ; for local defaulting
- (when parent ; parent's default
- (component-loader parent))))
+ (or (component-loader component) ; for local defaulting
+ (when parent ; parent's default
+ (component-loader parent))))
;; Evaluate the root dir arg
(setf (component-root-dir component :source)
- (eval (component-root-dir component :source)))
+ (eval (component-root-dir component :source)))
(setf (component-root-dir component :binary)
- (eval (component-root-dir component :binary)))
+ (eval (component-root-dir component :binary)))
;; Evaluate the pathname arg
(setf (component-pathname component :source)
- (eval (component-pathname component :source)))
+ (eval (component-pathname component :source)))
(setf (component-pathname component :binary)
- (eval (component-pathname component :binary)))
+ (eval (component-pathname component :binary)))
;; Pass along the host and devices
(setf (component-host component)
- (or (component-host component)
- (when parent (component-host parent))
- (pathname-host *default-pathname-defaults*)))
+ (or (component-host component)
+ (when parent (component-host parent))
+ (pathname-host *default-pathname-defaults*)))
(setf (component-device component)
- (or (component-device component)
- (when parent (component-device parent))))
+ (or (component-device component)
+ (when parent (component-device parent))))
;; Set up extension defaults
(setf (component-extension component :source)
- (or (component-extension component :source
+ (or (component-extension component :source
:local #| (component-language component) |#
t
) ; local default
(when (component-language component)
(default-source-extension component))
- (when parent ; parent's default
- (component-extension parent :source))))
+ (when parent ; parent's default
+ (component-extension parent :source))))
(setf (component-extension component :binary)
- (or (component-extension component :binary
+ (or (component-extension component :binary
:local #| (component-language component) |#
t
) ; local default
(when (component-language component)
(default-binary-extension component))
- (when parent ; parent's default
- (component-extension parent :binary))))
+ (when parent ; parent's default
+ (component-extension parent :binary))))
;; Set up pathname defaults -- expand with parent
;; We must set up the source pathname before the binary pathname
;; specified for binaries, but no module directories, it inherits
;; parallel directory structure.
(case (component-type component)
- ((:defsystem :system) ; Absolute Pathname
+ ((:defsystem :system) ; Absolute Pathname
;; Set the root-dir to be the absolute pathname
(setf (component-root-dir component pathname-type)
- (or (component-pathname component pathname-type)
- (when (eq pathname-type :binary)
- ;; When the binary root is nil, use source.
- (component-root-dir component :source))) )
+ (or (component-pathname component pathname-type)
+ (when (eq pathname-type :binary)
+ ;; When the binary root is nil, use source.
+ (component-root-dir component :source))) )
;; Set the relative pathname to be nil
(setf (component-pathname component pathname-type)
- nil));; should this be "" instead?
+ nil));; should this be "" instead?
;; If the name of the component-pathname is nil, it
;; defaults to the name of the component. Use "" to
;; avoid this defaulting.
(:private-file ; Absolute Pathname
;; Root-dir is the directory part of the pathname
(setf (component-root-dir component pathname-type)
- ""
- #+ignore(or (when (component-pathname component pathname-type)
- (pathname-directory
- (component-pathname component pathname-type)))
- (when (eq pathname-type :binary)
- ;; When the binary root is nil, use source.
- (component-root-dir component :source)))
- )
+ ""
+ #+ignore(or (when (component-pathname component pathname-type)
+ (pathname-directory
+ (component-pathname component pathname-type)))
+ (when (eq pathname-type :binary)
+ ;; When the binary root is nil, use source.
+ (component-root-dir component :source)))
+ )
;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "",
;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could
;; wind up being "", which is wrong for :file components. So replace
(setf (component-pathname component pathname-type) nil))
;; The relative pathname is the name part
(setf (component-pathname component pathname-type)
- (or (when (and (eq pathname-type :binary)
- (null (component-pathname component :binary)))
- ;; When the binary-pathname is nil use source.
- (component-pathname component :source))
- (or (when (component-pathname component pathname-type)
+ (or (when (and (eq pathname-type :binary)
+ (null (component-pathname component :binary)))
+ ;; When the binary-pathname is nil use source.
+ (component-pathname component :source))
+ (or (when (component-pathname component pathname-type)
;; (pathname-name )
- (component-pathname component pathname-type))
- (component-name component)))))
- ((:module :subsystem) ; Pathname relative to parent.
+ (component-pathname component pathname-type))
+ (component-name component)))))
+ ((:module :subsystem) ; Pathname relative to parent.
;; Inherit root-dir from parent
(setf (component-root-dir component pathname-type)
- (component-root-dir parent pathname-type))
+ (component-root-dir parent pathname-type))
;; Tack the relative-dir onto the pathname
(setf (component-pathname component pathname-type)
- (or (when (and (eq pathname-type :binary)
- (null (component-pathname component :binary)))
- ;; When the binary-pathname is nil use source.
- (component-pathname component :source))
- (append-directories
- (component-pathname parent pathname-type)
- (or (component-pathname component pathname-type)
- (component-name component))))))
- (:file ; Pathname relative to parent.
+ (or (when (and (eq pathname-type :binary)
+ (null (component-pathname component :binary)))
+ ;; When the binary-pathname is nil use source.
+ (component-pathname component :source))
+ (append-directories
+ (component-pathname parent pathname-type)
+ (or (component-pathname component pathname-type)
+ (component-name component))))))
+ (:file ; Pathname relative to parent.
;; Inherit root-dir from parent
(setf (component-root-dir component pathname-type)
- (component-root-dir parent pathname-type))
+ (component-root-dir parent pathname-type))
;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "",
;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could
;; wind up being "", which is wrong for :file components. So replace
(setf (component-pathname component pathname-type) nil))
;; Tack the relative-dir onto the pathname
(setf (component-pathname component pathname-type)
- (or (append-directories
- (component-pathname parent pathname-type)
- (or (component-pathname component pathname-type)
- (component-name component)
- (when (eq pathname-type :binary)
- ;; When the binary-pathname is nil use source.
- (component-pathname component :source)))))))
+ (or (append-directories
+ (component-pathname parent pathname-type)
+ (or (component-pathname component pathname-type)
+ (component-name component)
+ (when (eq pathname-type :binary)
+ ;; When the binary-pathname is nil use source.
+ (component-pathname component :source)))))))
))
#|| ;; old version
(defun expand-component-components (component &optional (indent 0))
(let ((definitions (component-components component)))
(setf (component-components component)
- (remove-if #'null
- (mapcar #'(lambda (definition)
- (expand-component-definition definition
- component
- indent))
- definitions)))))
+ (remove-if #'null
+ (mapcar #'(lambda (definition)
+ (expand-component-definition definition
+ component
+ indent))
+ definitions)))))
||#
;;; new version
(defun expand-component-components (component &optional (indent 0))
(let ((definitions (component-components component)))
(if (eq (car definitions) :serial)
- (setf (component-components component)
- (expand-serial-component-chain (cdr definitions)
- component indent))
- (setf (component-components component)
- (expand-component-definitions definitions component indent)))))
+ (setf (component-components component)
+ (expand-serial-component-chain (cdr definitions)
+ component indent))
+ (setf (component-components component)
+ (expand-component-definitions definitions component indent)))))
(defun expand-component-definitions (definitions parent &optional (indent 0))
(let ((components nil))
(dolist (definition definitions)
(let ((new (expand-component-definition definition parent indent)))
- (when new (push new components))))
+ (when new (push new components))))
(nreverse components)))
(defun expand-serial-component-chain (definitions parent &optional (indent 0))
(let ((previous nil)
- (components nil))
+ (components nil))
(dolist (definition definitions)
(let ((new (expand-component-definition definition parent indent)))
- (when new
- ;; Make this component depend on the previous one. Since
- ;; we don't know the form of the definition, we have to
- ;; expand it first.
- (when previous (pushnew previous (component-depends-on new)))
- ;; The dependencies will be linked later, so we use the name
- ;; instead of the actual component.
- (setq previous (component-name new))
- ;; Save the new component.
- (push new components))))
+ (when new
+ ;; Make this component depend on the previous one. Since
+ ;; we don't know the form of the definition, we have to
+ ;; expand it first.
+ (when previous (pushnew previous (component-depends-on new)))
+ ;; The dependencies will be linked later, so we use the name
+ ;; instead of the actual component.
+ (setq previous (component-name new))
+ ;; Save the new component.
+ (push new components))))
;; Return the list of expanded components, in appropriate order.
(nreverse components)))
;; represents an absolute pathname.
(or (find #\: string :test #'char=)
(and (not (null-string string))
- (char= (char string 0) #\/))))
+ (char= (char string 0) #\/))))
(defun expand-component-definition (definition parent &optional (indent 0))
(cond ((null definition) nil)
((stringp definition)
;; Strings are assumed to be of type :file
- (if (and *enable-straz-absolute-string-hack*
- (absolute-file-namestring-p definition))
- ;; Special hack for Straz
- (create-component :private-file definition nil parent indent)
- ;; Normal behavior
- (create-component :file definition nil parent indent)))
+ (if (and *enable-straz-absolute-string-hack*
+ (absolute-file-namestring-p definition))
+ ;; Special hack for Straz
+ (create-component :private-file definition nil parent indent)
+ ;; Normal behavior
+ (create-component :file definition nil parent indent)))
((and (listp definition)
(not (member (car definition)
- '(:defsystem :system :subsystem
- :module :file :private-file))))
+ '(:defsystem :system :subsystem
+ :module :file :private-file))))
;; Lists whose first element is not a component type
;; are assumed to be of type :file
(create-component :file
- (first definition)
- ;; (preprocess-component-definition (rest definition)) ; Not working.
+ (first definition)
+ ;; (preprocess-component-definition (rest definition)) ; Not working.
(rest definition)
- parent
- indent))
+ parent
+ indent))
((listp definition)
;; Otherwise, it is (we hope) a normal form definition
(create-component (first definition) ; type
(second definition) ; name
- ;; definition body
+ ;; definition body
;; (preprocess-component-definition (cddr definition)) ; Not working.
(cddr definition)
parent ; parent
- indent) ; indent
+ indent) ; indent
)))
(eq (component-type component) :defsystem))
(setf (component-depends-on component)
(mapcar #'(lambda (dependency)
- (let ((parent (find (string dependency) components
- :key #'component-name
- :test #'string-equal)))
- (cond (parent parent)
- ;; make it more intelligent about the following
- (t (warn "Dependency ~S of component ~S not found."
- dependency component)))))
+ (let ((parent (find (string dependency) components
+ :key #'component-name
+ :test #'string-equal)))
+ (cond (parent parent)
+ ;; make it more intelligent about the following
+ (t (warn "Dependency ~S of component ~S not found."
+ dependency component)))))
(component-depends-on component))))))
;; blackening times for each vertex, and then sorts the vertices into
;; reverse order by blackening time.
(labels ((dfs-visit (node)
- (setf (topsort-color node) 'gray)
- (unless (and *system-dependencies-delayed*
- (eq (component-type node) :defsystem))
- (dolist (child (component-depends-on node))
- (cond ((eq (topsort-color child) 'white)
- (dfs-visit child))
- ((eq (topsort-color child) 'gray)
- (format t "~&Detected cycle containing ~A" child)))))
- (setf (topsort-color node) 'black)
- (setf (topsort-time node) time)
- (incf time)))
+ (setf (topsort-color node) 'gray)
+ (unless (and *system-dependencies-delayed*
+ (eq (component-type node) :defsystem))
+ (dolist (child (component-depends-on node))
+ (cond ((eq (topsort-color child) 'white)
+ (dfs-visit child))
+ ((eq (topsort-color child) 'gray)
+ (format t "~&Detected cycle containing ~A" child)))))
+ (setf (topsort-color node) 'black)
+ (setf (topsort-time node) time)
+ (incf time)))
(dolist (node list)
(setf (topsort-color node) 'white))
(dolist (node list)
(defun split-string (string &key (item #\space) (test #'char=))
;; Splits the string into substrings at spaces.
(let ((len (length string))
- (index 0) result)
+ (index 0) result)
(dotimes (i len
- (progn (unless (= index len)
- (push (subseq string index) result))
- (reverse result)))
+ (progn (unless (= index len)
+ (push (subseq string index) result))
+ (reverse result)))
(when (funcall test (char string i) item)
- (unless (= index i);; two spaces in a row
- (push (subseq string index i) result))
- (setf index (1+ i))))))
+ (unless (= index i);; two spaces in a row
+ (push (subseq string index i) result))
+ (setf index (1+ i))))))
;; probably should remove the ",1" entirely. But AKCL 1.243 dies on it
;; because of an AKCL bug.
(defun prompt-string (component)
(format nil "; ~:[~;TEST:~]~V,1@T "
- *oos-test*
- (component-indent component)))
+ *oos-test*
+ (component-indent component)))
#||
(defun format-justified-string (prompt contents)
(format t (concatenate 'string
- "~%"
- prompt
- "-~{~<~%" prompt " ~1,80:; ~A~>~^~}")
- (split-string contents))
+ "~%"
+ prompt
+ "-~{~<~%" prompt " ~1,80:; ~A~>~^~}")
+ (split-string contents))
(finish-output *standard-output*))
||#
(defun format-justified-string (prompt contents &optional (width 80)
- (stream *standard-output*))
+ (stream *standard-output*))
(let ((prompt-length (+ 2 (length prompt))))
(cond ((< (+ prompt-length (length contents)) width)
- (format stream "~%~A- ~A" prompt contents))
- (t
- (format stream "~%~A-" prompt)
- (do* ((cursor prompt-length)
- (contents (split-string contents) (cdr contents))
- (content (car contents) (car contents))
- (content-length (1+ (length content)) (1+ (length content))))
- ((null contents))
- (cond ((< (+ cursor content-length) width)
- (incf cursor content-length)
- (format stream " ~A" content))
- (t
- (setf cursor (+ prompt-length content-length))
- (format stream "~%~A ~A" prompt content)))))))
+ (format stream "~%~A- ~A" prompt contents))
+ (t
+ (format stream "~%~A-" prompt)
+ (do* ((cursor prompt-length)
+ (contents (split-string contents) (cdr contents))
+ (content (car contents) (car contents))
+ (content-length (1+ (length content)) (1+ (length content))))
+ ((null contents))
+ (cond ((< (+ cursor content-length) width)
+ (incf cursor content-length)
+ (format stream " ~A" content))
+ (t
+ (setf cursor (+ prompt-length content-length))
+ (format stream "~%~A ~A" prompt content)))))))
(finish-output stream))
(when (or *oos-verbose* force)
(format-justified-string (prompt-string component)
(format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]"
- ;; To have better messages, wrap the following around the
- ;; case statement:
- ;;(if (find (component-type component)
- ;; '(:defsystem :system :subsystem :module))
- ;; "Checking"
- ;; (case ...))
- ;; This gets around the problem of DEFSYSTEM reporting
- ;; that it's loading a module, when it eventually never
- ;; loads any of the files of the module.
- (case what
- ((compile :compile)
- (if (component-load-only component)
- ;; If it is :load-only t, we're loading.
- "Loading"
- ;; Otherwise we're compiling.
- "Compiling"))
- ((load :load) "Loading")
- (otherwise what))
- (component-type component)
- (or (when type
- (component-full-pathname component type))
- (component-name component))
- (and *tell-user-when-done*
- (not no-dots))))))
+ ;; To have better messages, wrap the following around the
+ ;; case statement:
+ ;;(if (find (component-type component)
+ ;; '(:defsystem :system :subsystem :module))
+ ;; "Checking"
+ ;; (case ...))
+ ;; This gets around the problem of DEFSYSTEM reporting
+ ;; that it's loading a module, when it eventually never
+ ;; loads any of the files of the module.
+ (case what
+ ((compile :compile)
+ (if (component-load-only component)
+ ;; If it is :load-only t, we're loading.
+ "Loading"
+ ;; Otherwise we're compiling.
+ "Compiling"))
+ ((load :load) "Loading")
+ (otherwise what))
+ (component-type component)
+ (or (when type
+ (component-full-pathname component type))
+ (component-name component))
+ (and *tell-user-when-done*
+ (not no-dots))))))
(defun tell-user-done (component &optional force no-dots)
;; test is no longer really used, but we're leaving it in.
(when (and *tell-user-when-done*
- (or *oos-verbose* force))
+ (or *oos-verbose* force))
(format t "~&~A~:[~;...~] Done."
- (prompt-string component) (not no-dots))
+ (prompt-string component) (not no-dots))
(finish-output *standard-output*)))
(format-justified-string (prompt-string component)
(format nil "Source file ~A ~
~:[and binary file ~A ~;~]not found, not loading."
- (component-full-pathname component :source)
- (or *load-source-if-no-binary* *load-source-instead-of-binary*)
- (component-full-pathname component :binary)))))
+ (component-full-pathname component :source)
+ (or *load-source-if-no-binary* *load-source-instead-of-binary*)
+ (component-full-pathname component :binary)))))
(defun tell-user-require-system (name parent)
(when *oos-verbose*
(format t "~&; ~:[~;TEST:~] - System ~A requires ~S"
- *oos-test* (component-name parent) name)
+ *oos-test* (component-name parent) name)
(finish-output *standard-output*)))
(defun tell-user-generic (string)
(when *oos-verbose*
(format t "~&; ~:[~;TEST:~] - ~A"
- *oos-test* string)
+ *oos-test* string)
(finish-output *standard-output*)))
;;; that we lose input editing, but why can't the lisp implement this?
(defun y-or-n-p-wait (&optional (default #\y) (timeout 20)
- format-string &rest args)
+ format-string &rest args)
"Y-OR-N-P-WAIT prints the message, if any, and reads characters from
*QUERY-IO* until the user enters y, Y or space as an affirmative, or either
n or N as a negative answer, or the timeout occurs. It asks again if
(finish-output *query-io*))
(loop
(let* ((read-char (if *use-timeouts*
- (read-char-wait timeout *query-io* nil nil)
- (read-char *query-io*)))
- (char (or read-char default)))
+ (read-char-wait timeout *query-io* nil nil)
+ (read-char *query-io*)))
+ (char (or read-char default)))
;; We need to ignore #\newline because otherwise the bugs in
;; clear-input will cause y-or-n-p-wait to print the "Type ..."
;; message every time... *sigh*
;; clear-input is fixed.
(unless (find char '(#\tab #\newline #\return))
(when (null read-char)
- (format *query-io* "~@[~A~]" default)
- (finish-output *query-io*))
+ (format *query-io* "~@[~A~]" default)
+ (finish-output *query-io*))
(cond ((null char) (return t))
- ((find char '(#\y #\Y #\space) :test #'char=) (return t))
- ((find char '(#\n #\N) :test #'char=) (return nil))
- (t
- (when *clear-input-before-query* (clear-input *query-io*))
- (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ")
- (when format-string
- (fresh-line *query-io*)
- (apply #'format *query-io* format-string args))
- (finish-output *query-io*)))))))
+ ((find char '(#\y #\Y #\space) :test #'char=) (return t))
+ ((find char '(#\n #\N) :test #'char=) (return nil))
+ (t
+ (when *clear-input-before-query* (clear-input *query-io*))
+ (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ")
+ (when format-string
+ (fresh-line *query-io*)
+ (apply #'format *query-io* format-string args))
+ (finish-output *query-io*)))))))
#||
(y-or-n-p-wait #\y 20 "What? ")
;;; a string, which replaces the root.
(defun operate-on-system (name operation
- &key
- force
- (version *version*)
- (test *oos-test*) (verbose *oos-verbose*)
+ &key
+ force
+ (version *version*)
+ (test *oos-test*) (verbose *oos-verbose*)
(load-source-instead-of-binary
- *load-source-instead-of-binary*)
+ *load-source-instead-of-binary*)
(load-source-if-no-binary
- *load-source-if-no-binary*)
- (bother-user-if-no-binary
- *bother-user-if-no-binary*)
- (compile-during-load *compile-during-load*)
- dribble
- (minimal-load *minimal-load*)
- (override-compilation-unit t)
- )
+ *load-source-if-no-binary*)
+ (bother-user-if-no-binary
+ *bother-user-if-no-binary*)
+ (compile-during-load *compile-during-load*)
+ dribble
+ (minimal-load *minimal-load*)
+ (override-compilation-unit t)
+ )
(declare #-(or :cltl2 :ansi-cl) (ignore override-compilation-unit))
(unwind-protect
;; Protect the undribble.
(#+(and (or :cltl2 :ansi-cl) (not :gcl)) with-compilation-unit
- #+(and (or :cltl2 :ansi-cl) (not :gcl)) (:override override-compilation-unit)
- #-(and (or :cltl2 :ansi-cl) (not :gcl)) progn
- (when *reset-full-pathname-table* (clear-full-pathname-tables))
- (when dribble (dribble dribble))
- (when test (setq verbose t))
- (when (null force) ; defaults
- (case operation
- ((load :load) (setq force :all))
- ((compile :compile) (setq force :new-source-and-dependents))
- (t (setq force :all))))
- ;; Some CL implementations have a variable called *compile-verbose*
- ;; or *compile-file-verbose*.
- (multiple-value-bind (*version-dir* *version-replace*)
- (translate-version version)
- ;; CL implementations may uniformly default this to nil
- (let ((*load-verbose* #-common-lisp-controller t
- #+common-lisp-controller nil) ; nil
- #-(or MCL CMU CLISP ECL :sbcl lispworks scl)
- (*compile-file-verbose* t) ; nil
- #+common-lisp-controller
- (*compile-print* nil)
- #+(and common-lisp-controller cmu)
- (ext:*compile-progress* nil)
- #+(and common-lisp-controller cmu)
- (ext:*require-verbose* nil)
- #+(and common-lisp-controller cmu)
- (ext:*gc-verbose* nil)
-
- (*compile-verbose* #-common-lisp-controller t
- #+common-lisp-controller nil) ; nil
- (*version* version)
- (*oos-verbose* verbose)
- (*oos-test* test)
- (*load-source-if-no-binary* load-source-if-no-binary)
- (*compile-during-load* compile-during-load)
- (*bother-user-if-no-binary* bother-user-if-no-binary)
- (*load-source-instead-of-binary* load-source-instead-of-binary)
- (*minimal-load* minimal-load)
- (system (if (and (component-p name)
+ #+(and (or :cltl2 :ansi-cl) (not :gcl)) (:override override-compilation-unit)
+ #-(and (or :cltl2 :ansi-cl) (not :gcl)) progn
+ (when *reset-full-pathname-table* (clear-full-pathname-tables))
+ (when dribble (dribble dribble))
+ (when test (setq verbose t))
+ (when (null force) ; defaults
+ (case operation
+ ((load :load) (setq force :all))
+ ((compile :compile) (setq force :new-source-and-dependents))
+ (t (setq force :all))))
+ ;; Some CL implementations have a variable called *compile-verbose*
+ ;; or *compile-file-verbose*.
+ (multiple-value-bind (*version-dir* *version-replace*)
+ (translate-version version)
+ ;; CL implementations may uniformly default this to nil
+ (let ((*load-verbose* #-common-lisp-controller t
+ #+common-lisp-controller nil) ; nil
+ #-(or MCL CMU CLISP ECL :sbcl lispworks scl)
+ (*compile-file-verbose* t) ; nil
+ #+common-lisp-controller
+ (*compile-print* nil)
+ #+(and common-lisp-controller cmu)
+ (ext:*compile-progress* nil)
+ #+(and common-lisp-controller cmu)
+ (ext:*require-verbose* nil)
+ #+(and common-lisp-controller cmu)
+ (ext:*gc-verbose* nil)
+
+ (*compile-verbose* #-common-lisp-controller t
+ #+common-lisp-controller nil) ; nil
+ (*version* version)
+ (*oos-verbose* verbose)
+ (*oos-test* test)
+ (*load-source-if-no-binary* load-source-if-no-binary)
+ (*compile-during-load* compile-during-load)
+ (*bother-user-if-no-binary* bother-user-if-no-binary)
+ (*load-source-instead-of-binary* load-source-instead-of-binary)
+ (*minimal-load* minimal-load)
+ (system (if (and (component-p name)
(member (component-type name)
- '(:system :defsystem :subsystem)))
+ '(:system :defsystem :subsystem)))
name
(find-system name :load))))
- #-(or CMU CLISP :sbcl :lispworks :cormanlisp scl)
- (declare (special *compile-verbose* #-MCL *compile-file-verbose*)
- #-openmcl (ignore *compile-verbose*
- #-MCL *compile-file-verbose*)
- #-openmcl (optimize (inhibit-warnings 3)))
- (unless (component-operation operation)
- (error "Operation ~A undefined." operation))
-
- (operate-on-component system operation force))))
+ #-(or CMU CLISP :sbcl :lispworks :cormanlisp scl)
+ (declare (special *compile-verbose* #-MCL *compile-file-verbose*)
+ #-openmcl (ignore *compile-verbose*
+ #-MCL *compile-file-verbose*)
+ #-openmcl (optimize (inhibit-warnings 3)))
+ (unless (component-operation operation)
+ (error "Operation ~A undefined." operation))
+
+ (operate-on-component system operation force))))
(when dribble (dribble))))
(defun compile-system (name &key force
- (version *version*)
- (test *oos-test*) (verbose *oos-verbose*)
- (load-source-instead-of-binary
- *load-source-instead-of-binary*)
- (load-source-if-no-binary
- *load-source-if-no-binary*)
- (bother-user-if-no-binary
- *bother-user-if-no-binary*)
- (compile-during-load *compile-during-load*)
- dribble
- (minimal-load *minimal-load*))
+ (version *version*)
+ (test *oos-test*) (verbose *oos-verbose*)
+ (load-source-instead-of-binary
+ *load-source-instead-of-binary*)
+ (load-source-if-no-binary
+ *load-source-if-no-binary*)
+ (bother-user-if-no-binary
+ *bother-user-if-no-binary*)
+ (compile-during-load *compile-during-load*)
+ dribble
+ (minimal-load *minimal-load*))
;; For users who are confused by OOS.
(operate-on-system
name :compile
:minimal-load minimal-load))
(defun load-system (name &key force
- (version *version*)
- (test *oos-test*) (verbose *oos-verbose*)
- (load-source-instead-of-binary
- *load-source-instead-of-binary*)
- (load-source-if-no-binary *load-source-if-no-binary*)
- (bother-user-if-no-binary *bother-user-if-no-binary*)
- (compile-during-load *compile-during-load*)
- dribble
- (minimal-load *minimal-load*))
+ (version *version*)
+ (test *oos-test*) (verbose *oos-verbose*)
+ (load-source-instead-of-binary
+ *load-source-instead-of-binary*)
+ (load-source-if-no-binary *load-source-if-no-binary*)
+ (bother-user-if-no-binary *bother-user-if-no-binary*)
+ (compile-during-load *compile-during-load*)
+ dribble
+ (minimal-load *minimal-load*))
;; For users who are confused by OOS.
(operate-on-system
name :load
:minimal-load minimal-load))
(defun clean-system (name &key (force :all)
- (version *version*)
- (test *oos-test*) (verbose *oos-verbose*)
- dribble)
+ (version *version*)
+ (test *oos-test*) (verbose *oos-verbose*)
+ dribble)
"Deletes all the binaries in the system."
;; For users who are confused by OOS.
(operate-on-system
(defun edit-system
(name &key force
- (version *version*)
- (test *oos-test*)
- (verbose *oos-verbose*)
- dribble)
+ (version *version*)
+ (test *oos-test*)
+ (verbose *oos-verbose*)
+ dribble)
(operate-on-system
name :edit
(defun hardcopy-system
(name &key force
- (version *version*)
- (test *oos-test*)
- (verbose *oos-verbose*)
- dribble)
+ (version *version*)
+ (test *oos-test*)
+ (verbose *oos-verbose*)
+ dribble)
(operate-on-system
name :hardcopy
;;; ensure-external-system-def-loaded component --
;;; Let's treat definition clauses of the form
;;;
-;;; (:system "name")
+;;; (:system "name")
;;; i.e.
;;;
-;;; (:system "name" :components nil)
+;;; (:system "name" :components nil)
;;;
;;; in a special way.
;;; When encountered, MK:DEFSYSTEM tries to FIND-SYSTEM
(defun ensure-external-system-def-loaded (component)
(assert (member (component-type component)
- '(:subsystem :system)))
+ '(:subsystem :system)))
(when (null (component-components component))
(let* ((cname (component-name component)))
(declare (ignorable cname))
;; First we ensure that we reload the system definition.
(undefsystem cname)
(let* ((*reload-systems-from-disk* t)
- (system-component
- (find-system (component-name component)
- :load
-
- ;; Let's not supply the def-pname
- ;; yet.
- #+not-yet
- (merge-pathname
- (make-pathname :name cname
- :type "system"
- :directory ())
- (component-full-pathname component
- :source))
-
-
- ))
- )
- ;; Now we have a problem.
- ;; We have just ensured that a system definition is
- ;; loaded, however, the COMPONENT at hand is different
- ;; from SYSTEM-COMPONENT.
- ;; To fix this problem we just use the following
- ;; kludge. This should prevent re-entering in this
- ;; code branch, while actually preparing the COMPONENT
- ;; for operation.
- (setf (component-components component)
- (list system-component))
- ))))
+ (system-component
+ (find-system (component-name component)
+ :load
+
+ ;; Let's not supply the def-pname
+ ;; yet.
+ #+not-yet
+ (merge-pathname
+ (make-pathname :name cname
+ :type "system"
+ :directory ())
+ (component-full-pathname component
+ :source))
+
+
+ ))
+ )
+ ;; Now we have a problem.
+ ;; We have just ensured that a system definition is
+ ;; loaded, however, the COMPONENT at hand is different
+ ;; from SYSTEM-COMPONENT.
+ ;; To fix this problem we just use the following
+ ;; kludge. This should prevent re-entering in this
+ ;; code branch, while actually preparing the COMPONENT
+ ;; for operation.
+ (setf (component-components component)
+ (list system-component))
+ ))))
(defun operate-on-component (component operation force &aux changed)
;; Returns T if something changed and had to be compiled.
(let ((type (component-type component))
- (old-package (package-name *package*)))
+ (old-package (package-name *package*)))
(unwind-protect
- ;; Protect old-package.
- (progn
- ;; Use the correct package.
- (when (component-package component)
- (tell-user-generic (format nil "Using package ~A"
- (component-package component)))
- (unless *oos-test*
- (unless (find-package (component-package component))
- ;; If the package name is the same as the name of the system,
- ;; and the package is not defined, this would lead to an
- ;; infinite loop, so bomb out with an error.
- (when (string-equal (string (component-package component))
- (component-name component))
- (format t "~%Component ~A not loaded:~%"
- (component-name component))
- (error " Package ~A is not defined"
- (component-package component)))
- ;; If package not found, try using REQUIRE to load it.
- (new-require (component-package component)))
- ;; This was USE-PACKAGE, but should be IN-PACKAGE.
- ;; Actually, CLtL2 lisps define in-package as a macro,
- ;; so we'll set the package manually.
- ;; (in-package (component-package component))
- (let ((package (find-package (component-package component))))
- (when package
- (setf *package* package)))))
-
- ;; Marco Antoniotti 20040609
- ;; New feature. Try to FIND-SYSTEM :system components if
- ;; they have no local :components definition.
- ;; OPERATE-ON-SYSTEM-DEPENDENCIES should still work as
- ;; advertised, given the small change made there.
-
- (when (or (eq type :system) (eq type :subsystem))
- (ensure-external-system-def-loaded component))
-
- (when (or (eq type :defsystem) (eq type :system))
- (operate-on-system-dependencies component operation force))
-
- ;; Do any compiler proclamations
- (when (component-proclamations component)
- (tell-user-generic (format nil "Doing proclamations for ~A"
- (component-name component)))
- (unless *oos-test*
+ ;; Protect old-package.
+ (progn
+ ;; Use the correct package.
+ (when (component-package component)
+ (tell-user-generic (format nil "Using package ~A"
+ (component-package component)))
+ (unless *oos-test*
+ (unless (find-package (component-package component))
+ ;; If the package name is the same as the name of the system,
+ ;; and the package is not defined, this would lead to an
+ ;; infinite loop, so bomb out with an error.
+ (when (string-equal (string (component-package component))
+ (component-name component))
+ (format t "~%Component ~A not loaded:~%"
+ (component-name component))
+ (error " Package ~A is not defined"
+ (component-package component)))
+ ;; If package not found, try using REQUIRE to load it.
+ (new-require (component-package component)))
+ ;; This was USE-PACKAGE, but should be IN-PACKAGE.
+ ;; Actually, CLtL2 lisps define in-package as a macro,
+ ;; so we'll set the package manually.
+ ;; (in-package (component-package component))
+ (let ((package (find-package (component-package component))))
+ (when package
+ (setf *package* package)))))
+
+ ;; Marco Antoniotti 20040609
+ ;; New feature. Try to FIND-SYSTEM :system components if
+ ;; they have no local :components definition.
+ ;; OPERATE-ON-SYSTEM-DEPENDENCIES should still work as
+ ;; advertised, given the small change made there.
+
+ (when (or (eq type :system) (eq type :subsystem))
+ (ensure-external-system-def-loaded component))
+
+ (when (or (eq type :defsystem) (eq type :system))
+ (operate-on-system-dependencies component operation force))
+
+ ;; Do any compiler proclamations
+ (when (component-proclamations component)
+ (tell-user-generic (format nil "Doing proclamations for ~A"
+ (component-name component)))
+ (unless *oos-test*
(proclaim (component-proclamations component))))
- ;; Do any initial actions
- (when (component-initially-do component)
- (tell-user-generic (format nil "Doing initializations for ~A"
- (component-name component)))
- (unless *oos-test*
+ ;; Do any initial actions
+ (when (component-initially-do component)
+ (tell-user-generic (format nil "Doing initializations for ~A"
+ (component-name component)))
+ (unless *oos-test*
(with-special-component-vars (component)
(let ((initially-do (component-initially-do component)))
(if (functionp initially-do)
(eval initially-do))))
))
- ;; If operation is :compile and load-only is T, this would change
- ;; the operation to load. Only, this would mean that a module would
- ;; be considered to have changed if it was :load-only and had to be
- ;; loaded, and then dependents would be recompiled -- this doesn't
- ;; seem right. So instead, we propagate the :load-only attribute
- ;; to the components, and modify compile-file-operation so that
- ;; it won't compile the files (and modify tell-user to say "Loading"
- ;; instead of "Compiling" for load-only modules).
- #||
- (when (and (find operation '(:compile compile))
- (component-load-only component))
- (setf operation :load))
- ||#
-
- ;; Do operation and set changed flag if necessary.
- (setq changed
- (case type
- ((:file :private-file)
- (funcall (component-operation operation) component force))
- ((:module :system :subsystem :defsystem)
- (operate-on-components component operation force changed))))
-
- ;; Do any final actions
- (when (component-finally-do component)
- (tell-user-generic (format nil "Doing finalizations for ~A"
- (component-name component)))
- (unless *oos-test*
+ ;; If operation is :compile and load-only is T, this would change
+ ;; the operation to load. Only, this would mean that a module would
+ ;; be considered to have changed if it was :load-only and had to be
+ ;; loaded, and then dependents would be recompiled -- this doesn't
+ ;; seem right. So instead, we propagate the :load-only attribute
+ ;; to the components, and modify compile-file-operation so that
+ ;; it won't compile the files (and modify tell-user to say "Loading"
+ ;; instead of "Compiling" for load-only modules).
+ #||
+ (when (and (find operation '(:compile compile))
+ (component-load-only component))
+ (setf operation :load))
+ ||#
+
+ ;; Do operation and set changed flag if necessary.
+ (setq changed
+ (case type
+ ((:file :private-file)
+ (funcall (component-operation operation) component force))
+ ((:module :system :subsystem :defsystem)
+ (operate-on-components component operation force changed))))
+
+ ;; Do any final actions
+ (when (component-finally-do component)
+ (tell-user-generic (format nil "Doing finalizations for ~A"
+ (component-name component)))
+ (unless *oos-test*
(with-special-component-vars (component)
(let ((finally-do (component-finally-do component)))
(if (functionp finally-do)
(eval finally-do))))
))
- ;; add the banner if needed
- #+(or cmu scl)
- (when (component-banner component)
- (unless (stringp (component-banner component))
- (error "The banner should be a string, it is: ~S"
- (component-banner component)))
- (setf (getf ext:*herald-items*
- (intern (string-upcase (component-name component))
- (find-package :keyword)))
- (list
- (component-banner component)))))
+ ;; add the banner if needed
+ #+(or cmu scl)
+ (when (component-banner component)
+ (unless (stringp (component-banner component))
+ (error "The banner should be a string, it is: ~S"
+ (component-banner component)))
+ (setf (getf ext:*herald-items*
+ (intern (string-upcase (component-name component))
+ (find-package :keyword)))
+ (list
+ (component-banner component)))))
;; Reset the package. (Cleanup form of unwind-protect.)
;;(in-package old-package)
;; Provide the loaded system
(when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
(tell-user-generic (format nil "Providing system ~A~%"
- (component-name component)))
+ (component-name component)))
(or *oos-test*
- (provide (canonicalize-system-name (component-name component))))))
+ (provide (canonicalize-system-name (component-name component))))))
;; Return non-NIL if something changed in this component and hence had
;; to be recompiled. This is only used as a boolean.
(when *system-dependencies-delayed*
(let ((*force* force))
(dolist (system (component-depends-on component))
- ;; For each system that this system depends on, if it is a
- ;; defined system (either via defsystem or component type :system),
- ;; and propagation is turned on, propagates the operation to the
- ;; subsystem. Otherwise runs require (my version) on that system
- ;; to load it (needed since we may be depending on a lisp
- ;; dependent package).
- ;; Explores the system tree in a DFS manner.
-
- ;; Do not try to do anything with non system components.
+ ;; For each system that this system depends on, if it is a
+ ;; defined system (either via defsystem or component type :system),
+ ;; and propagation is turned on, propagates the operation to the
+ ;; subsystem. Otherwise runs require (my version) on that system
+ ;; to load it (needed since we may be depending on a lisp
+ ;; dependent package).
+ ;; Explores the system tree in a DFS manner.
+
+ ;; Do not try to do anything with non system components.
(cond ((and *operations-propagate-to-subsystems*
(not (listp system))
- (or (stringp system) (symbolp system))
+ (or (stringp system) (symbolp system))
;; The subsystem is a defined system.
(find-system system :load-or-nil))
;; Call OOS on it. Since *system-dependencies-delayed* is
(defun operate-on-components (component operation force changed)
(with-tell-user (operation component)
(if (component-components component)
- (dolist (module (component-components component))
- (when (operate-on-component module operation
- (cond ((and (module-depends-on-changed module changed)
- #||(some #'(lambda (dependent)
- (member dependent changed))
- (component-depends-on module))||#
- (or (non-empty-listp force)
- (eq force :new-source-and-dependents)))
- ;; The component depends on a changed file
- ;; and force agrees.
- (if (eq force :new-source-and-dependents)
- :new-source-all
- :all))
- ((and (non-empty-listp force)
- (member (component-name module) force
- :test #'string-equal :key #'string))
- ;; Force is a list of modules
- ;; and the component is one of them.
- :all)
- (t force)))
- (push module changed)))
- (case operation
- ((compile :compile)
- (with-special-component-vars (component)
+ (dolist (module (component-components component))
+ (when (operate-on-component module operation
+ (cond ((and (module-depends-on-changed module changed)
+ #||(some #'(lambda (dependent)
+ (member dependent changed))
+ (component-depends-on module))||#
+ (or (non-empty-listp force)
+ (eq force :new-source-and-dependents)))
+ ;; The component depends on a changed file
+ ;; and force agrees.
+ (if (eq force :new-source-and-dependents)
+ :new-source-all
+ :all))
+ ((and (non-empty-listp force)
+ (member (component-name module) force
+ :test #'string-equal :key #'string))
+ ;; Force is a list of modules
+ ;; and the component is one of them.
+ :all)
+ (t force)))
+ (push module changed)))
+ (case operation
+ ((compile :compile)
+ (with-special-component-vars (component)
(let ((compile-form (component-compile-form component)))
(if (functionp compile-form)
- (funcall compile-form)
- (eval compile-form)))))
- ((load :load)
- (with-special-component-vars (component)
+ (funcall compile-form)
+ (eval compile-form)))))
+ ((load :load)
+ (with-special-component-vars (component)
(let ((load-form (component-load-form component)))
(if (functionp load-form)
- (funcall load-form)
+ (funcall load-form)
(eval load-form)))
- )))))
+ )))))
;; This is only used as a boolean.
changed)
;;; a tangled mess.
(defun new-require (module-name
- &optional
- pathname
- definition-pname
- default-action
- (version *version*))
+ &optional
+ pathname
+ definition-pname
+ default-action
+ (version *version*))
;; If the pathname is present, this behaves like the old require.
(unless (and module-name
- (find (string module-name)
- *modules* :test #'string=))
+ (find (string module-name)
+ *modules* :test #'string=))
(handler-case
(cond (pathname
- (funcall *old-require* module-name pathname))
- ;; If the system is defined, load it.
- ((find-system module-name :load-or-nil definition-pname)
- (operate-on-system
- module-name :load
- :force *force*
- :version version
- :test *oos-test*
- :verbose *oos-verbose*
- :load-source-if-no-binary *load-source-if-no-binary*
- :bother-user-if-no-binary *bother-user-if-no-binary*
- :compile-during-load *compile-during-load*
- :load-source-instead-of-binary *load-source-instead-of-binary*
- :minimal-load *minimal-load*))
- ;; If there's a default action, do it. This could be a progn which
- ;; loads a file that does everything.
- ((and default-action
- (eval default-action)))
- ;; If no system definition file, try regular require.
- ;; had last arg PATHNAME, but this wasn't really necessary.
- ((funcall *old-require* module-name))
- ;; If no default action, print a warning or error message.
- (t
- #||
- (format t "~&Warning: System ~A doesn't seem to be defined..."
- module-name)
- ||#
- (error 'missing-system :name module-name)))
+ (funcall *old-require* module-name pathname))
+ ;; If the system is defined, load it.
+ ((find-system module-name :load-or-nil definition-pname)
+ (operate-on-system
+ module-name :load
+ :force *force*
+ :version version
+ :test *oos-test*
+ :verbose *oos-verbose*
+ :load-source-if-no-binary *load-source-if-no-binary*
+ :bother-user-if-no-binary *bother-user-if-no-binary*
+ :compile-during-load *compile-during-load*
+ :load-source-instead-of-binary *load-source-instead-of-binary*
+ :minimal-load *minimal-load*))
+ ;; If there's a default action, do it. This could be a progn which
+ ;; loads a file that does everything.
+ ((and default-action
+ (eval default-action)))
+ ;; If no system definition file, try regular require.
+ ;; had last arg PATHNAME, but this wasn't really necessary.
+ ((funcall *old-require* module-name))
+ ;; If no default action, print a warning or error message.
+ (t
+ #||
+ (format t "~&Warning: System ~A doesn't seem to be defined..."
+ module-name)
+ ||#
+ (error 'missing-system :name module-name)))
(missing-module (mmc) (signal mmc)) ; Resignal.
(error (e)
(declare (ignore e))
- ;; Signal a (maybe wrong) MISSING-SYSTEM.
- (error 'missing-system :name module-name)))
+ ;; Signal a (maybe wrong) MISSING-SYSTEM.
+ (error 'missing-system :name module-name)))
))
#||
(unless *old-require*
(setf *old-require*
- (symbol-function #-(or :lispworks
- :sbcl
- (and :excl :allegro-v4.0)) 'lisp:require
- #+:sbcl 'cl:require
- #+:lispworks 'system:::require
- #+(and :excl :allegro-v4.0) 'cltl1:require))
+ (symbol-function #-(or :lispworks
+ :sbcl
+ (and :excl :allegro-v4.0)) 'lisp:require
+ #+:sbcl 'cl:require
+ #+:lispworks 'system:::require
+ #+(and :excl :allegro-v4.0) 'cltl1:require))
(let (#+:CCL (ccl:*warn-if-redefine-kernel* nil))
;; Note that lots of lisps barf if we redefine a function from
;; do the right thing, try just replacing require-as-macro
;; with lisp:require.
(defmacro require-as-macro (module-name
- &optional pathname definition-pname
- default-action (version '*version*))
+ &optional pathname definition-pname
+ default-action (version '*version*))
`(eval-when (compile load eval)
- (new-require ,module-name ,pathname ,definition-pname
- ,default-action ,version)))
+ (new-require ,module-name ,pathname ,definition-pname
+ ,default-action ,version)))
(setf (macro-function #-(and :excl :sbcl :allegro-v4.0) 'lisp:require
- #+:sbcl 'cl:require
- #+(and :excl :allegro-v4.0) 'cltl1:require)
- (macro-function 'require-as-macro))))
+ #+:sbcl 'cl:require
+ #+(and :excl :allegro-v4.0) 'cltl1:require)
+ (macro-function 'require-as-macro))))
||#
;;; This will almost certainly fix the problem, but will cause problems
;;; if anybody does a funcall on #'require.
;;; Redefine old require to call the new require.
(eval-when #-(or :lucid) (:load-toplevel :execute)
- #+(or :lucid) (load eval)
+ #+(or :lucid) (load eval)
(unless *old-require*
(setf *old-require*
- (symbol-function
- #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
- #+(and :excl :allegro-v4.0) 'cltl1:require
- #+:sbcl 'cl:require
- #+:lispworks3.1 'common-lisp::require
- #+(and :lispworks (not :lispworks3.1)) 'system::require
- #+:openmcl 'cl:require
- #+(and :mcl (not :openmcl)) 'ccl:require
- ))
+ (symbol-function
+ #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
+ #+(and :excl :allegro-v4.0) 'cltl1:require
+ #+:sbcl 'cl:require
+ #+:lispworks3.1 'common-lisp::require
+ #+(and :lispworks (not :lispworks3.1)) 'system::require
+ #+:openmcl 'cl:require
+ #+(and :mcl (not :openmcl)) 'ccl:require
+ ))
(unless *dont-redefine-require*
(let (#+(or :mcl (and :CCL (not :lispworks)))
- (ccl:*warn-if-redefine-kernel* nil))
+ (ccl:*warn-if-redefine-kernel* nil))
#-(or :ecl (and allegro-version>= (version>= 4 1)) :lispworks)
(setf (symbol-function
- #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
- #+(and :excl :allegro-v4.0) 'cltl1:require
- #+:lispworks3.1 'common-lisp::require
- #+:sbcl 'cl:require
- #+(and :lispworks (not :lispworks3.1)) 'system::require
- #+:openmcl 'cl:require
- #+(and :mcl (not :openmcl)) 'ccl:require
- )
- (symbol-function 'new-require))
+ #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
+ #+(and :excl :allegro-v4.0) 'cltl1:require
+ #+:lispworks3.1 'common-lisp::require
+ #+:sbcl 'cl:require
+ #+(and :lispworks (not :lispworks3.1)) 'system::require
+ #+:openmcl 'cl:require
+ #+(and :mcl (not :openmcl)) 'ccl:require
+ )
+ (symbol-function 'new-require))
#+:ecl
(progn
(ext:package-lock "CL" nil)
(ext:package-lock "CL" t))
#+:lispworks
(let ((warn-packs system::*packages-for-warn-on-redefinition*))
- (declare (special system::*packages-for-warn-on-redefinition*))
- (setq system::*packages-for-warn-on-redefinition* nil)
- (setf (symbol-function
- #+:lispworks3.1 'common-lisp::require
- #-:lispworks3.1 'system::require
- )
- (symbol-function 'new-require))
- (setq system::*packages-for-warn-on-redefinition* warn-packs))
+ (declare (special system::*packages-for-warn-on-redefinition*))
+ (setq system::*packages-for-warn-on-redefinition* nil)
+ (setf (symbol-function
+ #+:lispworks3.1 'common-lisp::require
+ #-:lispworks3.1 'system::require
+ )
+ (symbol-function 'new-require))
+ (setq system::*packages-for-warn-on-redefinition* warn-packs))
#+(and allegro-version>= (version>= 4 1))
(excl:without-package-locks
(setf (symbol-function 'lisp:require)
- (symbol-function 'new-require))))))
+ (symbol-function 'new-require))))))
)
;; Let's hope things go smoothly.
(let ((module-name (string-downcase (string name))))
(when (mk:find-system module-name :load-or-nil)
- (mk:load-system module-name
- :compile-during-load t
- :verbose nil))))
+ (mk:load-system module-name
+ :compile-during-load t
+ :verbose nil))))
(pushnew 'sbcl-mk-defsystem-module-provider sb-ext:*module-provider-functions*)
)
(defun cmucl-mk-defsystem-module-provider (name)
(let ((module-name (string-downcase (string name))))
(when (mk:find-system module-name :load-or-nil)
- (mk:load-system module-name
- :compile-during-load t
- :verbose nil))))
+ (mk:load-system module-name
+ :compile-during-load t
+ :verbose nil))))
(pushnew 'cmucl-mk-defsystem-module-provider ext:*module-provider-functions*)
)
(gethash name *language-table*))
(defstruct (language (:print-function print-language))
- name ; The name of the language (a keyword)
- compiler ; The function used to compile files in the language
- loader ; The function used to load files in the language
- source-extension ; Filename extensions for source files
- binary-extension ; Filename extensions for binary files
+ name ; The name of the language (a keyword)
+ compiler ; The function used to compile files in the language
+ loader ; The function used to load files in the language
+ source-extension ; Filename extensions for source files
+ binary-extension ; Filename extensions for binary files
)
(defun print-language (language stream depth)
(format stream "#<~:@(~A~): ~A ~A>"
(language-name language)
(language-source-extension language)
- (language-binary-extension language)))
+ (language-binary-extension language)))
(defun compile-function (component)
(or (component-compiler component)
(let ((language (find-language (or (component-language component)
- :lisp))))
- (when language (language-compiler language)))
+ :lisp))))
+ (when language (language-compiler language)))
#'compile-file))
(defun load-function (component)
(or (component-loader component)
(let ((language (find-language (or (component-language component)
- :lisp))))
- (when language (language-loader language)))
+ :lisp))))
+ (when language (language-loader language)))
#'load))
(defun default-source-extension (component)
(let ((language (find-language (or (component-language component)
- :lisp))))
+ :lisp))))
(or (when language (language-source-extension language))
- (car *filename-extensions*))))
+ (car *filename-extensions*))))
(defun default-binary-extension (component)
(let ((language (find-language (or (component-language component)
- :lisp))))
+ :lisp))))
(or (when language (language-binary-extension language))
- (cdr *filename-extensions*))))
+ (cdr *filename-extensions*))))
(defmacro define-language (name &key compiler loader
- source-extension binary-extension)
+ source-extension binary-extension)
(let ((language (gensym "LANGUAGE")))
`(let ((,language (make-language :name ,name
- :compiler ,compiler
- :loader ,loader
- :source-extension ,source-extension
- :binary-extension ,binary-extension)))
+ :compiler ,compiler
+ :loader ,loader
+ :source-extension ,source-extension
+ :binary-extension ,binary-extension)))
(setf (gethash ,name *language-table*) ,language)
,name)))
(defsystem foo
:language :lisp
:components ((:module c :language :c :components ("foo" "bar"))
- (:module lisp :components ("baz" "barf"))))
+ (:module lisp :components ("baz" "barf"))))
||#
(defun scheme-compile-file (filename &rest args)
(let ((scheme-package (find-package '#:scheme)))
(apply (symbol-function (find-symbol (symbol-name 'compile-file)
- scheme-package))
- filename
- (funcall (symbol-function
- (find-symbol (symbol-name '#:interaction-environment)
- scheme-package)))
- args)))
+ scheme-package))
+ filename
+ (funcall (symbol-function
+ (find-symbol (symbol-name '#:interaction-environment)
+ scheme-package)))
+ args)))
(define-language :scheme
:compiler #'scheme-compile-file
;; command-line option to send to the program.
#+:lucid (run-program program :arguments arguments)
#+:allegro (excl:run-shell-command
- (format nil "~A~@[ ~{~A~^ ~}~]"
- program arguments))
+ (format nil "~A~@[ ~{~A~^ ~}~]"
+ program arguments))
#+(or :kcl :ecl) (system (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
#+(or :cmu :scl) (extensions:run-program program arguments)
#+:openmcl (ccl:run-program program arguments)
#+:sbcl (sb-ext:run-program program arguments)
#+:lispworks (foreign:call-system-showing-output
- (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
+ (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
#+clisp (#+lisp=cl ext:run-program #-lisp=cl lisp:run-program
program :arguments arguments)
)
:shell-type shell
:output-stream output)
- #+clisp ;XXX not exactly *trace-output*, I know
+ #+clisp ;XXX not exactly *trace-output*, I know
(ext:run-shell-command command :output :terminal :wait t)
#+openmcl
(nth-value 1
- (ccl:external-process-status
- (ccl:run-program shell
+ (ccl:external-process-status
+ (ccl:run-program shell
(list "-c" command)
- :input nil
+ :input nil
:output output
- :wait t)))
+ :wait t)))
#-(or openmcl clisp lispworks allegro scl cmu sbcl)
(error "RUN-SHELL-PROGRAM not implemented for this Lisp")
;; gcc -c foo.c -o foo.o
(declare (ignore args))
(run-unix-program *c-compiler*
- (format nil "-c ~A~@[ -o ~A~]"
- filename
- output-file)))
+ (format nil "-c ~A~@[ -o ~A~]"
+ filename
+ output-file)))
||#
#||
;; gcc -c foo.c -o foo.o
(declare (ignore args error-file))
(run-unix-program *c-compiler*
- `("-c" ,filename ,@(if output-file `("-o" ,output-file)))))
+ `("-c" ,filename ,@(if output-file `("-o" ,output-file)))))
||#
(defun run-compiler (program
- arguments
- output-file
- error-file
- error-output
- verbose)
+ arguments
+ output-file
+ error-file
+ error-output
+ verbose)
#-(or cmu scl) (declare (ignore error-file error-output))
(flet ((make-useable-stream (&rest streams)
- (apply #'make-broadcast-stream (delete nil streams)))
- )
+ (apply #'make-broadcast-stream (delete nil streams)))
+ )
(let (#+(or cmu scl) (error-file error-file)
- #+(or cmu scl) (error-file-stream nil)
- (verbose-stream nil)
- (old-timestamp (file-write-date output-file))
- (fatal-error nil)
- (output-file-written nil)
- )
+ #+(or cmu scl) (error-file-stream nil)
+ (verbose-stream nil)
+ (old-timestamp (file-write-date output-file))
+ (fatal-error nil)
+ (output-file-written nil)
+ )
(unwind-protect
- (progn
- #+(or cmu scl)
- (setf error-file
- (when error-file
- (default-output-pathname error-file
- output-file
- *compile-error-file-type*))
-
- error-file-stream
- (and error-file
- (open error-file
- :direction :output
- :if-exists :supersede)))
-
- (setf verbose-stream
- (make-useable-stream
- #+cmu error-file-stream
- (and verbose *trace-output*)))
-
- (format verbose-stream "Running ~A~@[ ~{~A~^ ~}~]~%"
- program
- arguments)
-
- (setf fatal-error
- #-(or cmu scl)
- (and (run-unix-program program arguments) nil) ; Incomplete.
- #+(or cmu scl)
- (let* ((error-output
- (make-useable-stream error-file-stream
- (if (eq error-output t)
- *error-output*
- error-output)))
- (process
- (ext:run-program program arguments
- :error error-output)))
- (not (zerop (ext:process-exit-code process)))))
-
- (setf output-file-written
- (and (probe-file output-file)
- (not (eql old-timestamp
- (file-write-date output-file)))))
-
-
- (when output-file-written
- (format verbose-stream "~A written~%" output-file))
- (format verbose-stream "Running of ~A finished~%"
- program)
- (values (and output-file-written output-file)
- fatal-error
- fatal-error))
-
- #+(or cmu scl)
- (when error-file
- (close error-file-stream)
- (unless (or fatal-error (not output-file-written))
- (delete-file error-file)))
-
- (values (and output-file-written output-file)
- fatal-error
- fatal-error)))))
+ (progn
+ #+(or cmu scl)
+ (setf error-file
+ (when error-file
+ (default-output-pathname error-file
+ output-file
+ *compile-error-file-type*))
+
+ error-file-stream
+ (and error-file
+ (open error-file
+ :direction :output
+ :if-exists :supersede)))
+
+ (setf verbose-stream
+ (make-useable-stream
+ #+cmu error-file-stream
+ (and verbose *trace-output*)))
+
+ (format verbose-stream "Running ~A~@[ ~{~A~^ ~}~]~%"
+ program
+ arguments)
+
+ (setf fatal-error
+ #-(or cmu scl)
+ (and (run-unix-program program arguments) nil) ; Incomplete.
+ #+(or cmu scl)
+ (let* ((error-output
+ (make-useable-stream error-file-stream
+ (if (eq error-output t)
+ *error-output*
+ error-output)))
+ (process
+ (ext:run-program program arguments
+ :error error-output)))
+ (not (zerop (ext:process-exit-code process)))))
+
+ (setf output-file-written
+ (and (probe-file output-file)
+ (not (eql old-timestamp
+ (file-write-date output-file)))))
+
+
+ (when output-file-written
+ (format verbose-stream "~A written~%" output-file))
+ (format verbose-stream "Running of ~A finished~%"
+ program)
+ (values (and output-file-written output-file)
+ fatal-error
+ fatal-error))
+
+ #+(or cmu scl)
+ (when error-file
+ (close error-file-stream)
+ (unless (or fatal-error (not output-file-written))
+ (delete-file error-file)))
+
+ (values (and output-file-written output-file)
+ fatal-error
+ fatal-error)))))
;;; C Language definitions.
(defun c-compile-file (filename &rest args
- &key
- (output-file t)
- (error-file t)
- (error-output t)
- (verbose *compile-verbose*)
- debug
- link
- optimize
- cflags
- definitions
- include-paths
- library-paths
- libraries
- (error t))
+ &key
+ (output-file t)
+ (error-file t)
+ (error-output t)
+ (verbose *compile-verbose*)
+ debug
+ link
+ optimize
+ cflags
+ definitions
+ include-paths
+ library-paths
+ libraries
+ (error t))
(declare (ignore args))
(flet ((map-options (flag options &optional (func #'identity))
- (mapcar #'(lambda (option)
- (format nil "~A~A" flag (funcall func option)))
- options))
- )
+ (mapcar #'(lambda (option)
+ (format nil "~A~A" flag (funcall func option)))
+ options))
+ )
(let* ((output-file (default-output-pathname output-file filename "o"))
- (arguments
- `(,@(when (not link) '("-c"))
- ,@(when debug '("-g"))
- ,@(when optimize (list (format nil "-O~D" optimize)))
- ,@cflags
- ,@(map-options
- "-D" definitions
- #'(lambda (definition)
- (if (atom definition)
- definition
- (apply #'format nil "~A=~A" definition))))
- ,@(map-options "-I" include-paths #'truename)
- ,(namestring (truename filename))
- "-o"
- ,(namestring (translate-logical-pathname output-file))
- ,@(map-options "-L" library-paths #'truename)
- ,@(map-options "-l" libraries))))
+ (arguments
+ `(,@(when (not link) '("-c"))
+ ,@(when debug '("-g"))
+ ,@(when optimize (list (format nil "-O~D" optimize)))
+ ,@cflags
+ ,@(map-options
+ "-D" definitions
+ #'(lambda (definition)
+ (if (atom definition)
+ definition
+ (apply #'format nil "~A=~A" definition))))
+ ,@(map-options "-I" include-paths #'truename)
+ ,(namestring (truename filename))
+ "-o"
+ ,(namestring (translate-logical-pathname output-file))
+ ,@(map-options "-L" library-paths #'truename)
+ ,@(map-options "-l" libraries))))
(multiple-value-bind (output-file warnings fatal-errors)
- (run-compiler *c-compiler*
- arguments
- output-file
- error-file
- error-output
- verbose)
- (if (and error (or (not output-file) fatal-errors))
- (error "Compilation failed")
- (values output-file warnings fatal-errors))))))
+ (run-compiler *c-compiler*
+ arguments
+ output-file
+ error-file
+ error-output
+ verbose)
+ (if (and error (or (not output-file) fatal-errors))
+ (error "Compilation failed")
+ (values output-file warnings fatal-errors))))))
(define-language :c
#+:allegro #'load
#+(or :cmu :scl) #'alien:load-foreign
#+:sbcl #'sb-alien:load-foreign
- #+(and :lispworks :unix (not :linux) (not :macosx)) #'link-load:read-foreign-modules
- #+(and :lispworks :unix (or :linux :macosx)) #'fli:register-module
- #+(and :lispworks :win32) #'fli:register-module
+ #+(and :lispworks :unix (not :linux) (not :macosx)) #'link-load:read-foreign-modules
+ #+(and :lispworks :unix (or :linux :macosx)) #'fli:register-module
+ #+(and :lispworks :win32) #'fli:register-module
#+(or :ecl :gcl :kcl) #'load ; should be enough.
#-(or :lucid
- :allegro
- :cmu
- :sbcl
- :scl
- :lispworks
- :ecl :gcl :kcl)
- (lambda (&rest args)
- (declare (ignore args))
- (cerror "Continue returning NIL."
- "Loader not defined for C foreign libraries in ~A ~A."
- (lisp-implementation-type)
- (lisp-implementation-version)))
+ :allegro
+ :cmu
+ :sbcl
+ :scl
+ :lispworks
+ :ecl :gcl :kcl)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (cerror "Continue returning NIL."
+ "Loader not defined for C foreign libraries in ~A ~A."
+ (lisp-implementation-type)
+ (lisp-implementation-version)))
:source-extension "c"
:binary-extension "o")
(defparameter *fortran-options* '("-O"))
(defun fortran-compile-file (filename &rest args
- &key output-file error-file
- &allow-other-keys)
+ &key output-file error-file
+ &allow-other-keys)
(declare (ignore error-file args))
(let ((arg-list
- (append *fortran-options*
- `("-c" ,filename ,@(if output-file `("-o" ,output-file))))))
+ (append *fortran-options*
+ `("-c" ,filename ,@(if output-file `("-o" ,output-file))))))
(run-unix-program *fortran-compiler* arg-list)))
(let ((args (list "rv" (truename libname))))
(format t ";;; Building archive ~A~%" libname)
(run-unix-program *ar-program*
- (append args
- (mapcar #'truename (directory directory))))))
+ (append args
+ (mapcar #'truename (directory directory))))))
;;; ********************************
(let ((changed (compile-file-operation component force)))
;; Return T if the file had to be recompiled and reloaded.
(if (and changed (component-compile-only component))
- ;; For files which are :compile-only T, compiling the file
- ;; satisfies the need to load.
- changed
- ;; If the file wasn't compiled, or :compile-only is nil,
- ;; check to see if it needs to be loaded.
- (and (load-file-operation component force) ; FORCE was CHANGED ???
- changed))))
+ ;; For files which are :compile-only T, compiling the file
+ ;; satisfies the need to load.
+ changed
+ ;; If the file wasn't compiled, or :compile-only is nil,
+ ;; check to see if it needs to be loaded.
+ (and (load-file-operation component force) ; FORCE was CHANGED ???
+ changed))))
(defun unmunge-lucid (namestring)
;; use of defsystem, but some defsystem users are depending on
;; using relative pathnames (at least three folks reported the problem).
(cond ((null-string namestring) namestring)
- ((char= (char namestring 0) #\/)
- ;; It's an absolute namestring
- namestring)
- (t
- ;; Ugly, but seems to fix the problem.
- (concatenate 'string "./" namestring))))
+ ((char= (char namestring 0) #\/)
+ ;; It's an absolute namestring
+ namestring)
+ (t
+ ;; Ugly, but seems to fix the problem.
+ (concatenate 'string "./" namestring))))
#+gcl
(defun ensure-directories-exist (arg0 &key verbose)
(defun compile-file-operation (component force)
;; Returns T if the file had to be compiled.
(let ((must-compile
- ;; For files which are :load-only T, loading the file
- ;; satisfies the demand to recompile.
- (and (null (component-load-only component)) ; not load-only
- (or (find force '(:all :new-source-all t) :test #'eq)
- (and (find force '(:new-source :new-source-and-dependents)
- :test #'eq)
- (needs-compilation component nil)))))
- (source-pname (component-full-pathname component :source)))
+ ;; For files which are :load-only T, loading the file
+ ;; satisfies the demand to recompile.
+ (and (null (component-load-only component)) ; not load-only
+ (or (find force '(:all :new-source-all t) :test #'eq)
+ (and (find force '(:new-source :new-source-and-dependents)
+ :test #'eq)
+ (needs-compilation component nil)))))
+ (source-pname (component-full-pathname component :source)))
(cond ((and must-compile (probe-file source-pname))
- (with-tell-user ("Compiling source" component :source)
- (let ((output-file
- #+:lucid
- (unmunge-lucid (component-full-pathname component
- :binary))
- #-:lucid
- (component-full-pathname component :binary)))
-
- ;; make certain the directory we need to write to
- ;; exists [pvaneynd@debian.org 20001114]
- ;; Added PATHNAME-HOST following suggestion by John
- ;; DeSoi [marcoxa@sourceforge.net 20020529]
-
- (ensure-directories-exist
- (make-pathname
- :host (pathname-host output-file)
- :directory (pathname-directory output-file)))
-
- (or *oos-test*
- (apply (compile-function component)
- source-pname
- :output-file
- output-file
-
- #+(or :cmu :scl)
- :error-file
-
- #+(or :cmu :scl)
- (and *cmu-errors-to-file*
- (component-full-pathname component :error))
-
- #+cmu
- :error-output
- #+cmu
- *cmu-errors-to-terminal*
-
- (component-compiler-options component)
- ))))
- must-compile)
- (must-compile
- (tell-user "Source file not found. Not compiling"
- component :source :no-dots :force)
- nil)
- (t nil))))
+ (with-tell-user ("Compiling source" component :source)
+ (let ((output-file
+ #+:lucid
+ (unmunge-lucid (component-full-pathname component
+ :binary))
+ #-:lucid
+ (component-full-pathname component :binary)))
+
+ ;; make certain the directory we need to write to
+ ;; exists [pvaneynd@debian.org 20001114]
+ ;; Added PATHNAME-HOST following suggestion by John
+ ;; DeSoi [marcoxa@sourceforge.net 20020529]
+
+ (ensure-directories-exist
+ (make-pathname
+ :host (pathname-host output-file)
+ :directory (pathname-directory output-file)))
+
+ (or *oos-test*
+ (apply (compile-function component)
+ source-pname
+ :output-file
+ output-file
+
+ #+(or :cmu :scl)
+ :error-file
+
+ #+(or :cmu :scl)
+ (and *cmu-errors-to-file*
+ (component-full-pathname component :error))
+
+ #+cmu
+ :error-output
+ #+cmu
+ *cmu-errors-to-terminal*
+
+ (component-compiler-options component)
+ ))))
+ must-compile)
+ (must-compile
+ (tell-user "Source file not found. Not compiling"
+ component :source :no-dots :force)
+ nil)
+ (t nil))))
;;; compiled-file-p --
#+clisp
(with-open-file (in file-name :direction :input :if-does-not-exist nil)
(handler-bind ((error (lambda (c) (declare (ignore c))
- (return-from compiled-file-p nil))))
- (and in (char= #\( (peek-char nil in nil #\a))
- (let ((form (read in nil nil)))
- (and (consp form)
- (eq (car form) 'SYSTEM::VERSION)
- (null (eval form)))))))
+ (return-from compiled-file-p nil))))
+ (and in (char= #\( (peek-char nil in nil #\a))
+ (let ((form (read in nil nil)))
+ (and (consp form)
+ (eq (car form) 'SYSTEM::VERSION)
+ (null (eval form)))))))
#-clisp (declare (ignorable file-name))
#-clisp t))
;; Compares the component's load-time against the file-write-date of
;; the files on disk.
(let ((load-time (component-load-time component))
- (source-pname (component-full-pathname component :source))
- (binary-pname (component-full-pathname component :binary)))
+ (source-pname (component-full-pathname component :source))
+ (binary-pname (component-full-pathname component :binary)))
(or
#|| ISI Extension ||#
(component-load-always component)
(null load-time)
;; Binary is newer.
(when (and check-binary
- (probe-file binary-pname))
+ (probe-file binary-pname))
(< load-time
- (file-write-date binary-pname)))
+ (file-write-date binary-pname)))
;; Source is newer.
(when (and check-source
- (probe-file source-pname))
+ (probe-file source-pname))
(< load-time
- (file-write-date source-pname))))))
+ (file-write-date source-pname))))))
;;; Need to completely rework this function...
(defun load-file-operation (component force)
;; Returns T if the file had to be loaded
(let* ((binary-pname (component-full-pathname component :binary))
- (source-pname (component-full-pathname component :source))
- (binary-exists (probe-file binary-pname))
- (source-exists (probe-file source-pname))
- (source-needs-loading (needs-loading component t nil))
- (binary-needs-loading (needs-loading component nil t))
- ;; needs-compilation has an implicit source-exists in it.
- (needs-compilation (if (component-load-only component)
- source-needs-loading
- (needs-compilation component force)))
- (check-for-new-source
- ;; If force is :new-source*, we're checking for files
- ;; whose source is newer than the compiled versions.
- (find force '(:new-source :new-source-and-dependents :new-source-all)
- :test #'eq))
- (load-binary (or (find force '(:all :new-source-all t) :test #'eq)
- binary-needs-loading))
- (load-source
- (or *load-source-instead-of-binary*
- (and load-binary (component-load-only component))
- (and check-for-new-source needs-compilation)))
- (compile-and-load
- (and needs-compilation
+ (source-pname (component-full-pathname component :source))
+ (binary-exists (probe-file binary-pname))
+ (source-exists (probe-file source-pname))
+ (source-needs-loading (needs-loading component t nil))
+ (binary-needs-loading (needs-loading component nil t))
+ ;; needs-compilation has an implicit source-exists in it.
+ (needs-compilation (if (component-load-only component)
+ source-needs-loading
+ (needs-compilation component force)))
+ (check-for-new-source
+ ;; If force is :new-source*, we're checking for files
+ ;; whose source is newer than the compiled versions.
+ (find force '(:new-source :new-source-and-dependents :new-source-all)
+ :test #'eq))
+ (load-binary (or (find force '(:all :new-source-all t) :test #'eq)
+ binary-needs-loading))
+ (load-source
+ (or *load-source-instead-of-binary*
+ (and load-binary (component-load-only component))
+ (and check-for-new-source needs-compilation)))
+ (compile-and-load
+ (and needs-compilation
(or load-binary check-for-new-source)
- (compile-and-load-source-if-no-binary component)))
+ (compile-and-load-source-if-no-binary component)))
)
;; When we're trying to minimize the files loaded to only those
;; that need be, restrict the values of load-source and load-binary
;; the load-time.
(when (and *minimal-load*
(not (find force '(:all :new-source-all)
- :test #'eq)))
+ :test #'eq)))
(when load-source (setf load-source source-needs-loading))
(when load-binary (setf load-binary binary-needs-loading)))
(when (or load-source load-binary compile-and-load)
(cond (compile-and-load
- ;; If we're loading the binary and it is old or nonexistent,
- ;; and the user says yes, compile and load the source.
- (compile-file-operation component t)
- (with-tell-user ("Loading binary" component :binary)
- (or *oos-test*
- (progn
- (funcall (load-function component) binary-pname)
- (setf (component-load-time component)
- (file-write-date binary-pname)))))
- t)
- ((and source-exists
- (or (and load-source ; implicit needs-comp...
- (or *load-source-instead-of-binary*
- (component-load-only component)
- (not *compile-during-load*)))
- (and load-binary
+ ;; If we're loading the binary and it is old or nonexistent,
+ ;; and the user says yes, compile and load the source.
+ (compile-file-operation component t)
+ (with-tell-user ("Loading binary" component :binary)
+ (or *oos-test*
+ (progn
+ (funcall (load-function component) binary-pname)
+ (setf (component-load-time component)
+ (file-write-date binary-pname)))))
+ t)
+ ((and source-exists
+ (or (and load-source ; implicit needs-comp...
+ (or *load-source-instead-of-binary*
+ (component-load-only component)
+ (not *compile-during-load*)))
+ (and load-binary
(not binary-exists)
- (load-source-if-no-binary component))))
- ;; Load the source if the source exists and:
- ;; o we're loading binary and it doesn't exist
- ;; o we're forcing it
- ;; o we're loading new source and user wasn't asked to compile
- (with-tell-user ("Loading source" component :source)
- (or *oos-test*
- (progn
- (funcall (load-function component) source-pname)
- (setf (component-load-time component)
- (file-write-date source-pname)))))
- t)
- ((and binary-exists load-binary)
- (with-tell-user ("Loading binary" component :binary)
- (or *oos-test*
- (progn
- (funcall (load-function component) binary-pname)
- (setf (component-load-time component)
- (file-write-date binary-pname)))))
- t)
- ((and (not binary-exists) (not source-exists))
- (tell-user-no-files component :force)
- (when *files-missing-is-an-error*
- (cerror "Continue, ignoring missing files."
- "~&Source file ~S ~:[and binary file ~S ~;~]do not exist."
- source-pname
- (or *load-source-if-no-binary*
- *load-source-instead-of-binary*)
- binary-pname))
- nil)
- (t
- nil)))))
+ (load-source-if-no-binary component))))
+ ;; Load the source if the source exists and:
+ ;; o we're loading binary and it doesn't exist
+ ;; o we're forcing it
+ ;; o we're loading new source and user wasn't asked to compile
+ (with-tell-user ("Loading source" component :source)
+ (or *oos-test*
+ (progn
+ (funcall (load-function component) source-pname)
+ (setf (component-load-time component)
+ (file-write-date source-pname)))))
+ t)
+ ((and binary-exists load-binary)
+ (with-tell-user ("Loading binary" component :binary)
+ (or *oos-test*
+ (progn
+ (funcall (load-function component) binary-pname)
+ (setf (component-load-time component)
+ (file-write-date binary-pname)))))
+ t)
+ ((and (not binary-exists) (not source-exists))
+ (tell-user-no-files component :force)
+ (when *files-missing-is-an-error*
+ (cerror "Continue, ignoring missing files."
+ "~&Source file ~S ~:[and binary file ~S ~;~]do not exist."
+ source-pname
+ (or *load-source-if-no-binary*
+ *load-source-instead-of-binary*)
+ binary-pname))
+ nil)
+ (t
+ nil)))))
(eval-when (load eval)
(component-operation :clean 'delete-binaries-operation)
)
(defun delete-binaries-operation (component force)
(when (or (eq force :all)
- (eq force t)
- (and (find force '(:new-source :new-source-and-dependents
- :new-source-all)
- :test #'eq)
- (needs-compilation component nil)))
+ (eq force t)
+ (and (find force '(:new-source :new-source-and-dependents
+ :new-source-all)
+ :test #'eq)
+ (needs-compilation component nil)))
(let ((binary-pname (component-full-pathname component :binary)))
(when (probe-file binary-pname)
- (with-tell-user ("Deleting binary" component :binary)
- (or *oos-test*
- (delete-file binary-pname)))))))
+ (with-tell-user ("Deleting binary" component :binary)
+ (or *oos-test*
+ (delete-file binary-pname)))))))
;; when the operation = :compile, we can assume the binary exists in test mode.
-;; ((and *oos-test*
-;; (eq operation :compile)
-;; (probe-file (component-full-pathname component :source)))
-;; (with-tell-user ("Loading binary" component :binary)))
+;; ((and *oos-test*
+;; (eq operation :compile)
+;; (probe-file (component-full-pathname component :source)))
+;; (with-tell-user ("Loading binary" component :binary)))
(defun binary-exists (component)
(probe-file (component-full-pathname component :binary)))
;;; or old-binary
(defun compile-and-load-source-if-no-binary (component)
(when (not (or *load-source-instead-of-binary*
- (and *load-source-if-no-binary*
- (not (binary-exists component)))))
+ (and *load-source-if-no-binary*
+ (not (binary-exists component)))))
(cond ((component-load-only component)
- #||
- (let ((prompt (prompt-string component)))
- (format t "~A- File ~A is load-only, ~
+ #||
+ (let ((prompt (prompt-string component)))
+ (format t "~A- File ~A is load-only, ~
~&~A not compiling."
- prompt
- (component-full-pathname component :source)
- prompt))
- ||#
- nil)
- ((eq *compile-during-load* :query)
- (let* ((prompt (prompt-string component))
- (compile-source
- (y-or-n-p-wait
- #\y 30
- "~A- Binary file ~A is old or does not exist. ~
+ prompt
+ (component-full-pathname component :source)
+ prompt))
+ ||#
+ nil)
+ ((eq *compile-during-load* :query)
+ (let* ((prompt (prompt-string component))
+ (compile-source
+ (y-or-n-p-wait
+ #\y 30
+ "~A- Binary file ~A is old or does not exist. ~
~&~A Compile (and load) source file ~A instead? "
- prompt
- (component-full-pathname component :binary)
- prompt
- (component-full-pathname component :source))))
- (unless (y-or-n-p-wait
- #\y 30
- "~A- Should I bother you if this happens again? "
- prompt)
- (setq *compile-during-load*
- (y-or-n-p-wait
- #\y 30
- "~A- Should I compile while loading the system? "
- prompt))) ; was compile-source, then t
- compile-source))
- (*compile-during-load*)
- (t nil))))
+ prompt
+ (component-full-pathname component :binary)
+ prompt
+ (component-full-pathname component :source))))
+ (unless (y-or-n-p-wait
+ #\y 30
+ "~A- Should I bother you if this happens again? "
+ prompt)
+ (setq *compile-during-load*
+ (y-or-n-p-wait
+ #\y 30
+ "~A- Should I compile while loading the system? "
+ prompt))) ; was compile-source, then t
+ compile-source))
+ (*compile-during-load*)
+ (t nil))))
(defun load-source-if-no-binary (component)
(and (not *load-source-instead-of-binary*)
(or (and *load-source-if-no-binary*
- (not (binary-exists component)))
- (component-load-only component)
- (when *bother-user-if-no-binary*
- (let* ((prompt (prompt-string component))
- (load-source
- (y-or-n-p-wait #\y 30
- "~A- Binary file ~A does not exist. ~
+ (not (binary-exists component)))
+ (component-load-only component)
+ (when *bother-user-if-no-binary*
+ (let* ((prompt (prompt-string component))
+ (load-source
+ (y-or-n-p-wait #\y 30
+ "~A- Binary file ~A does not exist. ~
~&~A Load source file ~A instead? "
- prompt
- (component-full-pathname component :binary)
- prompt
- (component-full-pathname component :source))))
- (setq *bother-user-if-no-binary*
- (y-or-n-p-wait #\n 30
- "~A- Should I bother you if this happens again? "
- prompt ))
- (unless *bother-user-if-no-binary*
- (setq *load-source-if-no-binary* load-source))
- load-source)))))
+ prompt
+ (component-full-pathname component :binary)
+ prompt
+ (component-full-pathname component :source))))
+ (setq *bother-user-if-no-binary*
+ (y-or-n-p-wait #\n 30
+ "~A- Should I bother you if this happens again? "
+ prompt ))
+ (unless *bother-user-if-no-binary*
+ (setq *load-source-if-no-binary* load-source))
+ load-source)))))
;;; ********************************
;;; Allegro Toplevel Commands ******
#+:allegro
(top-level:alias ("compile-system" 8)
(system &key force (minimal-load mk:*minimal-load*)
- test verbose version)
+ test verbose version)
"Compile the specified system"
(mk:compile-system system :force force
- :minimal-load minimal-load
- :test test :verbose verbose
- :version version))
+ :minimal-load minimal-load
+ :test test :verbose verbose
+ :version version))
#+:allegro
(top-level:alias ("load-system" 5)
(system &key force (minimal-load mk:*minimal-load*)
- (compile-during-load mk:*compile-during-load*)
- test verbose version)
+ (compile-during-load mk:*compile-during-load*)
+ test verbose version)
"Compile the specified system"
(mk:load-system system :force force
- :minimal-load minimal-load
- :compile-during-load compile-during-load
- :test test :verbose verbose
- :version version))
+ :minimal-load minimal-load
+ :compile-during-load compile-during-load
+ :test test :verbose verbose
+ :version version))
#+:allegro
(top-level:alias ("show-system" 5) (system)
"Delete binaries in the specified system."
(mk:clean-system system :force force
- :test test :verbose verbose
- :version version))
+ :test test :verbose verbose
+ :version version))
#+:allegro
(top-level:alias ("edit-system" 7)
"Load system source files into Emacs."
(mk:edit-system system :force force
- :test test :verbose verbose
- :version version))
+ :test test :verbose verbose
+ :version version))
#+:allegro
(top-level:alias ("hardcopy-system" 9)
"Hardcopy files in the specified system."
(mk:hardcopy-system system :force force
- :test test :verbose verbose
- :version version))
+ :test test :verbose verbose
+ :version version))
#+:allegro
(top-level:alias ("make-system-tag-table" 13) (system)
;;; ********************************
#+:excl
(defun allegro-make-system-fasl (system destination
- &optional (include-dependents t))
+ &optional (include-dependents t))
(excl:shell
(format nil "rm -f ~A; cat~{ ~A~} > ~A"
- destination
- (if include-dependents
- (files-in-system-and-dependents system :all :binary)
- (files-in-system system :all :binary))
- destination)))
+ destination
+ (if include-dependents
+ (files-in-system-and-dependents system :all :binary)
+ (files-in-system system :all :binary))
+ destination)))
(defun files-which-need-compilation (system)
(mapcar #'(lambda (comp) (component-full-pathname comp :source))
- (remove nil
- (file-components-in-component
- (find-system system :load) :new-source))))
+ (remove nil
+ (file-components-in-component
+ (find-system system :load) :new-source))))
(defun files-in-system-and-dependents (name &optional (force :all)
- (type :source) version)
+ (type :source) version)
;; Returns a list of the pathnames in system and dependents in load order.
(let ((system (find-system name :load)))
(multiple-value-bind (*version-dir* *version-replace*)
- (translate-version version)
+ (translate-version version)
(let ((*version* version))
- (let ((result (file-pathnames-in-component system type force)))
- (dolist (dependent (reverse (component-depends-on system)))
- (setq result
- (append (files-in-system-and-dependents dependent
- force type version)
- result)))
- result)))))
+ (let ((result (file-pathnames-in-component system type force)))
+ (dolist (dependent (reverse (component-depends-on system)))
+ (setq result
+ (append (files-in-system-and-dependents dependent
+ force type version)
+ result)))
+ result)))))
(defun files-in-system (name &optional (force :all) (type :source) version)
;; Returns a list of the pathnames in system in load order.
name
(find-system name :load))))
(multiple-value-bind (*version-dir* *version-replace*)
- (translate-version version)
+ (translate-version version)
(let ((*version* version))
- (file-pathnames-in-component system type force)))))
+ (file-pathnames-in-component system type force)))))
(defun file-pathnames-in-component (component type &optional (force :all))
(mapcar #'(lambda (comp) (component-full-pathname comp type))
- (file-components-in-component component force)))
+ (file-components-in-component component force)))
(defun file-components-in-component (component &optional (force :all)
- &aux result changed)
+ &aux result changed)
(case (component-type component)
((:file :private-file)
(when (setq changed
- (or (find force '(:all t) :test #'eq)
- (and (not (non-empty-listp force))
- (needs-compilation component nil))))
+ (or (find force '(:all t) :test #'eq)
+ (and (not (non-empty-listp force))
+ (needs-compilation component nil))))
(setq result
- (list component))))
+ (list component))))
((:module :system :subsystem :defsystem)
(dolist (module (component-components component))
(multiple-value-bind (r c)
- (file-components-in-component
- module
- (cond ((and (some #'(lambda (dependent)
- (member dependent changed))
- (component-depends-on module))
- (or (non-empty-listp force)
- (eq force :new-source-and-dependents)))
- ;; The component depends on a changed file and force agrees.
- :all)
- ((and (non-empty-listp force)
- (member (component-name module) force
- :test #'string-equal :key #'string))
- ;; Force is a list of modules and the component is
- ;; one of them.
- :all)
- (t force)))
- (when c
- (push module changed)
- (setq result (append result r)))))))
+ (file-components-in-component
+ module
+ (cond ((and (some #'(lambda (dependent)
+ (member dependent changed))
+ (component-depends-on module))
+ (or (non-empty-listp force)
+ (eq force :new-source-and-dependents)))
+ ;; The component depends on a changed file and force agrees.
+ :all)
+ ((and (non-empty-listp force)
+ (member (component-name module) force
+ :test #'string-equal :key #'string))
+ ;; Force is a list of modules and the component is
+ ;; one of them.
+ :all)
+ (t force)))
+ (when c
+ (push module changed)
+ (setq result (append result r)))))))
(values result changed))
(setf (symbol-function 'oos) (symbol-function 'operate-on-system))
;;; Should this conditionalization be (or :mcl (and :CCL (not :lispworks)))?
#|
- #+:ccl
- (defun edit-operation (component force)
+ #+:ccl
+ (defun edit-operation (component force)
"Always returns nil, i.e. component not changed."
(declare (ignore force))
;;
(ed full-pathname)))
nil)
- #+:allegro
- (defun edit-operation (component force)
+ #+:allegro
+ (defun edit-operation (component force)
"Edit a component - always returns nil, i.e. component not changed."
(declare (ignore force))
(let ((full-pathname (component-full-pathname component :source)))
(ed full-pathname))
nil)
- #+(or :ccl :allegro)
- (make::component-operation :edit 'edit-operation)
- #+(or :ccl :allegro)
- (make::component-operation 'edit 'edit-operation)
- |#
+ #+(or :ccl :allegro)
+ (make::component-operation :edit 'edit-operation)
+ #+(or :ccl :allegro)
+ (make::component-operation 'edit 'edit-operation)
+ |#
;;; *** Hardcopy System ***
(defparameter *print-command* "enscript -2Gr" ; "lpr"
(declare (ignore force))
(let ((full-pathname (component-full-pathname component :source)))
(excl:run-shell-command (format nil "~A ~A"
- *print-command* full-pathname)))
+ *print-command* full-pathname)))
nil)
#+:allegro
(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)
(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)
;; 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)
;; 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)))
(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))
(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)
(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))))
(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
(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")
(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
(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
(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
(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)
(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+)
(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")
(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))))
(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))))
(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 *))
(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))
(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")
(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);
(fd_set*)#1->foreign.data,
NULL, &tv);
@(return 1) = errno; }"
- :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)))))))
+ :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)))))))
;;; Wait for up to timeout seconds for an event to happen. Make sure all
(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"))
(if (c-inline () () :object
"
{
- WSADATA wsadata;
- cl_object output;
- ecl_disable_interrupts();
- if (WSAStartup(MAKEWORD(2,2), &wsadata) == NO_ERROR)
- output = ECL_T;
- else
- output = ECL_NIL;
- ecl_enable_interrupts();
- @(return) = output;
+ WSADATA wsadata;
+ cl_object output;
+ ecl_disable_interrupts();
+ if (WSAStartup(MAKEWORD(2,2), &wsadata) == NO_ERROR)
+ output = ECL_T;
+ else
+ output = ECL_NIL;
+ ecl_enable_interrupts();
+ @(return) = output;
}")
(setf +wsock-initialized+ t)
- (error "Unable to initialize Windows Socket library"))))
+ (error "Unable to initialize Windows Socket library"))))
(wsock-initialize)
); #+:wsock
(defmacro define-c-constants (&rest args)
`(let () ; Prevents evaluation of constant value form
,@(loop
- for (lisp-name c-name) on args by #'cddr
- collect `(defconstant ,lisp-name (c-constant ,c-name))))))
+ for (lisp-name c-name) on args by #'cddr
+ collect `(defconstant ,lisp-name (c-constant ,c-name))))))
#+:wsock
(Clines
((name :initarg :name :accessor host-ent-name)
(aliases :initarg :aliases :accessor host-ent-aliases)
(address-type :initarg :type :accessor host-ent-address-type)
- ; presently always AF_INET
+ ; presently always AF_INET
(addresses :initarg :addresses :accessor host-ent-addresses))
(:documentation ""))
weird stuff - see gethostbyname(3) for grisly details."
(let ((host-ent (make-instance 'host-ent)))
(if (c-inline (host-name host-ent
- #'(setf host-ent-name)
- #'(setf host-ent-aliases)
- #'(setf host-ent-address-type)
- #'(setf host-ent-addresses))
- (:cstring t t t t t) t
- "
+ #'(setf host-ent-name)
+ #'(setf host-ent-aliases)
+ #'(setf host-ent-address-type)
+ #'(setf host-ent-addresses))
+ (:cstring t t t t t) t
+ "
{
- struct hostent *hostent = gethostbyname(#0);
+ struct hostent *hostent = gethostbyname(#0);
- if (hostent != NULL) {
- char **aliases;
+ if (hostent != NULL) {
+ char **aliases;
char **addrs;
cl_object aliases_list = ECL_NIL;
cl_object addr_list = ECL_NIL;
int length = hostent->h_length;
- funcall(3,#2,make_simple_base_string(hostent->h_name),#1);
+ funcall(3,#2,make_simple_base_string(hostent->h_name),#1);
funcall(3,#4,ecl_make_integer(hostent->h_addrtype),#1);
for (aliases = hostent->h_aliases; *aliases != NULL; aliases++) {
funcall(3,#5,addr_list,#1);
@(return) = #1;
- } else {
- @(return) = ECL_NIL;
- }
+ } else {
+ @(return) = ECL_NIL;
+ }
}"
- :side-effects t)
- host-ent
- (name-service-error "get-host-by-name"))))
+ :side-effects t)
+ host-ent
+ (name-service-error "get-host-by-name"))))
(defun get-host-by-address (address)
(assert (and (typep address 'vector)
- (= (length address) 4)))
+ (= (length address) 4)))
(let ((host-ent (make-instance 'host-ent)))
(if
(c-inline (address host-ent
- #'(setf host-ent-name)
- #'(setf host-ent-aliases)
- #'(setf host-ent-address-type)
- #'(setf host-ent-addresses))
- (t t t t t t) t
- "
+ #'(setf host-ent-name)
+ #'(setf host-ent-aliases)
+ #'(setf host-ent-address-type)
+ #'(setf host-ent-addresses))
+ (t t t t t t) t
+ "
{
- unsigned char vector[4];
- struct hostent *hostent;
- vector[0] = fixint(ecl_aref(#0,0));
- vector[1] = fixint(ecl_aref(#0,1));
- vector[2] = fixint(ecl_aref(#0,2));
- vector[3] = fixint(ecl_aref(#0,3));
- ecl_disable_interrupts();
- hostent = gethostbyaddr(wincoerce(const char *, vector),4,AF_INET);
- ecl_enable_interrupts();
-
- if (hostent != NULL) {
- char **aliases;
+ unsigned char vector[4];
+ struct hostent *hostent;
+ vector[0] = fixint(ecl_aref(#0,0));
+ vector[1] = fixint(ecl_aref(#0,1));
+ vector[2] = fixint(ecl_aref(#0,2));
+ vector[3] = fixint(ecl_aref(#0,3));
+ ecl_disable_interrupts();
+ hostent = gethostbyaddr(wincoerce(const char *, vector),4,AF_INET);
+ ecl_enable_interrupts();
+
+ if (hostent != NULL) {
+ char **aliases;
char **addrs;
cl_object aliases_list = ECL_NIL;
cl_object addr_list = ECL_NIL;
int length = hostent->h_length;
- funcall(3,#2,make_simple_base_string(hostent->h_name),#1);
+ funcall(3,#2,make_simple_base_string(hostent->h_name),#1);
funcall(3,#4,ecl_make_integer(hostent->h_addrtype),#1);
for (aliases = hostent->h_aliases; *aliases != NULL; aliases++) {
funcall(3,#5,addr_list,#1);
@(return) = #1;
- } else {
- @(return) = ECL_NIL;
- }
+ } else {
+ @(return) = ECL_NIL;
+ }
}"
- :side-effects t)
+ :side-effects t)
host-ent
(name-service-error "get-host-by-address"))))
(defclass socket ()
((file-descriptor :initarg :descriptor
- :reader socket-file-descriptor)
+ :reader socket-file-descriptor)
(family :initform (error "No socket family")
- :reader socket-family)
+ :reader socket-family)
(protocol :initarg :protocol
- :reader socket-protocol
- :documentation "Protocol used by the socket. If a
+ :reader socket-protocol
+ :documentation "Protocol used by the socket. If a
keyword, the symbol-name of the keyword will be passed to
GET-PROTOCOL-BY-NAME downcased, and the returned value used as
protocol. Other values are used as-is.")
(type :initarg :type
- :reader socket-type
- :initform :stream
- :documentation "Type of the socket: :STREAM or :DATAGRAM.")
+ :reader socket-type
+ :initform :stream
+ :documentation "Type of the socket: :STREAM or :DATAGRAM.")
(stream)
#+:wsock
(non-blocking-p :initform nil))
(princ (slot-value object 'file-descriptor) stream)))
(defmethod shared-initialize :after ((socket socket) slot-names
- &key protocol type
- &allow-other-keys)
+ &key protocol type
+ &allow-other-keys)
(let* ((proto-num
- (cond ((and protocol (keywordp protocol))
- (get-protocol-by-name (string-downcase (symbol-name protocol))))
- (protocol protocol)
- (t 0)))
- (fd (or (and (slot-boundp socket 'file-descriptor)
- (socket-file-descriptor socket))
- #+:wsock
- (and (member (socket-family socket) (list +af-named-pipe+ +af-local+)) 0)
- (ff-socket (socket-family socket)
- (ecase (or type
- (socket-type socket))
- ((:datagram) (c-constant "SOCK_DGRAM"))
- ((:stream) (c-constant "SOCK_STREAM")))
- proto-num))))
+ (cond ((and protocol (keywordp protocol))
+ (get-protocol-by-name (string-downcase (symbol-name protocol))))
+ (protocol protocol)
+ (t 0)))
+ (fd (or (and (slot-boundp socket 'file-descriptor)
+ (socket-file-descriptor socket))
+ #+:wsock
+ (and (member (socket-family socket) (list +af-named-pipe+ +af-local+)) 0)
+ (ff-socket (socket-family socket)
+ (ecase (or type
+ (socket-type socket))
+ ((:datagram) (c-constant "SOCK_DGRAM"))
+ ((:stream) (c-constant "SOCK_STREAM")))
+ proto-num))))
(if (= fd -1) (socket-error "socket"))
(setf (slot-value socket 'file-descriptor) fd
- (slot-value socket 'protocol) proto-num)
+ (slot-value socket 'protocol) proto-num)
#+ ignore
(sb-ext:finalize socket (lambda () (sockint::close fd)))))
grow to before new connection attempts are refused. See also listen(2)"))
(defgeneric socket-receive (socket buffer length
- &key
- oob peek waitall element-type)
+ &key
+ oob peek waitall element-type)
(:documentation "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is
used, so at least one of these two arguments must be non-NIL. If
small"))
(defgeneric socket-send (socket buffer length
- &key
+ &key
address external-format oob eor dontroute dontwait
- nosignal confirm more)
+ nosignal confirm more)
(:documentation "Send length octets from buffer into socket, using sendto(2).
If buffer is a string, it will converted to octets according to external-format&
If length is nil, the length of the octet buffer is used. The format of address
(close (two-way-stream-output-stream stream))
#-threads
(close stream)) ;; closes fd indirectly
- (slot-makunbound socket 'stream))
- ((= (socket-close-low-level socket) -1)
- (socket-error "close")))
+ (slot-makunbound socket 'stream))
+ ((= (socket-close-low-level socket) -1)
+ (socket-error "close")))
(setf (slot-value socket 'file-descriptor) -1))))
(ffi::clines "
static void *
safe_buffer_pointer(cl_object x, cl_index size)
{
- cl_type t = type_of(x);
- int ok = 0;
- if (t == t_base_string) {
- ok = (size <= x->base_string.dim);
- } else if (t == t_vector) {
- cl_elttype aet = (cl_elttype)x->vector.elttype;
- if (aet == aet_b8 || aet == aet_i8 || aet == aet_bc) {
- ok = (size <= x->vector.dim);
- } else if (aet == aet_fix || aet == aet_index) {
- cl_index divisor = sizeof(cl_index);
- size = (size + divisor - 1) / divisor;
- ok = (size <= x->vector.dim);
- }
- }
- if (!ok) {
- FEerror(\"Lisp object is not a valid socket buffer: ~A\", 1, x);
- }
- return (void *)x->vector.self.t;
+ cl_type t = type_of(x);
+ int ok = 0;
+ if (t == t_base_string) {
+ ok = (size <= x->base_string.dim);
+ } else if (t == t_vector) {
+ cl_elttype aet = (cl_elttype)x->vector.elttype;
+ if (aet == aet_b8 || aet == aet_i8 || aet == aet_bc) {
+ ok = (size <= x->vector.dim);
+ } else if (aet == aet_fix || aet == aet_index) {
+ cl_index divisor = sizeof(cl_index);
+ size = (size + divisor - 1) / divisor;
+ ok = (size <= x->vector.dim);
+ }
+ }
+ if (!ok) {
+ FEerror(\"Lisp object is not a valid socket buffer: ~A\", 1, x);
+ }
+ return (void *)x->vector.self.t;
}
")
;; FIXME: How bad is manipulating fillp directly?
(defmethod socket-receive ((socket socket) buffer length
- &key oob peek waitall element-type)
+ &key oob peek waitall element-type)
(unless (or buffer length) (error "You have to supply either buffer or length!"))
(let ((buffer (or buffer (make-array length :element-type element-type)))
- (length (or length (length buffer)))
- (fd (socket-file-descriptor socket)))
+ (length (or length (length buffer)))
+ (fd (socket-file-descriptor socket)))
(multiple-value-bind (len-recv errno)
- (c-inline (fd buffer length
- oob peek waitall)
- (:int :object :int :bool :bool :bool)
+ (c-inline (fd buffer length
+ oob peek waitall)
+ (:int :object :int :bool :bool :bool)
(values :long :int)
- "
+ "
{
int flags = ( #3 ? MSG_OOB : 0 ) |
( #4 ? MSG_PEEK : 0 ) |
( #5 ? MSG_WAITALL : 0 );
cl_type type = type_of(#1);
- ssize_t len;
+ ssize_t len;
ecl_disable_interrupts();
len = recvfrom(#0, wincoerce(char*, safe_buffer_pointer(#1, #2)),
#2, flags, NULL,NULL);
- ecl_enable_interrupts();
+ ecl_enable_interrupts();
if (len >= 0) {
if (type == t_vector) { #1->vector.fillp = len; }
else if (type == t_base_string) { #1->base_string.fillp = len; }
(Clines
"
static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port,
- int a1, int a2, int a3, int a4)
+ int a1, int a2, int a3, int a4)
{
#if defined(_MSC_VER) || defined(mingw32)
- memset(sockaddr,0,sizeof(struct sockaddr_in));
+ memset(sockaddr,0,sizeof(struct sockaddr_in));
#else
- bzero(sockaddr,sizeof(struct sockaddr_in));
+ bzero(sockaddr,sizeof(struct sockaddr_in));
#endif
- sockaddr->sin_family = AF_INET;
- sockaddr->sin_port = htons(port);
- sockaddr->sin_addr.s_addr= htonl((uint32_t)a1<<24 | (uint32_t)a2<<16 | (uint32_t)a3<<8 | (uint32_t)a4) ;
+ sockaddr->sin_family = AF_INET;
+ sockaddr->sin_port = htons(port);
+ sockaddr->sin_addr.s_addr= htonl((uint32_t)a1<<24 | (uint32_t)a2<<16 | (uint32_t)a3<<8 | (uint32_t)a4) ;
}
")
(defmethod socket-bind ((socket inet-socket) &rest address)
(assert (= 2 (length address)) (address) "Socket-bind needs three parameters for inet sockets.")
(let ((ip (first address))
- (port (second address)))
+ (port (second address)))
(if (= -1
- (c-inline (port (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)
- (socket-file-descriptor socket))
- (:int :int :int :int :int :int)
- :int
- "
+ (c-inline (port (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)
+ (socket-file-descriptor socket))
+ (:int :int :int :int :int :int)
+ :int
+ "
{
- struct sockaddr_in sockaddr;
- int output;
- ecl_disable_interrupts();
- fill_inet_sockaddr(&sockaddr, #0, #1, #2, #3, #4);
- output = bind(#5,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in));
- ecl_enable_interrupts();
- @(return) = output;
+ struct sockaddr_in sockaddr;
+ int output;
+ ecl_disable_interrupts();
+ fill_inet_sockaddr(&sockaddr, #0, #1, #2, #3, #4);
+ output = bind(#5,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in));
+ ecl_enable_interrupts();
+ @(return) = output;
}"
- :side-effects t))
- (socket-error "bind"))))
+ :side-effects t))
+ (socket-error "bind"))))
(defmethod socket-accept ((socket inet-socket))
(let ((sfd (socket-file-descriptor socket)))
socklen_t addr_len = (socklen_t)sizeof(struct sockaddr_in);
int new_fd;
- ecl_disable_interrupts();
- new_fd = accept(#0, (struct sockaddr*)&sockaddr, &addr_len);
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ new_fd = accept(#0, (struct sockaddr*)&sockaddr, &addr_len);
+ ecl_enable_interrupts();
- @(return 0) = new_fd;
- @(return 1) = ECL_NIL;
- @(return 2) = 0;
+ @(return 0) = new_fd;
+ @(return 1) = ECL_NIL;
+ @(return 2) = 0;
if (new_fd != -1) {
uint32_t ip = ntohl(sockaddr.sin_addr.s_addr);
uint16_t port = ntohs(sockaddr.sin_port);
cl_object vector = cl_make_array(1,MAKE_FIXNUM(4));
ecl_aset(vector,0, MAKE_FIXNUM( ip>>24 ));
- ecl_aset(vector,1, MAKE_FIXNUM( (ip>>16) & 0xFF));
- ecl_aset(vector,2, MAKE_FIXNUM( (ip>>8) & 0xFF));
+ ecl_aset(vector,1, MAKE_FIXNUM( (ip>>16) & 0xFF));
+ ecl_aset(vector,2, MAKE_FIXNUM( (ip>>8) & 0xFF));
ecl_aset(vector,3, MAKE_FIXNUM( ip & 0xFF ));
- @(return 1) = vector;
- @(return 2) = port;
- }
+ @(return 1) = vector;
+ @(return 2) = port;
+ }
}")
(cond
- ((= fd -1)
- (socket-error "accept"))
- (t
- (values
- (make-instance (class-of socket)
- :type (socket-type socket)
- :protocol (socket-protocol socket)
- :descriptor fd)
- vector
- port))))))
+ ((= fd -1)
+ (socket-error "accept"))
+ (t
+ (values
+ (make-instance (class-of socket)
+ :type (socket-type socket)
+ :protocol (socket-protocol socket)
+ :descriptor fd)
+ vector
+ port))))))
(defmethod socket-connect ((socket inet-socket) &rest address)
(let ((ip (first address))
- (port (second address)))
+ (port (second address)))
(if (= -1
- (c-inline (port (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)
- (socket-file-descriptor socket))
- (:int :int :int :int :int :int)
- :int
- "
+ (c-inline (port (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)
+ (socket-file-descriptor socket))
+ (:int :int :int :int :int :int)
+ :int
+ "
{
- struct sockaddr_in sockaddr;
- int output;
+ struct sockaddr_in sockaddr;
+ int output;
- ecl_disable_interrupts();
- fill_inet_sockaddr(&sockaddr, #0, #1, #2, #3, #4);
- output = connect(#5,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in));
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ fill_inet_sockaddr(&sockaddr, #0, #1, #2, #3, #4);
+ output = connect(#5,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in));
+ ecl_enable_interrupts();
- @(return) = output;
+ @(return) = output;
}"))
- (socket-error "connect"))))
+ (socket-error "connect"))))
(defmethod socket-peername ((socket inet-socket))
(let* ((vector (make-array 4))
- (fd (socket-file-descriptor socket))
- (port (c-inline (fd vector) (:int t) :int
+ (fd (socket-file-descriptor socket))
+ (port (c-inline (fd vector) (:int t) :int
"@01;{
struct sockaddr_in name;
socklen_t len = sizeof(struct sockaddr_in);
int ret;
- ecl_disable_interrupts();
- ret = getpeername(#0,(struct sockaddr*)&name,&len);
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = getpeername(#0,(struct sockaddr*)&name,&len);
+ ecl_enable_interrupts();
if (ret == 0) {
uint32_t ip = ntohl(name.sin_addr.s_addr);
uint16_t port = ntohs(name.sin_port);
ecl_aset(#1,0, MAKE_FIXNUM( ip>>24 ));
- ecl_aset(#1,1, MAKE_FIXNUM( (ip>>16) & 0xFF));
- ecl_aset(#1,2, MAKE_FIXNUM( (ip>>8) & 0xFF));
+ ecl_aset(#1,1, MAKE_FIXNUM( (ip>>16) & 0xFF));
+ ecl_aset(#1,2, MAKE_FIXNUM( (ip>>8) & 0xFF));
ecl_aset(#1,3, MAKE_FIXNUM( ip & 0xFF ));
@(return) = port;
}
}")))
(if (>= port 0)
- (values vector port)
- (socket-error "getpeername"))))
+ (values vector port)
+ (socket-error "getpeername"))))
(defmethod socket-name ((socket inet-socket))
(let* ((vector (make-array 4))
- (fd (socket-file-descriptor socket))
- (port (c-inline (fd vector) (:int t) :int
+ (fd (socket-file-descriptor socket))
+ (port (c-inline (fd vector) (:int t) :int
"@01;{
struct sockaddr_in name;
socklen_t len = sizeof(struct sockaddr_in);
int ret;
- ecl_disable_interrupts();
- ret = getsockname(#0,(struct sockaddr*)&name,&len);
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = getsockname(#0,(struct sockaddr*)&name,&len);
+ ecl_enable_interrupts();
if (ret == 0) {
uint32_t ip = ntohl(name.sin_addr.s_addr);
uint16_t port = ntohs(name.sin_port);
ecl_aset(#1,0, MAKE_FIXNUM( ip>>24 ));
- ecl_aset(#1,1, MAKE_FIXNUM( (ip>>16) & 0xFF));
- ecl_aset(#1,2, MAKE_FIXNUM( (ip>>8) & 0xFF));
+ ecl_aset(#1,1, MAKE_FIXNUM( (ip>>16) & 0xFF));
+ ecl_aset(#1,2, MAKE_FIXNUM( (ip>>8) & 0xFF));
ecl_aset(#1,3, MAKE_FIXNUM( ip & 0xFF ));
@(return) = port;
}
}")))
(if (>= port 0)
- (values vector port)
- (socket-error "getsockname"))))
+ (values vector port)
+ (socket-error "getsockname"))))
#+:wsock
(defmethod socket-close-low-level ((socket inet-socket))
(ff-closesocket (socket-file-descriptor socket)))
(defmethod socket-send ((socket socket) buffer length
- &key address external-format oob eor dontroute dontwait nosignal confirm more)
+ &key address external-format oob eor dontroute dontwait nosignal confirm more)
(declare (ignore external-format more))
(assert (or (stringp buffer)
- (typep buffer 'vector)))
+ (typep buffer 'vector)))
(let (;eh, here goes string->octet convertion...
- ;When will ecl support Unicode?
- (length (or length (length buffer)))
- (fd (socket-file-descriptor socket)))
+ ;When will ecl support Unicode?
+ (length (or length (length buffer)))
+ (fd (socket-file-descriptor socket)))
(let ((len-sent
- (if address
- (progn
- (assert (= 2 (length address)))
- (c-inline (fd buffer length
- (second address)
- (aref (first address) 0)
- (aref (first address) 1)
- (aref (first address) 2)
- (aref (first address) 3)
- oob eor dontroute dontwait nosignal confirm)
- (:int :object :int
- :int :int :int :int :int
- :bool :bool :bool :bool :bool :bool)
- :long
- "
+ (if address
+ (progn
+ (assert (= 2 (length address)))
+ (c-inline (fd buffer length
+ (second address)
+ (aref (first address) 0)
+ (aref (first address) 1)
+ (aref (first address) 2)
+ (aref (first address) 3)
+ oob eor dontroute dontwait nosignal confirm)
+ (:int :object :int
+ :int :int :int :int :int
+ :bool :bool :bool :bool :bool :bool)
+ :long
+ "
{
- int sock = #0;
- int length = #2;
- void *buffer = safe_buffer_pointer(#1, length);
+ int sock = #0;
+ int length = #2;
+ void *buffer = safe_buffer_pointer(#1, length);
int flags = ( #8 ? MSG_OOB : 0 ) |
( #9 ? MSG_EOR : 0 ) |
( #a ? MSG_DONTROUTE : 0 ) |
( #d ? MSG_CONFIRM : 0 );
cl_type type = type_of(#1);
struct sockaddr_in sockaddr;
- ssize_t len;
+ ssize_t len;
- ecl_disable_interrupts();
- fill_inet_sockaddr(&sockaddr, #3, #4, #5, #6, #7);
+ ecl_disable_interrupts();
+ fill_inet_sockaddr(&sockaddr, #3, #4, #5, #6, #7);
##if (MSG_NOSIGNAL == 0) && defined(SO_NOSIGPIPE)
- {
- int sockopt = #c;
- setsockopt(#0,SOL_SOCKET,SO_NOSIGPIPE,
- wincoerce(char *,&sockopt),
- sizeof(int));
- }
+ {
+ int sockopt = #c;
+ setsockopt(#0,SOL_SOCKET,SO_NOSIGPIPE,
+ wincoerce(char *,&sockopt),
+ sizeof(int));
+ }
##endif
len = sendto(sock, wincoerce(char *,buffer),
length, flags,(struct sockaddr*)&sockaddr,
sizeof(struct sockaddr_in));
- ecl_enable_interrupts();
+ ecl_enable_interrupts();
@(return) = len;
}
"
- :one-liner nil))
- (c-inline (fd buffer length
- oob eor dontroute dontwait nosignal confirm)
- (:int :object :int
- :bool :bool :bool :bool :bool :bool)
- :long
- "
+ :one-liner nil))
+ (c-inline (fd buffer length
+ oob eor dontroute dontwait nosignal confirm)
+ (:int :object :int
+ :bool :bool :bool :bool :bool :bool)
+ :long
+ "
{
- int sock = #0;
- int length = #2;
- void *buffer = safe_buffer_pointer(#1, length);
+ int sock = #0;
+ int length = #2;
+ void *buffer = safe_buffer_pointer(#1, length);
int flags = ( #3 ? MSG_OOB : 0 ) |
( #4 ? MSG_EOR : 0 ) |
( #5 ? MSG_DONTROUTE : 0 ) |
( #8 ? MSG_CONFIRM : 0 );
cl_type type = type_of(#1);
ssize_t len;
- ecl_disable_interrupts();
+ ecl_disable_interrupts();
##if (MSG_NOSIGNAL == 0) && defined(SO_NOSIGPIPE)
- {
- int sockopt = #7;
- setsockopt(#0,SOL_SOCKET,SO_NOSIGPIPE,
- wincoerce(char *,&sockopt),
- sizeof(int));
- }
+ {
+ int sockopt = #7;
+ setsockopt(#0,SOL_SOCKET,SO_NOSIGPIPE,
+ wincoerce(char *,&sockopt),
+ sizeof(int));
+ }
##endif
- len = send(sock, wincoerce(char *, buffer), length, flags);
- ecl_enable_interrupts();
+ len = send(sock, wincoerce(char *, buffer), length, flags);
+ ecl_enable_interrupts();
@(return) = len;
}
"
- :one-liner nil))))
+ :one-liner nil))))
(if (= len-sent -1)
- (socket-error "send")
- len-sent))))
+ (socket-error "send")
+ len-sent))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(defmethod socket-bind ((socket local-socket) &rest address)
(assert (= 1 (length address)) (address) "Socket-bind needs two parameters for local sockets.")
(let ((name (first address))
- (fd (socket-file-descriptor socket))
- (family (socket-family socket)))
+ (fd (socket-file-descriptor socket))
+ (family (socket-family socket)))
(if (= -1
- (c-inline (fd name family) (:int :cstring :int) :int
- "
+ (c-inline (fd name family) (:int :cstring :int) :int
+ "
{
struct sockaddr_un sockaddr;
- size_t size;
- int output;
+ size_t size;
+ int output;
##ifdef BSD
sockaddr.sun_len = sizeof(struct sockaddr_un);
##endif
sockaddr.sun_family = #2;
strncpy(sockaddr.sun_path,#1,sizeof(sockaddr.sun_path));
- sockaddr.sun_path[sizeof(sockaddr.sun_path)-1] = 0;
+ sockaddr.sun_path[sizeof(sockaddr.sun_path)-1] = 0;
- ecl_disable_interrupts();
- output = bind(#0,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un));
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ output = bind(#0,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un));
+ ecl_enable_interrupts();
@(return) = output;
}"))
- (socket-error "bind"))))
+ (socket-error "bind"))))
(defmethod socket-accept ((socket local-socket))
(multiple-value-bind (fd name)
struct sockaddr_un sockaddr;
socklen_t addr_len = (socklen_t)sizeof(struct sockaddr_un);
int new_fd;
- ecl_disable_interrupts();
- new_fd = accept(#0, (struct sockaddr *)&sockaddr, &addr_len);
- ecl_enable_interrupts();
- @(return 0) = new_fd;
- @(return 1) = (new_fd == -1) ? ECL_NIL : make_base_string_copy(sockaddr.sun_path);
+ ecl_disable_interrupts();
+ new_fd = accept(#0, (struct sockaddr *)&sockaddr, &addr_len);
+ ecl_enable_interrupts();
+ @(return 0) = new_fd;
+ @(return 1) = (new_fd == -1) ? ECL_NIL : make_base_string_copy(sockaddr.sun_path);
}")
(cond
((= fd -1)
(socket-error "accept"))
(t
(values
- (make-instance (class-of socket)
- :type (socket-type socket)
- :protocol (socket-protocol socket)
- :descriptor fd)
- name)))))
+ (make-instance (class-of socket)
+ :type (socket-type socket)
+ :protocol (socket-protocol socket)
+ :descriptor fd)
+ name)))))
(defmethod socket-connect ((socket local-socket) &rest address)
(assert (= 1 (length address)) (address) "Socket-connect needs two parameters for local sockets.")
(let ((path (first address))
- (fd (socket-file-descriptor socket))
- (family (socket-family socket)))
+ (fd (socket-file-descriptor socket))
+ (family (socket-family socket)))
(if (= -1
- (c-inline (fd family path) (:int :int :cstring) :int
- "
+ (c-inline (fd family path) (:int :int :cstring) :int
+ "
{
struct sockaddr_un sockaddr;
- int output;
+ int output;
##ifdef BSD
sockaddr.sun_len = sizeof(struct sockaddr_un);
##endif
sockaddr.sun_family = #1;
strncpy(sockaddr.sun_path,#2,sizeof(sockaddr.sun_path));
- sockaddr.sun_path[sizeof(sockaddr.sun_path)-1] = 0;
+ sockaddr.sun_path[sizeof(sockaddr.sun_path)-1] = 0;
- ecl_disable_interrupts();
- output = connect(#0,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un));
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ output = connect(#0,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un));
+ ecl_enable_interrupts();
@(return) = output;
}"))
- (socket-error "connect"))))
+ (socket-error "connect"))))
(defmethod socket-peername ((socket local-socket))
(let* ((fd (socket-file-descriptor socket))
- (peer (c-inline (fd) (:int) t
- "
+ (peer (c-inline (fd) (:int) t
+ "
{
struct sockaddr_un name;
socklen_t len = sizeof(struct sockaddr_un);
int ret;
- ecl_disable_interrupts();
- ret = getpeername(#0,(struct sockaddr*)&name,&len);
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = getpeername(#0,(struct sockaddr*)&name,&len);
+ ecl_enable_interrupts();
if (ret == 0) {
@(return) = make_base_string_copy(name.sun_path);
}
}")))
(if peer
- peer
- (socket-error "getpeername"))))
+ peer
+ (socket-error "getpeername"))))
) ;#-:wsock
(multiple-value-bind (ip port) (socket-peername proxy-socket)
(handler-case
(with-open-file (fd (first address) :if-exists :error :if-does-not-exist :create :direction :output)
- (format fd "!<socket >~D 00000000-00000000-00000000-00000000" port))
- (file-error ()
- (socket-close proxy-socket)
- (c-inline () () nil "WSASetLastError(WSAEADDRINUSE)" :one-liner t)
- (socket-error "socket-bind")))
+ (format fd "!<socket >~D 00000000-00000000-00000000-00000000" port))
+ (file-error ()
+ (socket-close proxy-socket)
+ (c-inline () () nil "WSASetLastError(WSAEADDRINUSE)" :one-liner t)
+ (socket-error "socket-bind")))
(setf local-path (first address))
socket)))
(handler-case
(with-open-file (fd (first address) :if-does-not-exist :error :direction :input)
(let ((buf (make-string 128)) port)
- (read-sequence buf fd)
- (unless (and (string-equal "!<socket >" (subseq buf 0 10))
- (typep (setq port (read-from-string (subseq buf 10) nil 'eof)) '(integer 0 65535)))
- (c-inline () () nil "WSASetLastError(WSAEFAULT)" :one-liner t)
- (socket-error "connect"))
- (prog1
- (socket-connect proxy-socket #(127 0 0 1) port)
- (setf local-path (first address)))))
+ (read-sequence buf fd)
+ (unless (and (string-equal "!<socket >" (subseq buf 0 10))
+ (typep (setq port (read-from-string (subseq buf 10) nil 'eof)) '(integer 0 65535)))
+ (c-inline () () nil "WSASetLastError(WSAEFAULT)" :one-liner t)
+ (socket-error "connect"))
+ (prog1
+ (socket-connect proxy-socket #(127 0 0 1) port)
+ (setf local-path (first address)))))
(file-error ()
(socket-error "connect")))))
(assert (= 1 (length address)) (address) "Socket-bind needs two parameters for local sockets.")
(let* ((pipe-name (concatenate 'string "\\\\.\\pipe\\" (first address)))
(hnd (c-inline (pipe-name) (:cstring) :int
- "
+ "
{
- HANDLE hnd;
- ecl_disable_interrupts();
- hnd = CreateNamedPipe(
- #0,
- PIPE_ACCESS_DUPLEX,
- PIPE_TYPE_BYTE | PIPE_READMODE_BYTE | PIPE_WAIT,
- PIPE_UNLIMITED_INSTANCES,
- 4096,
- 4096,
- NMPWAIT_USE_DEFAULT_WAIT,
- NULL);
- ecl_enable_interrupts();
- if (hnd == INVALID_HANDLE_VALUE)
- @(return) = -1;
- else
- @(return) = _open_osfhandle((intptr_t)hnd, O_RDWR);
+ HANDLE hnd;
+ ecl_disable_interrupts();
+ hnd = CreateNamedPipe(
+ #0,
+ PIPE_ACCESS_DUPLEX,
+ PIPE_TYPE_BYTE | PIPE_READMODE_BYTE | PIPE_WAIT,
+ PIPE_UNLIMITED_INSTANCES,
+ 4096,
+ 4096,
+ NMPWAIT_USE_DEFAULT_WAIT,
+ NULL);
+ ecl_enable_interrupts();
+ if (hnd == INVALID_HANDLE_VALUE)
+ @(return) = -1;
+ else
+ @(return) = _open_osfhandle((intptr_t)hnd, O_RDWR);
}")))
(when (= hnd -1)
(socket-error "CreateNamedPipe"))
(defmethod socket-accept ((socket named-pipe-socket))
(let* ((fd (socket-file-descriptor socket))
(afd (c-inline (fd) (:int) :int
- "
+ "
{
- HANDLE hnd = (HANDLE)_get_osfhandle(#0), dupHnd;
- ecl_disable_interrupts();
- if (ConnectNamedPipe(hnd, NULL) != 0 || GetLastError() == ERROR_PIPE_CONNECTED) {
- @(return) = #0;
- } else
- @(return) = -1;
- ecl_enable_interrupts();
+ HANDLE hnd = (HANDLE)_get_osfhandle(#0), dupHnd;
+ ecl_disable_interrupts();
+ if (ConnectNamedPipe(hnd, NULL) != 0 || GetLastError() == ERROR_PIPE_CONNECTED) {
+ @(return) = #0;
+ } else
+ @(return) = -1;
+ ecl_enable_interrupts();
}"
:one-liner nil)))
(cond
;; rebind the socket to create a new named pipe instance in the server
(socket-bind socket (subseq (slot-value socket 'pipe-name) 9))
(values
- (make-instance (class-of socket)
- :type (socket-type socket)
- :protocol (socket-protocol socket)
- :descriptor afd
- :pipe-name (slot-value socket 'pipe-name))
- (slot-value socket 'pipe-name))))))
+ (make-instance (class-of socket)
+ :type (socket-type socket)
+ :protocol (socket-protocol socket)
+ :descriptor afd
+ :pipe-name (slot-value socket 'pipe-name))
+ (slot-value socket 'pipe-name))))))
(defmethod socket-connect ((socket named-pipe-socket) &rest address)
(assert (= 1 (length address)) (address) "Socket-connect needs two parameters for local sockets.")
(let* ((path (first address))
- (pipe-name (concatenate 'string "\\\\.\\pipe\\" path)))
+ (pipe-name (concatenate 'string "\\\\.\\pipe\\" path)))
(if (= -1
- (setf (slot-value socket 'file-descriptor)
- (c-inline (pipe-name) (:cstring) :int
- "
+ (setf (slot-value socket 'file-descriptor)
+ (c-inline (pipe-name) (:cstring) :int
+ "
{
- HANDLE hnd;
- ecl_disable_interrupts();
- hnd = CreateFile(
- #0,
- GENERIC_READ | GENERIC_WRITE,
- 0,
- NULL,
- OPEN_EXISTING,
- 0,
- NULL);
- if (hnd == INVALID_HANDLE_VALUE)
- @(return) = -1;
- else
- @(return) = _open_osfhandle((intptr_t)hnd, O_RDWR);
- ecl_enable_interrupts();
+ HANDLE hnd;
+ ecl_disable_interrupts();
+ hnd = CreateFile(
+ #0,
+ GENERIC_READ | GENERIC_WRITE,
+ 0,
+ NULL,
+ OPEN_EXISTING,
+ 0,
+ NULL);
+ if (hnd == INVALID_HANDLE_VALUE)
+ @(return) = -1;
+ else
+ @(return) = _open_osfhandle((intptr_t)hnd, O_RDWR);
+ ecl_enable_interrupts();
}")))
- (socket-error "connect")
- (setf (slot-value socket 'pipe-name) pipe-name))))
+ (socket-error "connect")
+ (setf (slot-value socket 'pipe-name) pipe-name))))
(defmethod socket-peername ((socket named-pipe-socket))
(slot-value socket 'pipe-name))
(c-inline (fd non-blocking-p) (:int t) :int
"
{
- DWORD mode = PIPE_READMODE_BYTE | (#1 == ECL_T ? PIPE_NOWAIT : PIPE_WAIT);
- HANDLE h = (HANDLE)_get_osfhandle(#0);
- ecl_disable_interrupts();
- @(return) = SetNamedPipeHandleState(h, &mode, NULL, NULL);
- ecl_enable_interrupts();
+ DWORD mode = PIPE_READMODE_BYTE | (#1 == ECL_T ? PIPE_NOWAIT : PIPE_WAIT);
+ HANDLE h = (HANDLE)_get_osfhandle(#0);
+ ecl_disable_interrupts();
+ @(return) = SetNamedPipeHandleState(h, &mode, NULL, NULL);
+ ecl_enable_interrupts();
}"
:one-liner nil))
(socket-error "SetNamedPipeHandleState")
(unless (c-inline (fd) (:int) t
"
{
- DWORD flags;
- HANDLE h = (HANDLE)_get_osfhandle(#0);
- ecl_disable_interrupts();
- if (!GetNamedPipeInfo(h, &flags, NULL, NULL, NULL))
- @(return) = ECL_NIL;
- if (flags == PIPE_CLIENT_END || DisconnectNamedPipe(h))
- @(return) = ECL_T;
- else
- @(return) = ECL_NIL;
- ecl_enable_interrupts();
+ DWORD flags;
+ HANDLE h = (HANDLE)_get_osfhandle(#0);
+ ecl_disable_interrupts();
+ if (!GetNamedPipeInfo(h, &flags, NULL, NULL, NULL))
+ @(return) = ECL_NIL;
+ if (flags == PIPE_CLIENT_END || DisconnectNamedPipe(h))
+ @(return) = ECL_T;
+ else
+ @(return) = ECL_NIL;
+ ecl_enable_interrupts();
}"
:one-liner nil)
(socket-error "DisconnectNamedPipe"))
(defmethod (setf non-blocking-mode) (non-blocking-p (socket socket))
(let ((fd (socket-file-descriptor socket))
- (nblock (if non-blocking-p 1 0)))
+ (nblock (if non-blocking-p 1 0)))
(if (= -1 (c-inline (fd nblock) (:int :int) :int
- #+:wsock
- "
+ #+:wsock
+ "
{
- int blocking_flag = (#1 ? 1 : 0);
- ecl_disable_interrupts();
- @(return) = ioctlsocket(#0, FIONBIO, (u_long*)&blocking_flag);
- ecl_enable_interrupts();
+ int blocking_flag = (#1 ? 1 : 0);
+ ecl_disable_interrupts();
+ @(return) = ioctlsocket(#0, FIONBIO, (u_long*)&blocking_flag);
+ ecl_enable_interrupts();
}"
- #-:wsock
- "
+ #-:wsock
+ "
{
int oldflags = fcntl(#0,F_GETFL,NULL);
int newflags = (oldflags & ~O_NONBLOCK) |
(#1 ? O_NONBLOCK : 0);
- ecl_disable_interrupts();
+ ecl_disable_interrupts();
@(return) = fcntl(#0,F_SETFL,newflags);
- ecl_enable_interrupts();
+ ecl_enable_interrupts();
}"))
- (socket-error #-:wsock "fcntl" #+:wsock "ioctlsocket")
- #-:wsock non-blocking-p
- #+:wsock (setf (slot-value socket 'non-blocking-p) non-blocking-p))))
+ (socket-error #-:wsock "fcntl" #+:wsock "ioctlsocket")
+ #-:wsock non-blocking-p
+ #+:wsock (setf (slot-value socket 'non-blocking-p) non-blocking-p))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(name "FD-STREAM"))
(assert (stringp name) (name) "name must be a string.")
(let* ((smm-mode (ecase mode
- (:input (c-constant "ecl_smm_input"))
- (:output (c-constant "ecl_smm_output"))
- (:input-output (c-constant "ecl_smm_io"))
- #+:wsock
- (:input-wsock (c-constant "ecl_smm_input_wsock"))
- #+:wsock
- (:output-wsock (c-constant "ecl_smm_output_wsock"))
- #+:wsock
- (:input-output-wsock (c-constant "ecl_smm_io_wsock"))
- ))
- (external-format (unless (subtypep element-type 'integer) external-format))
+ (:input (c-constant "ecl_smm_input"))
+ (:output (c-constant "ecl_smm_output"))
+ (:input-output (c-constant "ecl_smm_io"))
+ #+:wsock
+ (:input-wsock (c-constant "ecl_smm_input_wsock"))
+ #+:wsock
+ (:output-wsock (c-constant "ecl_smm_output_wsock"))
+ #+:wsock
+ (:input-output-wsock (c-constant "ecl_smm_io_wsock"))
+ ))
+ (external-format (unless (subtypep element-type 'integer) external-format))
(stream (ffi:c-inline (name fd smm-mode element-type external-format)
(t :int :int t t)
t
"
ecl_make_stream_from_fd(#0,#1,(enum ecl_smmode)#2,
- ecl_normalize_stream_element_type(#3),
+ ecl_normalize_stream_element_type(#3),
0,#4)"
:one-liner t)))
(when buffering
:buffering buffering
:element-type element-type
:external-format external-format))
- (output
- (make-stream-from-fd fd #-wsock :output #+wsock :output-wsock
+ (output
+ (make-stream-from-fd fd #-wsock :output #+wsock :output-wsock
:buffering buffering
:element-type element-type
:external-format external-format))
- (t
- (error "SOCKET-MAKE-STREAM: at least one of :INPUT or :OUTPUT has to be true."))))
+ (t
+ (error "SOCKET-MAKE-STREAM: at least one of :INPUT or :OUTPUT has to be true."))))
(defmethod socket-make-stream ((socket socket)
- &key (input nil input-p)
+ &key (input nil input-p)
(output nil output-p)
- (buffering :full)
+ (buffering :full)
(element-type 'base-char)
(external-format :default))
(let ((stream (and (slot-boundp socket 'stream)
- (slot-value socket 'stream))))
+ (slot-value socket 'stream))))
(unless stream
;; Complicated default logic for compatibility with previous releases
;; should disappear soon. (FIXME!)
(unless (or input-p output-p)
- (setf input t output t))
+ (setf input t output t))
(setf stream (socket-make-stream-inner (socket-file-descriptor socket)
- input output buffering element-type
+ input output buffering element-type
external-format))
(setf (slot-value socket 'stream) stream)
#+ ignore
#+:wsock
(defmethod socket-make-stream ((socket named-pipe-socket)
- &key input output
+ &key input output
(buffering :full) (external-format :default))
(let ((stream (and (slot-boundp socket 'stream)
- (slot-value socket 'stream))))
+ (slot-value socket 'stream))))
(unless stream
(setf stream
- (let* ((fd (socket-file-descriptor socket))
- (in (make-stream-from-fd fd :smm-input buffering external-format))
- (out (make-stream-from-fd fd :smm-output buffering external-format)))
- (make-two-way-stream in out)))
+ (let* ((fd (socket-file-descriptor socket))
+ (in (make-stream-from-fd fd :smm-input buffering external-format))
+ (out (make-stream-from-fd fd :smm-output buffering external-format)))
+ (make-two-way-stream in out)))
(setf (slot-value socket 'stream) stream))
stream))
#+:wsock
(defun get-win32-error-string (num)
(c-inline (num) (:int) t
- "{char *lpMsgBuf;
- cl_object msg;
- ecl_disable_interrupts();
- FormatMessage(
- FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM,
- NULL,
- #0,
- 0,
- (LPTSTR)&lpMsgBuf,
- 0,
- NULL);
- msg = make_base_string_copy(lpMsgBuf);
- LocalFree(lpMsgBuf);
- ecl_enable_interrupts();
- @(return) = msg;}"
- :one-liner nil))
+ "{char *lpMsgBuf;
+ cl_object msg;
+ ecl_disable_interrupts();
+ FormatMessage(
+ FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM,
+ NULL,
+ #0,
+ 0,
+ (LPTSTR)&lpMsgBuf,
+ 0,
+ NULL);
+ msg = make_base_string_copy(lpMsgBuf);
+ LocalFree(lpMsgBuf);
+ ecl_enable_interrupts();
+ @(return) = msg;}"
+ :one-liner nil))
;;;
;;; 1) SOCKET ERRORS
(format s "Socket error in \"~A\": ~A (~A)"
(socket-error-syscall c)
(or (socket-error-symbol c) (socket-error-errno c))
- #+:wsock
- (get-win32-error-string num)
- #-:wsock
- (c-inline (num) (:int) :cstring
- "strerror(#0)" :one-liner t)))))
+ #+:wsock
+ (get-win32-error-string num)
+ #-:wsock
+ (c-inline (num) (:int) :cstring
+ "strerror(#0)" :one-liner t)))))
(:documentation "Common base class of socket related conditions."))
(defmacro define-socket-condition (symbol name)
(if (= *name-service-errno* (c-constant "NETDB_INTERNAL"))
(socket-error where)
(let ((condition
- (condition-for-name-service-errno *name-service-errno*)))
+ (condition-for-name-service-errno *name-service-errno*)))
(error condition :errno *name-service-errno* :syscall where))))
(define-condition name-service-error (condition)
((errno :initform nil
- :initarg :errno
- :reader name-service-error-errno)
+ :initarg :errno
+ :reader name-service-error-errno)
(symbol :initform nil :initarg :symbol :reader name-service-error-symbol)
(syscall :initform "an unknown location" :initarg :syscall :reader name-service-error-syscall))
(:report (lambda (c s)
- (let ((num (name-service-error-errno c)))
- (format s "Name service error in \"~A\": ~A (~A)"
- (name-service-error-syscall c)
- (or (name-service-error-symbol c)
- (name-service-error-errno c))
- (get-name-service-error-message num))))))
+ (let ((num (name-service-error-errno c)))
+ (format s "Name service error in \"~A\": ~A (~A)"
+ (name-service-error-syscall c)
+ (or (name-service-error-symbol c)
+ (name-service-error-errno c))
+ (get-name-service-error-message num))))))
(defmacro define-name-service-condition (symbol name)
`(let ()
int sockopt, ret;
socklen_t socklen = sizeof(int);
- ecl_disable_interrupts();
- ret = getsockopt(#0,#1,#2,wincoerce(char*,&sockopt),&socklen);
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = getsockopt(#0,#1,#2,wincoerce(char*,&sockopt),&socklen);
+ ecl_enable_interrupts();
@(return) = (ret == 0) ? ecl_make_integer(sockopt) : ECL_NIL;
}")))
(if ret
- ret
- (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
+ ret
+ (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
(defun get-sockopt-bool (fd level const)
(let ((ret (c-inline (fd level const) (:int :int :int) t
int sockopt, ret;
socklen_t socklen = sizeof(int);
- ecl_disable_interrupts();
- ret = getsockopt(#0,#1,#2,wincoerce(char*,&sockopt),&socklen);
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = getsockopt(#0,#1,#2,wincoerce(char*,&sockopt),&socklen);
+ ecl_enable_interrupts();
@(return) = (ret == 0) ? ecl_make_integer(sockopt) : ECL_NIL;
}")))
(if ret
- (/= ret 0)
- (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
+ (/= ret 0)
+ (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
#+wsock
(defun get-sockopt-timeval (fd level const)
(defun get-sockopt-timeval (fd level const)
(let ((ret (c-inline (fd level const) (:int :int :int) t
"{
- struct timeval tv;
+ struct timeval tv;
socklen_t socklen = sizeof(struct timeval);
int ret;
- ecl_disable_interrupts();
- ret = getsockopt(#0,#1,#2,wincoerce(char*,&tv),&socklen);
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = getsockopt(#0,#1,#2,wincoerce(char*,&tv),&socklen);
+ ecl_enable_interrupts();
@(return) = (ret == 0) ? ecl_make_doublefloat((double)tv.tv_sec
- + ((double)tv.tv_usec) / 1000000.0) : ECL_NIL;
+ + ((double)tv.tv_usec) / 1000000.0) : ECL_NIL;
}")))
(if ret
- ret
- (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
+ ret
+ (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
(defun get-sockopt-linger (fd level const)
(let ((ret (c-inline (fd level const) (:int :int :int) t
"{
- struct linger sockopt;
- socklen_t socklen = sizeof(struct linger);
- int ret;
+ struct linger sockopt;
+ socklen_t socklen = sizeof(struct linger);
+ int ret;
- ecl_disable_interrupts();
- ret = getsockopt(#0,#1,#2,wincoerce(char*,&sockopt),&socklen);
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = getsockopt(#0,#1,#2,wincoerce(char*,&sockopt),&socklen);
+ ecl_enable_interrupts();
- @(return) = (ret == 0) ? ecl_make_integer((sockopt.l_onoff != 0) ? sockopt.l_linger : 0) : ECL_NIL;
+ @(return) = (ret == 0) ? ecl_make_integer((sockopt.l_onoff != 0) ? sockopt.l_linger : 0) : ECL_NIL;
}")))
(if ret
- ret
- (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
+ ret
+ (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
(defun set-sockopt-int (fd level const value)
(let ((ret (c-inline (fd level const value) (:int :int :int :int) t
int sockopt = #3;
int ret;
- ecl_disable_interrupts();
- ret = setsockopt(#0,#1,#2,wincoerce(char *,&sockopt),sizeof(int));
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = setsockopt(#0,#1,#2,wincoerce(char *,&sockopt),sizeof(int));
+ ecl_enable_interrupts();
@(return) = (ret == 0) ? ECL_T : ECL_NIL;
}")))
(if ret
- value
- (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
+ value
+ (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
(defun set-sockopt-bool (fd level const value)
(let ((ret (c-inline (fd level const value) (:int :int :int :object) t
int sockopt = (#3 == ECL_NIL) ? 0 : 1;
int ret;
- ecl_disable_interrupts();
- ret = setsockopt(#0,#1,#2,wincoerce(char *,&sockopt),sizeof(int));
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = setsockopt(#0,#1,#2,wincoerce(char *,&sockopt),sizeof(int));
+ ecl_enable_interrupts();
@(return) = (ret == 0) ? ECL_T : ECL_NIL;
}")))
(if ret
- value
- (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
+ value
+ (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
#-wsock
(defun set-sockopt-timeval (fd level const value)
(let ((ret (c-inline (fd level const value) (:int :int :int :double) t
"{
- struct timeval tv;
- double tmp = #3;
- int ret;
+ struct timeval tv;
+ double tmp = #3;
+ int ret;
- ecl_disable_interrupts();
- tv.tv_sec = (int)tmp;
- tv.tv_usec = (int)((tmp-floor(tmp))*1000000.0);
+ ecl_disable_interrupts();
+ tv.tv_sec = (int)tmp;
+ tv.tv_usec = (int)((tmp-floor(tmp))*1000000.0);
ret = setsockopt(#0,#1,#2,&tv,sizeof(struct timeval));
- ecl_enable_interrupts();
+ ecl_enable_interrupts();
@(return) = (ret == 0) ? ECL_T : ECL_NIL;
}")))
(if ret
- value
- (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
+ value
+ (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
#+wsock
(defun set-sockopt-timeval (fd level const value)
(defun set-sockopt-linger (fd level const value)
(let ((ret (c-inline (fd level const value) (:int :int :int :int) t
"{
- struct linger sockopt = {0, 0};
- int value = #3;
- int ret;
+ struct linger sockopt = {0, 0};
+ int value = #3;
+ int ret;
- if (value > 0) {
- sockopt.l_onoff = 1;
- sockopt.l_linger = value;
- }
+ if (value > 0) {
+ sockopt.l_onoff = 1;
+ sockopt.l_linger = value;
+ }
- ecl_disable_interrupts();
- ret = setsockopt(#0,#1,#2,wincoerce(char *,&sockopt),
- sizeof(struct linger));
- ecl_enable_interrupts();
+ ecl_disable_interrupts();
+ ret = setsockopt(#0,#1,#2,wincoerce(char *,&sockopt),
+ sizeof(struct linger));
+ ecl_enable_interrupts();
- @(return) = (ret == 0) ? ECL_T : ECL_NIL;
+ @(return) = (ret == 0) ? ECL_T : ECL_NIL;
}")))
(if ret
- value
- (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
+ value
+ (error "Sockopt error: ~A" (c-inline () () :cstring "strerror(errno)" :one-liner t)))))
(eval-when (:compile-toplevel :load-toplevel)
(defmacro define-sockopt (name c-level c-const type &optional (read-only nil))
`(progn
(export ',name)
(defun ,name (socket)
- (,(intern (format nil "GET-SOCKOPT-~A" type))
- (socket-file-descriptor socket)
- (c-constant ,c-level)
- (c-constant ,c-const)))
+ (,(intern (format nil "GET-SOCKOPT-~A" type))
+ (socket-file-descriptor socket)
+ (c-constant ,c-level)
+ (c-constant ,c-const)))
,@(unless read-only
- `((defun (setf ,name) (value socket)
- (,(intern (format nil "SET-SOCKOPT-~A" type))
- (socket-file-descriptor socket)
- (c-constant ,c-level)
- (c-constant ,c-const)
- value)))))))
+ `((defun (setf ,name) (value socket)
+ (,(intern (format nil "SET-SOCKOPT-~A" type))
+ (socket-file-descriptor socket)
+ (c-constant ,c-level)
+ (c-constant ,c-const)
+ value)))))))
(define-sockopt sockopt-type "SOL_SOCKET" "SO_TYPE" int t)
(define-sockopt sockopt-receive-buffer "SOL_SOCKET" "SO_RCVBUF" int)
;; 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)
(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)
;;; 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)
(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
;; 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)
(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)
;; 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)
(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)))))))
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"
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))
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*)))
;#+(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*))))
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)))))
(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*))
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)
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
*/
#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.
*/
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.
*/
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.
*/
(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.
*/
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
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 {
"))
-;(ext:run-program "/bin/sh" '("-c" "cp *.c *.h ~/devel/ecl/src/c/unicode/"))
\ No newline at end of file
+;(ext:run-program "/bin/sh" '("-c" "cp *.c *.h ~/devel/ecl/src/c/unicode/"))
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))))
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))))
(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
;;; 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
(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
: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*
(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
(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...")
(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)
(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)))
(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*)))
(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))
(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
(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)
(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))
(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)
(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)
(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 ()
(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 ()
(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)
(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)))
(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 *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 *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 *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 *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 *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 *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 *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 *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 *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 *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 *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 *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 *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 *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_EX_CLIENTEDGE* #x00000200)
+
+(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 *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 *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 *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 *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 *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 *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 *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 *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 *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 *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 *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 *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
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
(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")
(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)
(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")
(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)))
*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)
(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))
|#
(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)
(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*)
;;;
(mapc #'delete-file (append (directory "*.o")
- (directory "*.obj")
- (directory "example-mono*")))
+ (directory "*.obj")
+ (directory "example-mono*")))
;;; 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;")
* 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!";
;;; 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:
;;; 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 "
(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
(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
#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
static void *
thread_entry_point(void *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);
-
- /*
- * 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;
+ 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);
+
+ /*
+ * 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;
}
int main(int narg, char **argv)
{
- 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);
-
- /*
- * 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];
-
- 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);
-
- return 0;
+ 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);
+
+ /*
+ * 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];
+
+ 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);
+
+ return 0;
}
#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
#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
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++)
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
Repositories / ecl.git / commitdiff