From: Zack Piper Date: Tue, 1 Sep 2015 20:10:10 +0000 (+0000) Subject: Untabify everything. X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=00521d869aee07c5bd8923196ad0c051f79c1cac;p=ecl.git Untabify everything. --- diff --git a/contrib/deflate/deflate.lisp b/contrib/deflate/deflate.lisp index 90cd81c..c465c53 100644 --- a/contrib/deflate/deflate.lisp +++ b/contrib/deflate/deflate.lisp @@ -35,7 +35,7 @@ #:inflate-stream #:inflate-zlib-stream #:parse-zlib-header #:parse-zlib-footer #:inflate-gzip-stream #:parse-gzip-header #:parse-gzip-footer - #:gunzip)) + #:gunzip)) (cl:in-package "DEFLATE") diff --git a/contrib/defsystem/defsystem.lisp b/contrib/defsystem/defsystem.lisp index dc487d3..0852ac7 100644 --- a/contrib/defsystem/defsystem.lisp +++ b/contrib/defsystem/defsystem.lisp @@ -454,14 +454,14 @@ ;;; 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 @@ -874,17 +874,17 @@ (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") @@ -911,7 +911,7 @@ ;; 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.") @@ -926,7 +926,7 @@ (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*)) @@ -937,11 +937,11 @@ 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 @@ -953,31 +953,31 @@ 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 ;;; ******************************** @@ -1000,7 +1000,7 @@ ;;; 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 19970105 ;;; In Allegro 4.1, 'provide' and 'require' are not external in @@ -1013,9 +1013,9 @@ #+: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") @@ -1026,8 +1026,8 @@ ;;; 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")))) @@ -1083,23 +1083,23 @@ #+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*. @@ -1174,16 +1174,16 @@ #-(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) @@ -1232,13 +1232,13 @@ on the particular lisp compiler version being used.") #-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 @@ -1257,7 +1257,7 @@ on the particular lisp compiler version being used.") "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 @@ -1284,18 +1284,18 @@ on the particular lisp compiler version being used.") ;; 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 @@ -1415,40 +1415,40 @@ and up to date.") (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"))) @@ -1545,21 +1545,21 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ (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) @@ -1571,14 +1571,14 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ (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)) @@ -1586,15 +1586,15 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ (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" @@ -1618,27 +1618,27 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ ;; 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 @@ -1658,23 +1658,23 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ (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) @@ -1757,8 +1757,8 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ #+: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) @@ -1778,10 +1778,10 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ #+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*)))) @@ -1844,9 +1844,9 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ "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)) @@ -1880,12 +1880,12 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ ;;; 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. @@ -1905,28 +1905,28 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ ;; 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 @@ -1935,11 +1935,11 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ ;; 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 "." (string-upcase abs-name))) - (setf abs-name nil)) + (setf abs-name (string-right-trim "." (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 "." (string-upcase rel-file))) - (setf rel-file nil)) + (setf rel-file (string-right-trim "." (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 @@ -1951,61 +1951,61 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ (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* @@ -2029,11 +2029,11 @@ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ (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)))) #|| @@ -2077,10 +2077,10 @@ ABS: NIL REL: NIL Result: "" ;; 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)) |# @@ -2091,10 +2091,10 @@ ABS: NIL REL: NIL Result: "" ;; 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))))) @@ -2140,15 +2140,15 @@ ABS: NIL REL: NIL Result: "" (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)) @@ -2156,19 +2156,19 @@ ABS: NIL REL: NIL Result: "" (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 @@ -2188,8 +2188,8 @@ ABS: NIL REL: NIL Result: "" #+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. @@ -2219,16 +2219,16 @@ ABS: NIL REL: NIL Result: "" (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))) @@ -2243,13 +2243,13 @@ ABS: NIL REL: NIL Result: "" :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 @@ -2258,13 +2258,13 @@ ABS: NIL REL: NIL Result: "" (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))) ))) @@ -2281,8 +2281,8 @@ ABS: NIL REL: NIL Result: "" (when absolute-directory (setq absolute-directory (pathname-directory absolute-directory))) (concatenate 'string - (or absolute-directory "") - (or relative-directory ""))) + (or absolute-directory "") + (or relative-directory ""))) ||# #|| @@ -2375,30 +2375,30 @@ D (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 @@ -2414,48 +2414,48 @@ D (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)) @@ -2469,9 +2469,9 @@ D (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. ) @@ -2501,7 +2501,7 @@ D ) #-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)))) ) @@ -2509,7 +2509,7 @@ D (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)))) ) @@ -2517,7 +2517,7 @@ D (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)))) ) @@ -2535,18 +2535,18 @@ D (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) @@ -2554,23 +2554,23 @@ D (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) @@ -2582,23 +2582,23 @@ D (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)) @@ -2612,39 +2612,39 @@ D (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))))) )) @@ -2654,8 +2654,8 @@ D (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))) @@ -2668,27 +2668,27 @@ D (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)))))) |# @@ -2708,52 +2708,52 @@ the system definition, if provided." (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) @@ -2775,22 +2775,22 @@ the system definition, if provided." ~& 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)) @@ -2803,7 +2803,7 @@ the system definition, if provided." ;; 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) @@ -2865,39 +2865,39 @@ used with caution.") (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 @@ -2935,45 +2935,45 @@ used with caution.") ;; 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 @@ -2985,16 +2985,16 @@ used with caution.") ;; 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. @@ -3014,28 +3014,28 @@ used with caution.") ;; 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*))) @@ -3054,32 +3054,32 @@ used with caution.") (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 @@ -3087,22 +3087,22 @@ used with caution.") ;; 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) @@ -3132,15 +3132,15 @@ used with caution.") (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 -- @@ -3156,15 +3156,15 @@ used with caution.") (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 @@ -3175,60 +3175,60 @@ used with caution.") ;; 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 @@ -3249,30 +3249,30 @@ used with caution.") ;; 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 @@ -3281,32 +3281,32 @@ used with caution.") (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 @@ -3315,61 +3315,61 @@ used with caution.") (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))) @@ -3388,7 +3388,7 @@ used with caution.") ;; 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)) @@ -3396,35 +3396,35 @@ used with caution.") (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 ))) @@ -3434,13 +3434,13 @@ used with caution.") (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)))))) @@ -3480,17 +3480,17 @@ used with caution.") ;; 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) @@ -3507,15 +3507,15 @@ used with caution.") (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. @@ -3523,37 +3523,37 @@ used with caution.") (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)) @@ -3561,38 +3561,38 @@ used with caution.") (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*))) @@ -3608,22 +3608,22 @@ used with caution.") (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*))) @@ -3679,7 +3679,7 @@ used with caution.") ;;; 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 @@ -3694,9 +3694,9 @@ used with caution.") (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* @@ -3704,18 +3704,18 @@ used with caution.") ;; 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? ") @@ -3764,92 +3764,92 @@ used with caution.") ;;; 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 @@ -3865,15 +3865,15 @@ used with caution.") :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 @@ -3889,9 +3889,9 @@ used with caution.") :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 @@ -3904,10 +3904,10 @@ used with caution.") (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 @@ -3919,10 +3919,10 @@ used with caution.") (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 @@ -3936,10 +3936,10 @@ used with caution.") ;;; 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 @@ -3948,100 +3948,100 @@ used with caution.") (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) @@ -4049,33 +4049,33 @@ used with caution.") (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) @@ -4083,17 +4083,17 @@ used with caution.") (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) @@ -4102,9 +4102,9 @@ used with caution.") ;; 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. @@ -4118,18 +4118,18 @@ used with caution.") (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 @@ -4193,41 +4193,41 @@ used with caution.") (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) @@ -4250,50 +4250,50 @@ used with caution.") ;;; 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))) )) @@ -4313,12 +4313,12 @@ used with caution.") #|| (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 @@ -4328,48 +4328,48 @@ used with caution.") ;; 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) @@ -4378,18 +4378,18 @@ used with caution.") (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)))))) ) @@ -4403,9 +4403,9 @@ used with caution.") ;; 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*) ) @@ -4415,9 +4415,9 @@ used with caution.") (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*) ) @@ -4439,11 +4439,11 @@ used with caution.") (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) @@ -4451,42 +4451,42 @@ used with caution.") (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))) @@ -4495,7 +4495,7 @@ used with caution.") (defsystem foo :language :lisp :components ((:module c :language :c :components ("foo" "bar")) - (:module lisp :components ("baz" "barf")))) + (:module lisp :components ("baz" "barf")))) ||# @@ -4510,12 +4510,12 @@ used with caution.") (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 @@ -4537,14 +4537,14 @@ used with caution.") ;; 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) ) @@ -4611,17 +4611,17 @@ output to *trace-output*. Returns the shell's exit code." :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") @@ -4633,9 +4633,9 @@ output to *trace-output*. Returns the shell's exit code." ;; 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))) ||# #|| @@ -4643,7 +4643,7 @@ output to *trace-output*. Returns the shell's exit code." ;; 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))))) ||# @@ -4661,139 +4661,139 @@ output to *trace-output*. Returns the shell's exit code." (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 @@ -4802,23 +4802,23 @@ output to *trace-output*. Returns the shell's exit code." #+: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") @@ -4832,12 +4832,12 @@ output to *trace-output*. Returns the shell's exit code." (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))) @@ -4859,8 +4859,8 @@ output to *trace-output*. Returns the shell's exit code." (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)))))) ;;; ******************************** @@ -4881,13 +4881,13 @@ output to *trace-output*. Returns the shell's exit code." (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) @@ -4901,12 +4901,12 @@ output to *trace-output*. Returns the shell's exit code." ;; 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) @@ -4917,60 +4917,60 @@ output to *trace-output*. Returns the shell's exit code." (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 -- @@ -4989,12 +4989,12 @@ or does not contain valid compiled code." #+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)) @@ -5025,8 +5025,8 @@ or does not contain valid compiled code." ;; 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) @@ -5035,43 +5035,43 @@ or does not contain valid compiled code." (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 @@ -5079,61 +5079,61 @@ or does not contain valid compiled code." ;; 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) @@ -5143,23 +5143,23 @@ or does not contain valid compiled code." ) (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))) @@ -5167,64 +5167,64 @@ or does not contain valid compiled code." ;;; 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 ****** @@ -5233,26 +5233,26 @@ or does not contain valid compiled code." #+: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) @@ -5278,8 +5278,8 @@ or does not contain valid compiled code." "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) @@ -5287,8 +5287,8 @@ or does not contain valid compiled code." "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) @@ -5296,8 +5296,8 @@ or does not contain valid compiled code." "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) @@ -5311,35 +5311,35 @@ or does not contain valid compiled code." ;;; ******************************** #+: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. @@ -5348,46 +5348,46 @@ or does not contain valid compiled code." 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)) @@ -5400,8 +5400,8 @@ or does not contain valid compiled code." ;;; 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)) ;; @@ -5417,19 +5417,19 @@ full-pathname) (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" @@ -5440,7 +5440,7 @@ nil) (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 diff --git a/contrib/ecl-cdb/ecl-cdb.lisp b/contrib/ecl-cdb/ecl-cdb.lisp index 834704b..a99a148 100644 --- a/contrib/ecl-cdb/ecl-cdb.lisp +++ b/contrib/ecl-cdb/ecl-cdb.lisp @@ -68,14 +68,14 @@ (defun read-word (stream) (logior (read-byte stream) - (ash (read-byte stream) 8) - (ash (read-byte stream) 16) - (ash (read-byte stream) 24))) + (ash (read-byte stream) 8) + (ash (read-byte stream) 16) + (ash (read-byte stream) 24))) (defun write-word (byte stream) (declare (type (unsigned-byte 32) byte) - (stream stream) - (optimize speed (safety 0))) + (stream stream) + (optimize speed (safety 0))) (write-byte (logand #xff byte) stream) (write-byte (logand #xff (ash byte -8)) stream) (write-byte (logand #xff (ash byte -16)) stream) @@ -91,35 +91,35 @@ (loop with h of-type (unsigned-integer 32) = 5381 for byte of-type (unsigned-byte 8) across key-vector do (setf h (logxor (logand #xffffffff - (+ (ash (logand #.(ash #xffffffff -5) h) - 5) - h)) - byte)) + (+ (ash (logand #.(ash #xffffffff -5) h) + 5) + h)) + byte)) finally (return h))) (defun %make-cdb (cdb-pathname temporary-pathname) (let ((stream (open temporary-pathname - :direction :output - :if-exists :supersede - :if-does-not-exist :create - :element-type '(unsigned-byte 8)))) + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :element-type '(unsigned-byte 8)))) (if stream - (progn - (file-position stream 0) - (dotimes (i (* 256 2)) - (write-word 0 stream)) - (make-cdb :stream stream - :pathname cdb-pathname - :tables (make-array 256 :initial-element nil) - :temporary-pathname temporary-pathname)) - (error "Unable to create CDB at filename ~A" temporary-pathname)))) + (progn + (file-position stream 0) + (dotimes (i (* 256 2)) + (write-word 0 stream)) + (make-cdb :stream stream + :pathname cdb-pathname + :tables (make-array 256 :initial-element nil) + :temporary-pathname temporary-pathname)) + (error "Unable to create CDB at filename ~A" temporary-pathname)))) (defmacro with-output-to-cdb ((cdb cdb-pathname temporary-pathname) &body body) `(let (,cdb) (unwind-protect - (progn - (setf ,cdb (%make-cdb ,cdb-pathname ,temporary-pathname)) - ,@body) + (progn + (setf ,cdb (%make-cdb ,cdb-pathname ,temporary-pathname)) + ,@body) (close-cdb ,cdb)))) (defun add-record (key value cdb) @@ -127,10 +127,10 @@ ;; reference in the CDB structure itself. This reference will be ;; used to create the hash. (let* ((hash-key (to-cdb-hash key)) - (table-index (logand #xff hash-key)) - (stream (cdb-stream cdb))) + (table-index (logand #xff hash-key)) + (stream (cdb-stream cdb))) (push (cons hash-key (file-position stream)) - (aref (cdb-tables cdb) table-index)) + (aref (cdb-tables cdb) table-index)) (write-word (length key) stream) (write-word (length value) stream) (write-sequence key stream) @@ -144,26 +144,26 @@ ;; Here we use a factor 2. (loop with length = (* 2 (length table)) with vector = (make-array (* 2 length) :initial-element 0 - :element-type '(unsigned-byte 32)) + :element-type '(unsigned-byte 32)) for (hash-key . pos) in table for index = (mod (ash hash-key -8) length) do (loop for disp from 0 below length - for i = (* 2 (mod (+ disp index) length)) - for record-pos = (aref vector (1+ i)) - until (zerop record-pos) - finally (setf (aref vector i) hash-key (aref vector (1+ i)) pos)) + for i = (* 2 (mod (+ disp index) length)) + for record-pos = (aref vector (1+ i)) + until (zerop record-pos) + finally (setf (aref vector i) hash-key (aref vector (1+ i)) pos)) finally (progn (write-vector vector stream) - (return length)))) + (return length)))) (defun dump-cdb (cdb) ;; After we have dumped all the records in the file, we append the ;; hash tables and recreate the index table at the beginning. (let* ((stream (cdb-stream cdb)) - (index (make-array (* 2 256) :element-type '(unsigned-byte 32)))) + (index (make-array (* 2 256) :element-type '(unsigned-byte 32)))) (loop for table across (cdb-tables cdb) for i of-type fixnum from 0 by 2 do (setf (aref index i) (file-position stream) - (aref index (1+ i)) (dump-table table stream))) + (aref index (1+ i)) (dump-table table stream))) (file-position stream 0) (write-vector index stream))) @@ -173,8 +173,8 @@ (dump-cdb cdb) (close stream) (when (cdb-pathname cdb) - (rename-file (cdb-temporary-pathname cdb) - (cdb-pathname cdb)))))) + (rename-file (cdb-temporary-pathname cdb) + (cdb-pathname cdb)))))) (defun cdb-error (stream) (error "Error when reading CDB database ~A" stream)) @@ -185,82 +185,82 @@ (let ((key-length (read-word stream))) (when (= key-length (length key-vector)) (let* ((value-length (read-word stream)) - (other-key (make-array key-length :element-type '(unsigned-byte 8)))) - (read-sequence other-key stream) - (when (equalp other-key key-vector) - (if return-position-p - (file-position stream) - (let ((value (make-array value-length :element-type '(unsigned-byte 8)))) - (read-sequence value stream) - value) - )))))) + (other-key (make-array key-length :element-type '(unsigned-byte 8)))) + (read-sequence other-key stream) + (when (equalp other-key key-vector) + (if return-position-p + (file-position stream) + (let ((value (make-array value-length :element-type '(unsigned-byte 8)))) + (read-sequence value stream) + value) + )))))) (defun lookup-cdb (key stream &optional return-position-p) (if (streamp stream) (let* ((hash (to-cdb-hash key)) - (table (logand #xFF hash))) - (unless (file-position stream (* table 8)) - (cdb-error stream)) - (let* ((start (read-word stream)) - (length (read-word stream)) - (index (mod (ash hash -8) length))) - (loop for reset = t - for i from 0 below length - for rounded-i = (mod (+ index i) length) - for position = (+ start (* 8 rounded-i)) - do (progn - (when reset - (unless (file-position stream position) - (cdb-error stream)) - (setf reset nil)) - (let* ((other-hash (read-word stream)) - (record-position (read-word stream))) - (when (zerop record-position) - (return nil)) - (when (= other-hash hash) - (let ((output (values-coincide record-position key stream - return-position-p))) - (if output - (return output) - (setf reset t))))))))) + (table (logand #xFF hash))) + (unless (file-position stream (* table 8)) + (cdb-error stream)) + (let* ((start (read-word stream)) + (length (read-word stream)) + (index (mod (ash hash -8) length))) + (loop for reset = t + for i from 0 below length + for rounded-i = (mod (+ index i) length) + for position = (+ start (* 8 rounded-i)) + do (progn + (when reset + (unless (file-position stream position) + (cdb-error stream)) + (setf reset nil)) + (let* ((other-hash (read-word stream)) + (record-position (read-word stream))) + (when (zerop record-position) + (return nil)) + (when (= other-hash hash) + (let ((output (values-coincide record-position key stream + return-position-p))) + (if output + (return output) + (setf reset t))))))))) (with-open-file (s stream :direction :input - :element-type '(unsigned-byte 8)) - (lookup-cdb key s return-position-p)))) + :element-type '(unsigned-byte 8)) + (lookup-cdb key s return-position-p)))) (defun map-cdb (function stream) (if (streamp stream) (let* ((index (make-array (* 256 2) :element-type '(unsigned-byte 32)))) - (unless (file-position stream 0) - (cdb-error stream)) - (unless (= (read-sequence index stream) (length index)) - (cdb-error stream)) - (loop for i from 0 by 2 below (length index) - for table-position = (aref index i) - for table-length = (aref index (1+ i)) - do (progn - (unless (file-position stream table-position) - (cdb-error stream)) - (loop for i from 0 below table-length - for position from table-position by 8 - for record-hash = (read-word stream) - for record-position = (read-word stream) - unless (zerop record-position) - do (progn - (unless (file-position stream record-position) - (cdb-error stream)) - (let* ((key-length (read-word stream)) - (value-length (read-word stream)) - (key (make-array key-length - :element-type '(unsigned-byte 8))) - (value (make-array value-length - :element-type '(unsigned-byte 8)))) - (unless (and (= (read-sequence key stream) - key-length) - (= (read-sequence value stream) - value-length)) - (cdb-error stream)) - (funcall function key value))))))) + (unless (file-position stream 0) + (cdb-error stream)) + (unless (= (read-sequence index stream) (length index)) + (cdb-error stream)) + (loop for i from 0 by 2 below (length index) + for table-position = (aref index i) + for table-length = (aref index (1+ i)) + do (progn + (unless (file-position stream table-position) + (cdb-error stream)) + (loop for i from 0 below table-length + for position from table-position by 8 + for record-hash = (read-word stream) + for record-position = (read-word stream) + unless (zerop record-position) + do (progn + (unless (file-position stream record-position) + (cdb-error stream)) + (let* ((key-length (read-word stream)) + (value-length (read-word stream)) + (key (make-array key-length + :element-type '(unsigned-byte 8))) + (value (make-array value-length + :element-type '(unsigned-byte 8)))) + (unless (and (= (read-sequence key stream) + key-length) + (= (read-sequence value stream) + value-length)) + (cdb-error stream)) + (funcall function key value))))))) (with-open-file (s stream :direction :input :element-type '(unsigned-byte 8)) - (map-cdb function s)))) + (map-cdb function s)))) (provide :ecl-cdb) diff --git a/contrib/ecl-cdb/ecl-help.lisp b/contrib/ecl-cdb/ecl-help.lisp index 5e848ff..e09ed09 100644 --- a/contrib/ecl-cdb/ecl-help.lisp +++ b/contrib/ecl-cdb/ecl-help.lisp @@ -14,25 +14,25 @@ (defun to-cdb-vector (object) (let* ((vector (make-array 128 :adjustable t - :fill-pointer 0 - :element-type '(unsigned-byte 8) - :initial-element 0)) - (stream (ext:make-sequence-output-stream - vector :external-format #+unicode :utf-8 #-unicode :default))) + :fill-pointer 0 + :element-type '(unsigned-byte 8) + :initial-element 0)) + (stream (ext:make-sequence-output-stream + vector :external-format #+unicode :utf-8 #-unicode :default))) (with-standard-io-syntax (let ((si::*print-package* (find-package "CL"))) - (write object :stream stream :pretty nil - :readably nil :escape t))) + (write object :stream stream :pretty nil + :readably nil :escape t))) vector)) (defun from-cdb-vector (vector) (let* ((stream (ext:make-sequence-input-stream - vector :external-format #+unicode :utf-8 #-unicode :default))) + vector :external-format #+unicode :utf-8 #-unicode :default))) (read stream nil nil nil))) (defun search-help-file (string path) (let* ((key (to-cdb-vector string)) - (value (ecl-cdb:lookup-cdb key path))) + (value (ecl-cdb:lookup-cdb key path))) (when value (from-cdb-vector value)))) @@ -43,8 +43,8 @@ (loop for k being the hash-key of hash-table using (hash-value v) do (ecl-cdb:add-record (to-cdb-vector k) - (to-cdb-vector v) - cdb))) + (to-cdb-vector v) + cdb))) ;; Testing the consistency of the output (when test (loop for k being the hash-key of hash-table diff --git a/contrib/ecl-curl/ecl-curl.lisp b/contrib/ecl-curl/ecl-curl.lisp index b458f32..8bae713 100644 --- a/contrib/ecl-curl/ecl-curl.lisp +++ b/contrib/ecl-curl/ecl-curl.lisp @@ -59,9 +59,9 @@ (defpackage #:ecl-curl (:use #:sb-bsd-sockets #:cl) (:export #:download-url-to-file - #:download-error - #:download-url - #:download-response)) + #:download-error + #:download-url + #:download-response)) (in-package "ECL-CURL") @@ -176,9 +176,9 @@ (if *proxy* url (let ((path-start (position #\/ url :start 7))) - (if path-start - (subseq url path-start) - "/index.html")))) + (if path-start + (subseq url path-start) + "/index.html")))) ;;;--------------------------------------------------------------------------- ;;; CONNECTION & HEADRE @@ -240,10 +240,10 @@ (let ((length (parse-integer (or (header-value :content-length headers) "") :junk-allowed t))) (unless quiet - (format t "~&;;; Downloading ~A bytes from ~A to ~A ...~%" - (or length "some unknown number of") - url - file-name)) + (format t "~&;;; Downloading ~A bytes from ~A to ~A ...~%" + (or length "some unknown number of") + url + file-name)) (force-output) (let ((ok? nil) (o nil)) (unwind-protect @@ -251,8 +251,8 @@ (setf o (open file-name :direction :output :if-exists :supersede :external-format - #-unicode :default - #+unicode :latin-1)) + #-unicode :default + #+unicode :latin-1)) (if length (let ((buf (make-array length :element-type diff --git a/contrib/encodings/generate.lisp b/contrib/encodings/generate.lisp index 8fb916e..20db4cd 100644 --- a/contrib/encodings/generate.lisp +++ b/contrib/encodings/generate.lisp @@ -21,13 +21,13 @@ (make-pathname :name name :type "BIN" :defaults "build:encodings;")) do (progn - (unless (probe-file orig) + (unless (probe-file orig) (error "Missing mapping") - (let ((mapping (if (equalp name "JISX0208") - (mapcar #'rest (read-mapping name 3)) - (read-mapping name)))) - (dump-mapping-array mapping orig))) - (copy-encoding-file orig copy))) + (let ((mapping (if (equalp name "JISX0208") + (mapcar #'rest (read-mapping name 3)) + (read-mapping name)))) + (dump-mapping-array mapping orig))) + (copy-encoding-file orig copy))) (defconstant +aliases+ '((:us-ascii ext::ascii) @@ -88,17 +88,17 @@ (loop for (name . aliases) in +aliases+ do (loop with *package* = (find-package "CL") - for alias in aliases - for filename0 = (make-pathname :name (symbol-name alias) + for alias in aliases + for filename0 = (make-pathname :name (symbol-name alias) :defaults "build:encodings;") - for filename = (ensure-directories-exist filename0) - do (with-open-file (out filename :direction :output :if-exists :supersede - :if-does-not-exist :create :element-type 'base-char) - (format t "~%;;; Creating alias ~A -> ~A, ~A" alias name filename) - (if (keywordp name) - (format out "(defparameter ~S '~S)" alias name) - (format out "(defparameter ~S (ext::make-encoding '~S))" alias name)) - ))) + for filename = (ensure-directories-exist filename0) + do (with-open-file (out filename :direction :output :if-exists :supersede + :if-does-not-exist :create :element-type 'base-char) + (format t "~%;;; Creating alias ~A -> ~A, ~A" alias name filename) + (if (keywordp name) + (format out "(defparameter ~S '~S)" alias name) + (format out "(defparameter ~S (ext::make-encoding '~S))" alias name)) + ))) (copy-encoding-file "ext:encodings;tools.lisp" "build:encodings;tools.lisp") (copy-encoding-file (merge-pathnames "ISO-2022-JP" +encodings-root+) diff --git a/contrib/encodings/tools.lisp b/contrib/encodings/tools.lisp index 1909e50..1711063 100644 --- a/contrib/encodings/tools.lisp +++ b/contrib/encodings/tools.lisp @@ -13,10 +13,10 @@ (defconstant +source-pathname+ (make-pathname :name nil :type nil - :directory (append (pathname-directory *load-pathname*) - (list "sources")) - :host (pathname-host *load-pathname*) - :device (pathname-device *load-pathname*))) + :directory (append (pathname-directory *load-pathname*) + (list "sources")) + :host (pathname-host *load-pathname*) + :device (pathname-device *load-pathname*))) (defconstant +all-mappings+ '(("ATARIST" "http://unicode.org/Public/MAPPINGS/VENDORS/MISC/ATARIST.TXT") @@ -100,67 +100,67 @@ (unless (probe-file filename) (let ((command (format nil "curl \"~A\" > ~A" url filename))) (unless (zerop (si::system command)) - (error "Unable to retrieve file ~A" url))))) + (error "Unable to retrieve file ~A" url))))) (defun reformat (line) (loop with l = (length line) for i from 0 below l for c = (char line i) do (cond ((eql c #\#) - (return (if (zerop i) "" (subseq line 0 (1- i))))) - ((not (standard-char-p c)) - (setf (char line i) #\space)) - ((and (eql c #\0) - (let ((j (1+ i))) - (and (< j l) (member (char line j) '(#\x #\X))))) - (setf (char line i) #\#))) + (return (if (zerop i) "" (subseq line 0 (1- i))))) + ((not (standard-char-p c)) + (setf (char line i) #\space)) + ((and (eql c #\0) + (let ((j (1+ i))) + (and (< j l) (member (char line j) '(#\x #\X))))) + (setf (char line i) #\#))) finally (return line))) (defun read-mapping (name &optional (n 2)) (let* ((source-file (make-pathname :name name :defaults +source-pathname+)) - (record (find name +all-mappings+ :key #'first :test #'equalp)) - (fixes (third record)) - (source-url (fourth record))) + (record (find name +all-mappings+ :key #'first :test #'equalp)) + (fixes (third record)) + (source-url (fourth record))) (unless (probe-file source-file) (unless source-url - (error "Unknown encoding ~A" name)) + (error "Unknown encoding ~A" name)) (download file source-url)) (with-open-file (in source-file :direction :input) (loop with output = '() - for line = (reformat (read-line in nil nil)) - while line - unless (zerop (length line)) - do (with-input-from-string (aux line) - (let ((byte-list (loop for byte = (read aux nil nil) - while byte - collect byte))) - (unless (/= (length byte-list) n) - (loop for i in fixes - when (= (first i) (first byte-list)) - do (progn (setf byte-list i) (return))) - (push byte-list output)))) - finally (return (nreverse output)))))) + for line = (reformat (read-line in nil nil)) + while line + unless (zerop (length line)) + do (with-input-from-string (aux line) + (let ((byte-list (loop for byte = (read aux nil nil) + while byte + collect byte))) + (unless (/= (length byte-list) n) + (loop for i in fixes + when (= (first i) (first byte-list)) + do (progn (setf byte-list i) (return))) + (push byte-list output)))) + finally (return (nreverse output)))))) (defun mapping-hash-table (mapping) (loop with hash = (make-hash-table :size (floor (* 1.5 (length mapping))) - :test 'eq) + :test 'eq) for (multibyte codepoint) in mapping for unicode-char = (code-char codepoint) do (progn - (setf (gethash multibyte hash) unicode-char) - (setf (gethash unicode-char hash) multibyte) - (when (> multibyte #xFF) - (setf (gethash (ash multibyte -8) hash) t))) + (setf (gethash multibyte hash) unicode-char) + (setf (gethash unicode-char hash) multibyte) + (when (> multibyte #xFF) + (setf (gethash (ash multibyte -8) hash) t))) finally (return hash))) (defun dump-mapping-array (mapping-assoc output-file) (let* ((mapping-list (reduce #'nconc mapping-assoc)) - (mapping-array (make-array (length mapping-list) :element-type +sequence-type+ - :initial-contents mapping-list))) + (mapping-array (make-array (length mapping-list) :element-type +sequence-type+ + :initial-contents mapping-list))) (format t "~%;;; Generating ~A" output-file) (force-output t) (with-open-file (s output-file :direction :output :if-exists :supersede - :element-type +sequence-type+ :external-format :big-endian) + :element-type +sequence-type+ :external-format :big-endian) (write-byte (length mapping-array) s) (write-sequence mapping-array s)))) @@ -169,34 +169,34 @@ (format t "~%;;; Copying ~A to ~A" in out) (with-open-file (sin in :direction :input :element-type '(unsigned-byte 8)) (with-open-file (sout out :direction :output :element-type '(unsigned-byte 8) - :if-exists :supersede :if-does-not-exist :create) - (loop for nbytes = (read-sequence buffer sin) - until (zerop nbytes) - do (write-sequence buffer sout :end nbytes)))))) + :if-exists :supersede :if-does-not-exist :create) + (loop for nbytes = (read-sequence buffer sin) + until (zerop nbytes) + do (write-sequence buffer sout :end nbytes)))))) (defun all-valid-unicode-chars (mapping) (cond ((consp mapping) - (loop for sublist on mapping - for i from 0 below 10 - until (and (eq sublist mapping) (plusp i)) - collect (all-valid-unicode-chars (first sublist)))) - ((hash-table-p mapping) - (concatenate 'string (loop for key being the hash-key in mapping - when (characterp key) - collect key))) - ((eq mapping :iso-8859-1) - (coerce 'string (loop for i from 0 to 255 collect (code-char i)))) - (t - (error "Unknown encoding")))) + (loop for sublist on mapping + for i from 0 below 10 + until (and (eq sublist mapping) (plusp i)) + collect (all-valid-unicode-chars (first sublist)))) + ((hash-table-p mapping) + (concatenate 'string (loop for key being the hash-key in mapping + when (characterp key) + collect key))) + ((eq mapping :iso-8859-1) + (coerce 'string (loop for i from 0 to 255 collect (code-char i)))) + (t + (error "Unknown encoding")))) (defun compare-hashes (h1 h2) (flet ((h1-in-h2 (h1 h2) - (loop for k being the hash-key in h1 using (hash-value v) - for v2 = (gethash k h2 nil) - unless (or (consp v2) (consp v) (equal v v2)) - do (progn (print (list h1 k v h2 k v2)) - (error) - (return nil)) - finally (return t)))) + (loop for k being the hash-key in h1 using (hash-value v) + for v2 = (gethash k h2 nil) + unless (or (consp v2) (consp v) (equal v v2)) + do (progn (print (list h1 k v h2 k v2)) + (error) + (return nil)) + finally (return t)))) (and (h1-in-h2 h1 h2) - (h1-in-h2 h2 h1)))) + (h1-in-h2 h2 h1)))) diff --git a/contrib/profile/profile.lisp b/contrib/profile/profile.lisp index 385834e..4c9df80 100644 --- a/contrib/profile/profile.lisp +++ b/contrib/profile/profile.lisp @@ -61,15 +61,15 @@ extern ECL_API size_t GC_get_total_bytes(); (let () ; This prevents compile-time evaluation of the following (defconstant +wrap+ (ffi:c-inline () () :object - "ecl_make_unsigned_integer(~((size_t)0))" - :one-liner t))) + "ecl_make_unsigned_integer(~((size_t)0))" + :one-liner t))) (defun get-bytes-consed (orig) (let ((bytes (ffi:c-inline () () :object "ecl_make_unsigned_integer(GC_get_total_bytes())" - :one-liner t))) + :one-liner t))) (if (< bytes orig) - (+ (- +wrap+ orig) bytes) - (- bytes orig)))) + (+ (- +wrap+ orig) bytes) + (- bytes orig)))) (deftype counter () '(integer 0 *)) @@ -206,28 +206,28 @@ extern ECL_API size_t GC_get_total_bytes(); (let ((dticks 0) (dconsing 0) (inner-enclosed-profiles 0) - (old-enclosed-ticks *enclosed-ticks*) - (old-enclosed-consing *enclosed-consing*) - (old-enclosed-profiles *enclosed-profiles*) - (start-ticks (get-internal-ticks)) - (start-consed (get-bytes-consed 0))) + (old-enclosed-ticks *enclosed-ticks*) + (old-enclosed-consing *enclosed-consing*) + (old-enclosed-profiles *enclosed-profiles*) + (start-ticks (get-internal-ticks)) + (start-consed (get-bytes-consed 0))) (unwind-protect - (progn - (setf *enclosed-ticks* 0 - *enclosed-profiles* 0 - *enclosed-consing* 0) - (apply encapsulated-fun args)) - (setf dticks (- (get-internal-ticks) start-ticks)) - (setf dconsing (get-bytes-consed start-consed)) - (setf inner-enclosed-profiles *enclosed-profiles*) - (let ((net-dticks (- dticks *enclosed-ticks*))) - (incf ticks net-dticks)) - (let ((net-dconsing (- dconsing *enclosed-consing*))) - (incf consing net-dconsing)) - (incf profiles inner-enclosed-profiles) + (progn + (setf *enclosed-ticks* 0 + *enclosed-profiles* 0 + *enclosed-consing* 0) + (apply encapsulated-fun args)) + (setf dticks (- (get-internal-ticks) start-ticks)) + (setf dconsing (get-bytes-consed start-consed)) + (setf inner-enclosed-profiles *enclosed-profiles*) + (let ((net-dticks (- dticks *enclosed-ticks*))) + (incf ticks net-dticks)) + (let ((net-dconsing (- dconsing *enclosed-consing*))) + (incf consing net-dconsing)) + (incf profiles inner-enclosed-profiles) (setf *enclosed-ticks* (+ old-enclosed-ticks dticks) - *enclosed-consing* (+ old-enclosed-consing dconsing) - *enclosed-profiles* (+ old-enclosed-profiles inner-enclosed-profiles 1))))) + *enclosed-consing* (+ old-enclosed-consing dconsing) + *enclosed-profiles* (+ old-enclosed-profiles inner-enclosed-profiles 1))))) ;; READ-STATS-FUN (lambda () (values count ticks consing profiles)) diff --git a/contrib/quicklisp/ecl-quicklisp.lisp b/contrib/quicklisp/ecl-quicklisp.lisp index 98cb5e8..36d6b3c 100644 --- a/contrib/quicklisp/ecl-quicklisp.lisp +++ b/contrib/quicklisp/ecl-quicklisp.lisp @@ -36,29 +36,29 @@ (ecl-curl:download-url-to-file *quicklisp-url* file) (load file) (eval (read-from-string - (format nil "(quicklisp-quickstart:install :path ~S)" - (namestring (truename target-directory)))) - ))) + (format nil "(quicklisp-quickstart:install :path ~S)" + (namestring (truename target-directory)))) + ))) (handler-case (progn (unless (probe-file *quicklisp-setup*) - (install-quicklisp *quicklisp-directory*)) + (install-quicklisp *quicklisp-directory*)) (unless (find-package "QL") - (load *quicklisp-setup*)) + (load *quicklisp-setup*)) (eval (read-from-string " (pushnew #'(ext:lambda-block quicklisp-require (module) - (let* ((module (string-downcase module))) - (when (find module (ql:provided-systems t) - :test #'string-equal - :key #'ql-dist:name) - (and (ql:quickload module) + (let* ((module (string-downcase module))) + (when (find module (ql:provided-systems t) + :test #'string-equal + :key #'ql-dist:name) + (and (ql:quickload module) (provide module))))) - sys::*module-provider-functions*) + sys::*module-provider-functions*) "))) (error (c) (format t "~%;;; Unable to load / install quicklisp. Error message follows:~%~A" - c))) + c))) (provide "ecl-quicklisp") diff --git a/contrib/serve-event/serve-event.lisp b/contrib/serve-event/serve-event.lisp index 6aa3871..e631a42 100644 --- a/contrib/serve-event/serve-event.lisp +++ b/contrib/serve-event/serve-event.lisp @@ -175,19 +175,19 @@ (setf maxfd fd)))) (multiple-value-bind (retval errno) - (if (null seconds) - ;; No timeout - (c-inline (rfd wfd (1+ maxfd)) - (:object :object :int) (values :int :int) - "{ @(return 0) = select(#2, (fd_set*)#0->foreign.data, + (if (null seconds) + ;; No timeout + (c-inline (rfd wfd (1+ maxfd)) + (:object :object :int) (values :int :int) + "{ @(return 0) = select(#2, (fd_set*)#0->foreign.data, (fd_set*)#1->foreign.data, NULL, NULL); @(return 1) = errno; }" - :one-liner nil - :side-effects t) - (c-inline (rfd wfd (1+ maxfd) seconds) - (:object :object :int :double) (values :int :int) - "{ struct timeval tv; + :one-liner nil + :side-effects t) + (c-inline (rfd wfd (1+ maxfd) seconds) + (:object :object :int :double) (values :int :int) + "{ struct timeval tv; double seconds = #3; tv.tv_sec = seconds; tv.tv_usec = (seconds * 1e6); @@ -195,26 +195,26 @@ (fd_set*)#1->foreign.data, NULL, &tv); @(return 1) = errno; }" - :one-liner nil - :side-effects t)) - - (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 diff --git a/contrib/sockets/package.lisp b/contrib/sockets/package.lisp index 7f0f022..99ce79a 100644 --- a/contrib/sockets/package.lisp +++ b/contrib/sockets/package.lisp @@ -13,12 +13,12 @@ (defpackage "SB-BSD-SOCKETS" (:use "CL" "FFI" "SI") (:export "GET-HOST-BY-NAME" "GET-HOST-BY-ADDRESS" - "SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT" - "SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN" - "SOCKET-RECEIVE" "SOCKET-CLOSE" "SOCKET-MAKE-STREAM" - "GET-PROTOCOL-BY-NAME" "MAKE-INET-ADDRESS" "LOCAL-SOCKET" - "SOCKET" "INET-SOCKET" "SOCKET-FILE-DESCRIPTOR" #+:win32 "NAMED-PIPE-SOCKET" - "SOCKET-FAMILY" "SOCKET-PROTOCOL" "SOCKET-TYPE" - "SOCKET-ERROR" "NAME-SERVICE-ERROR" "NON-BLOCKING-MODE" - "HOST-ENT-NAME" "HOST-ENT-ALIASES" "HOST-ENT-ADDRESS-TYPE" - "HOST-ENT-ADDRESSES" "HOST-ENT" "HOST-ENT-ADDRESS" "SOCKET-SEND")) + "SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT" + "SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN" + "SOCKET-RECEIVE" "SOCKET-CLOSE" "SOCKET-MAKE-STREAM" + "GET-PROTOCOL-BY-NAME" "MAKE-INET-ADDRESS" "LOCAL-SOCKET" + "SOCKET" "INET-SOCKET" "SOCKET-FILE-DESCRIPTOR" #+:win32 "NAMED-PIPE-SOCKET" + "SOCKET-FAMILY" "SOCKET-PROTOCOL" "SOCKET-TYPE" + "SOCKET-ERROR" "NAME-SERVICE-ERROR" "NON-BLOCKING-MODE" + "HOST-ENT-NAME" "HOST-ENT-ALIASES" "HOST-ENT-ADDRESS-TYPE" + "HOST-ENT-ADDRESSES" "HOST-ENT" "HOST-ENT-ADDRESS" "SOCKET-SEND")) diff --git a/contrib/sockets/sockets.lisp b/contrib/sockets/sockets.lisp index 9202122..19004c0 100755 --- a/contrib/sockets/sockets.lisp +++ b/contrib/sockets/sockets.lisp @@ -76,18 +76,18 @@ (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 @@ -97,8 +97,8 @@ (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 @@ -151,7 +151,7 @@ containing the whole rest of the given `string', if any." ((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 "")) @@ -168,23 +168,23 @@ HOST-NAME may also be an IP address in dotted quad notation or some other 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++) { @@ -204,45 +204,45 @@ weird stuff - see gethostbyname(3) for grisly details." 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++) { @@ -262,11 +262,11 @@ weird stuff - see gethostbyname(3) for grisly details." 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")))) @@ -277,19 +277,19 @@ weird stuff - see gethostbyname(3) for grisly details." (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)) @@ -303,26 +303,26 @@ directly instantiated.")) (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))))) @@ -357,8 +357,8 @@ defines the maximum length that the queue of pending connections may 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 @@ -369,9 +369,9 @@ so that the actual packet length is returned even if the buffer was too 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 @@ -433,61 +433,61 @@ SB-SYS:MAKE-FD-STREAM.")) (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; } @@ -552,16 +552,16 @@ Examples: (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) ; } ") @@ -571,24 +571,24 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, (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))) @@ -599,81 +599,81 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, 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; @@ -682,29 +682,29 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int 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; @@ -713,42 +713,42 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int 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 ) | @@ -757,36 +757,36 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, ( #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 ) | @@ -795,24 +795,24 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, ( #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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -831,29 +831,29 @@ also known as unix-domain sockets.")) (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) @@ -862,61 +862,61 @@ also known as unix-domain sockets.")) 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); @@ -925,8 +925,8 @@ also known as unix-domain sockets.")) } }"))) (if peer - peer - (socket-error "getpeername")))) + peer + (socket-error "getpeername")))) ) ;#-:wsock @@ -958,11 +958,11 @@ also known as unix-domain sockets.")) (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 "!~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 "!~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))) @@ -976,14 +976,14 @@ also known as unix-domain sockets.")) (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 "!" (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 "!" (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"))))) @@ -1025,24 +1025,24 @@ also known as unix-domain sockets.")) (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")) @@ -1052,15 +1052,15 @@ also known as unix-domain sockets.")) (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 @@ -1070,40 +1070,40 @@ also known as unix-domain sockets.")) ;; 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)) @@ -1114,11 +1114,11 @@ also known as unix-domain sockets.")) (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") @@ -1129,16 +1129,16 @@ also known as unix-domain sockets.")) (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")) @@ -1161,29 +1161,29 @@ also known as unix-domain sockets.")) (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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1203,23 +1203,23 @@ also known as unix-domain sockets.")) (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 @@ -1260,29 +1260,29 @@ ecl_make_stream_from_fd(#0,#1,(enum ecl_smmode)#2, :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 @@ -1294,16 +1294,16 @@ ecl_make_stream_from_fd(#0,#1,(enum ecl_smmode)#2, #+: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)) @@ -1318,22 +1318,22 @@ ecl_make_stream_from_fd(#0,#1,(enum ecl_smmode)#2, #+: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 @@ -1350,11 +1350,11 @@ ecl_make_stream_from_fd(#0,#1,(enum ecl_smmode)#2, (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) @@ -1422,22 +1422,22 @@ GET-NAME-SERVICE-ERRNO") (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 () @@ -1485,15 +1485,15 @@ GET-NAME-SERVICE-ERRNO") 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 @@ -1501,15 +1501,15 @@ GET-NAME-SERVICE-ERRNO") 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) @@ -1519,37 +1519,37 @@ GET-NAME-SERVICE-ERRNO") (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 @@ -1557,15 +1557,15 @@ GET-NAME-SERVICE-ERRNO") 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 @@ -1573,35 +1573,35 @@ GET-NAME-SERVICE-ERRNO") 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) @@ -1610,42 +1610,42 @@ GET-NAME-SERVICE-ERRNO") (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) diff --git a/contrib/sockets/test.lisp b/contrib/sockets/test.lisp index 2ea2c89..a63e250 100644 --- a/contrib/sockets/test.lisp +++ b/contrib/sockets/test.lisp @@ -43,18 +43,18 @@ ;; fail to make a socket: check correct error return. There's no nice ;; way to check the condition stuff on its own, which is a shame (handler-case - (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp")) + (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp")) ((or socket-type-not-supported-error protocol-not-supported-error) (c) - (declare (ignorable c)) t) + (declare (ignorable c)) t) (:no-error nil)) t) (deftest make-inet-socket-keyword-wrong ;; same again with keywords (handler-case - (make-instance 'inet-socket :type :stream :protocol :udp) + (make-instance 'inet-socket :type :stream :protocol :udp) ((or protocol-not-supported-error socket-type-not-supported-error) (c) - (declare (ignorable c)) t) + (declare (ignorable c)) t) (:no-error nil)) t) @@ -83,9 +83,9 @@ (do-gc-portably) ;gc should clear out any old sockets bound to this port (socket-bind s (make-inet-address "127.0.0.1") 1974) (handler-case - (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) - (socket-bind s2 (make-inet-address "127.0.0.1") 1974) - nil) + (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) + (socket-bind s2 (make-inet-address "127.0.0.1") 1974) + nil) (address-in-use-error () t))) t) @@ -113,23 +113,23 @@ ;;; these require that the echo services are turned on in inetd (deftest simple-tcp-client (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) - (data (make-string 200))) + (data (make-string 200))) (socket-connect s #(127 0 0 1) 7) (let ((stream (socket-make-stream s :input t :output t :buffering :none))) - (format stream "here is some text") - (let ((data (subseq data 0 (read-buf-nonblock data stream)))) - (format t "~&Got ~S back from TCP echo server~%" data) - (> (length data) 0)))) + (format stream "here is some text") + (let ((data (subseq data 0 (read-buf-nonblock data stream)))) + (format t "~&Got ~S back from TCP echo server~%" data) + (> (length data) 0)))) t) (deftest sockaddr-return-type (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) (unwind-protect - (progn - (socket-connect s #(127 0 0 1) 7) - (multiple-value-bind (host port) (socket-peername s) - (and (vectorp host) - (numberp port)))) + (progn + (socket-connect s #(127 0 0 1) 7) + (multiple-value-bind (host port) (socket-peername s) + (and (vectorp host) + (numberp port)))) (socket-close s))) t) @@ -142,8 +142,8 @@ (format stream "here is some text") (finish-output stream) (let ((data (subseq data 0 (read-buf-nonblock data stream)))) - (format t "~&Got ~S back from UDP echo server~%" data) - (> (length data) 0)))) + (format t "~&Got ~S back from UDP echo server~%" data) + (> (length data) 0)))) t) ;;; A fairly rudimentary test that connects to the syslog socket and @@ -158,23 +158,23 @@ ;; unavailable, or if it's a symlink to some weird character ;; device. (when (and (probe-file "/dev/log") - #-ecl - (sb-posix:s-issock - (sb-posix::stat-mode (sb-posix:stat "/dev/log")))) - (let ((s (make-instance 'local-socket :type :datagram))) - (format t "Connecting ~A... " s) - (finish-output) - (handler-case - (socket-connect s "/dev/log") - (socket-error () - (setq s (make-instance 'local-socket :type :stream)) - (format t "failed~%Retrying with ~A... " s) - (finish-output) - (socket-connect s "/dev/log"))) - (format t "ok.~%") - (let ((stream (socket-make-stream s :input t :output t :buffering :none))) - (format stream - "<7>sb-bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored")))) + #-ecl + (sb-posix:s-issock + (sb-posix::stat-mode (sb-posix:stat "/dev/log")))) + (let ((s (make-instance 'local-socket :type :datagram))) + (format t "Connecting ~A... " s) + (finish-output) + (handler-case + (socket-connect s "/dev/log") + (socket-error () + (setq s (make-instance 'local-socket :type :stream)) + (format t "failed~%Retrying with ~A... " s) + (finish-output) + (socket-connect s "/dev/log"))) + (format t "ok.~%") + (let ((stream (socket-make-stream s :input t :output t :buffering :none))) + (format stream + "<7>sb-bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored")))) t) t) @@ -207,13 +207,13 @@ (deftest simple-http-client-1 (handler-case - (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) - (let ((data (make-string 200))) - (setf data (subseq data 0 - (read-buf-nonblock data - (socket-make-stream s)))) - (princ data) - (> (length data) 0))) + (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) + (let ((data (make-string 200))) + (setf data (subseq data 0 + (read-buf-nonblock data + (socket-make-stream s)))) + (princ data) + (> (length data) 0))) (network-unreachable-error () 'network-unreachable)) t) @@ -223,14 +223,14 @@ ;; kernel: we set a size of x and then getsockopt() returns 2x. ;; This is why we compare with >= instead of = (handler-case - (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) - (setf (sockopt-receive-buffer s) 1975) - (let ((data (make-string 200))) - (setf data (subseq data 0 - (read-buf-nonblock data - (socket-make-stream s)))) - (and (> (length data) 0) - (>= (sockopt-receive-buffer s) 1975)))) + (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) + (setf (sockopt-receive-buffer s) 1975) + (let ((data (make-string 200))) + (setf data (subseq data 0 + (read-buf-nonblock data + (socket-make-stream s)))) + (and (> (length data) 0) + (>= (sockopt-receive-buffer s) 1975)))) (network-unreachable-error () 'network-unreachable)) t) @@ -253,4 +253,4 @@ (loop (multiple-value-bind (buf len address port) (socket-receive s nil 500) (format t "Received ~A bytes from ~A:~A - ~A ~%" - len address port (subseq buf 0 (min 10 len))))))) + len address port (subseq buf 0 (min 10 len))))))) diff --git a/contrib/unicode/load-names.lisp b/contrib/unicode/load-names.lisp index 9608f71..aeb8ba3 100644 --- a/contrib/unicode/load-names.lisp +++ b/contrib/unicode/load-names.lisp @@ -6,23 +6,23 @@ for c across text when (member c set) do (setf output (list* (make-array (+ (- i start) (if exclude 0 1)) - :element-type elt-type - :displaced-to text - :displaced-index-offset start) - output) - start (1+ i)) + :element-type elt-type + :displaced-to text + :displaced-index-offset start) + output) + start (1+ i)) finally (return (nreverse (list* (make-array (- i start) - :element-type elt-type - :displaced-to text - :displaced-index-offset start) - output))))) + :element-type elt-type + :displaced-to text + :displaced-index-offset start) + output))))) (defun encode-words (words hash) (loop for word in words collect (or (gethash word hash) - (let* ((word (copy-seq word)) - (ndx (hash-table-count hash))) - (setf (gethash word hash) (1+ ndx)))))) + (let* ((word (copy-seq word)) + (ndx (hash-table-count hash))) + (setf (gethash word hash) (1+ ndx)))))) (defun fixup-hangul-syllables (dictionary) ;; "Hangul Syllable Composition, Unicode 5.1 section 3-12" @@ -47,11 +47,11 @@ for v = (+ vbase (floor (mod sindex ncount) tcount)) for tee = (+ tbase (mod sindex tcount)) for name = (list* "HANGUL_" "SYLLABLE_" - (gethash l table) (gethash v table) - (unless (= tee tbase) (list (gethash tee table)))) + (gethash l table) (gethash v table) + (unless (= tee tbase) (list (gethash tee table)))) for code = (+ sbase sindex) collect (list* code (apply #'concatenate 'string name) - (encode-words name dictionary))))) + (encode-words name dictionary))))) (defun add-jamo-information (line table) (let* ((split (split-words line :set '(#\;) :exclude t)) @@ -68,17 +68,17 @@ for ucd-line = (read-line in nil nil nil) while ucd-line nconc (let* ((ucd-data (split-words ucd-line :set '(#\;))) - (code (first ucd-data)) - (name (second ucd-data))) - (unless (eql (char name 0) #\<) - (setf name (substitute #\_ #\Space name)) - (list (list* (parse-integer code :radix 16) - name - (encode-words (split-words - name - :set '(#\Space #\_ #\-) - :exclude nil) - words)))))))) + (code (first ucd-data)) + (name (second ucd-data))) + (unless (eql (char name 0) #\<) + (setf name (substitute #\_ #\Space name)) + (list (list* (parse-integer code :radix 16) + name + (encode-words (split-words + name + :set '(#\Space #\_ #\-) + :exclude nil) + words)))))))) (print (length *data*)) (print (first (last *data*))) @@ -86,9 +86,9 @@ ;#+(or) (progn (setf *data* - (sort (nconc (fixup-hangul-syllables *words*) *data*) - #'< - :key #'car)) + (sort (nconc (fixup-hangul-syllables *words*) *data*) + #'< + :key #'car)) (print (length *data*)) (print (first (last *data*)))) @@ -117,7 +117,7 @@ with last = start for (code name . rest) in *data* do (when (>= (- code last) 2) - (setf output (cons (list start last) output) - start code)) + (setf output (cons (list start last) output) + start code)) (setf last code) finally (return (nreverse (cons (list start code) output))))) diff --git a/contrib/unicode/names-pairs-sort.lisp b/contrib/unicode/names-pairs-sort.lisp index ce93a0b..56d314a 100644 --- a/contrib/unicode/names-pairs-sort.lisp +++ b/contrib/unicode/names-pairs-sort.lisp @@ -1,6 +1,6 @@ (defparameter *destination* (merge-pathnames "../../src/c/unicode/" - (or *load-truename* *compile-pathname*))) + (or *load-truename* *compile-pathname*))) (let* ((translated-data (copy-tree *compressed-data*)) (pairs (copy-tree *paired-data*)) @@ -14,39 +14,39 @@ for line in translated-data for pair-code = (third line) do (cond ((/= (length line) 3) - (error "Error in compressed data: too long code ~A" line)) - ((or (aref used-code pair-code) - (< pair-code first-code)) - (let ((new-pair (cons pair-code 0))) - (setf pairs (acons (incf last-code) new-pair pairs) - (third line) last-code))) - (t - (setf (aref used-code pair-code) t)))) + (error "Error in compressed data: too long code ~A" line)) + ((or (aref used-code pair-code) + (< pair-code first-code)) + (let ((new-pair (cons pair-code 0))) + (setf pairs (acons (incf last-code) new-pair pairs) + (third line) last-code))) + (t + (setf (aref used-code pair-code) t)))) ;; ;; We now renumber all pairs. ;; (let ((translation-table (make-array (1+ last-code) :initial-element nil)) - (counter -1)) + (counter -1)) (flet ((add-code (code) - (or (aref translation-table code) - (setf (aref translation-table code) (incf counter)))) - (translate (old-code) - (or (aref translation-table old-code) - (error "Unknown code ~A" old-code)))) + (or (aref translation-table code) + (setf (aref translation-table code) (incf counter)))) + (translate (old-code) + (or (aref translation-table old-code) + (error "Unknown code ~A" old-code)))) ;; First of all we add the words (loop for i from 0 below first-code - do (add-code i)) + do (add-code i)) ;; Then we add all pairs that represent characters, so that they ;; are consecutive, too. (loop for line in translated-data - do (setf (third line) (add-code (third line)))) + do (setf (third line) (add-code (third line)))) ;; Finally, we add the remaining pairs (loop for record in pairs - do (setf (car record) (add-code (car record)))) + do (setf (car record) (add-code (car record)))) ;; ... and we fix the definitions (loop for (code . pair) in pairs - do (setf (car pair) (translate (car pair)) - (cdr pair) (translate (cdr pair)))))) + do (setf (car pair) (translate (car pair)) + (cdr pair) (translate (cdr pair)))))) (defparameter *sorted-compressed-data* translated-data) (defparameter *sorted-pairs* (sort pairs #'< :key #'car)) (print 'finished) @@ -62,24 +62,24 @@ for line in *sorted-compressed-data* for (ucd-code name code) = line do (cond ((/= code n) - (error "Codes in *sorted-compressed-data* are not consecutive:~%~A" - (cons line (subseq aux 0 10)))) - ((null start-ucd-code) - (setf start-ucd-code ucd-code - start-code code)) - ((= last-ucd-code (1- ucd-code)) - ) - (t - (push (list start-ucd-code last-ucd-code start-code) - output) - (setf start-ucd-code ucd-code - start-code code))) + (error "Codes in *sorted-compressed-data* are not consecutive:~%~A" + (cons line (subseq aux 0 10)))) + ((null start-ucd-code) + (setf start-ucd-code ucd-code + start-code code)) + ((= last-ucd-code (1- ucd-code)) + ) + (t + (push (list start-ucd-code last-ucd-code start-code) + output) + (setf start-ucd-code ucd-code + start-code code))) (setf last-ucd-code ucd-code aux (cons line aux)) finally (return (nreverse output)))) (with-open-file (s (merge-pathnames "ucd_names.h" *destination*) - :direction :output - :if-exists :supersede) + :direction :output + :if-exists :supersede) (format s "/* * UNICODE NAMES DATABASE */ @@ -112,17 +112,17 @@ extern const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES]; #endif " - (1+ *last-word-index*) - (length *sorted-pairs*) - (length *grouped-characters*) - (loop for (code name . rest) in *compressed-data* - maximize (length name)) - (length *compressed-data*) - )) + (1+ *last-word-index*) + (length *sorted-pairs*) + (length *grouped-characters*) + (loop for (code name . rest) in *compressed-data* + maximize (length name)) + (length *compressed-data*) + )) (with-open-file (s (merge-pathnames "ucd_names_pair.c" *destination*) - :direction :output - :if-exists :supersede) + :direction :output + :if-exists :supersede) (format s "/* * Pairs of symbols. */ @@ -132,19 +132,19 @@ extern const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES]; const ecl_ucd_names_pair_type ecl_ucd_names_pair[ECL_UCD_TOTAL_PAIRS] = { " - (length *sorted-pairs*) (length *sorted-pairs*)) + (length *sorted-pairs*) (length *sorted-pairs*)) (loop for i from 0 for (pair-code . (a . b)) in *sorted-pairs* do (format s "~A{~D, ~D, ~D, ~D}~%" - (if (plusp i) "," "") - (logand a #xff) (ash a -8) - (logand b #xff) (ash b -8) - )) + (if (plusp i) "," "") + (logand a #xff) (ash a -8) + (logand b #xff) (ash b -8) + )) (format s "};~%")) (with-open-file (s (merge-pathnames "ucd_names_codes.c" *destination*) - :direction :output - :if-exists :supersede) + :direction :output + :if-exists :supersede) (format s "/* * Sorted character names. */ @@ -158,15 +158,15 @@ const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES] = { for (ucd-code name code) in l for i from 0 do (format s "~A{{~D, ~D}, {~D, ~D, ~D}}~%" - (if (plusp i) "," "") - (logand code #xff) (ash code -8) - (logand ucd-code #xff) (logand (ash ucd-code -8) #xff) - (logand (ash ucd-code -16) #xff))) + (if (plusp i) "," "") + (logand code #xff) (ash code -8) + (logand ucd-code #xff) (logand (ash ucd-code -8) #xff) + (logand (ash ucd-code -16) #xff))) (format s "};")) (with-open-file (s (merge-pathnames "ucd_names_str.c" *destination*) - :direction :output - :if-exists :supersede) + :direction :output + :if-exists :supersede) (format s "/* * Dictionary words. */ @@ -182,8 +182,8 @@ const char *ecl_ucd_names_word[ECL_UCD_FIRST_PAIR] = { (format s "};~%")) (with-open-file (s (merge-pathnames "ucd_names_char.c" *destination*) - :direction :output - :if-exists :supersede) + :direction :output + :if-exists :supersede) (format s "/* * Dictionary words. */ @@ -194,11 +194,11 @@ const char *ecl_ucd_names_word[ECL_UCD_FIRST_PAIR] = { const ecl_ucd_names_char_group ecl_ucd_names_char[ECL_UCD_TOTAL_GROUPS] = { " - (length *grouped-characters*)) + (length *grouped-characters*)) (loop for i from 0 for (start end pair-code) in *grouped-characters* do (format s "~A{~D,~D,~D}~%" (if (plusp i) "," "") - start end pair-code)) + start end pair-code)) (format s "}; static int @@ -266,7 +266,7 @@ _ecl_ucd_name_to_code(cl_object name) ecl_character c = ecl_char_upcase(ecl_char(name, mid)); buffer1[mid] = c; if (c < 32 || c > 127) /* All character names are [-A-Z_0-9]* */ - return ECL_NIL; + return ECL_NIL; } buffer1[mid] = 0; do { @@ -295,4 +295,4 @@ _ecl_ucd_name_to_code(cl_object name) ")) -;(ext:run-program "/bin/sh" '("-c" "cp *.c *.h ~/devel/ecl/src/c/unicode/")) \ No newline at end of file +;(ext:run-program "/bin/sh" '("-c" "cp *.c *.h ~/devel/ecl/src/c/unicode/")) diff --git a/contrib/unicode/names-pairs.lisp b/contrib/unicode/names-pairs.lisp index 8ff0df8..852aff2 100644 --- a/contrib/unicode/names-pairs.lisp +++ b/contrib/unicode/names-pairs.lisp @@ -10,32 +10,32 @@ with max-pair = nil for (code name . l) in data do (loop for l2 on l - for a = (car l2) - for b = (cadr l2) - while b - do (let* ((pair (cons a b)) - (c (gethash pair table))) - (setf (gethash pair table) - (setf c (if c (1+ c) 1)) - a b) - (when (> c max) - (setf max c max-pair pair)))) + for a = (car l2) + for b = (cadr l2) + while b + do (let* ((pair (cons a b)) + (c (gethash pair table))) + (setf (gethash pair table) + (setf c (if c (1+ c) 1)) + a b) + (when (> c max) + (setf max c max-pair pair)))) finally (return (cons max max-pair)))) (defun replace-pair (pair code data) (let ((old-a (car pair)) - (old-b (cdr pair))) + (old-b (cdr pair))) (loop with more = 0 for (ucd-code name . l) in data do (loop with l2 = l - for a = (first l2) - for b = (second l2) - while b - do (when (and (eql a old-a) (eql b old-b)) - ;; replace (a b . c) with (pair . c) - (setf (car l2) code - (cdr l2) (cddr l2))) - do (setf l2 (cdr l2))) + for a = (first l2) + for b = (second l2) + while b + do (when (and (eql a old-a) (eql b old-b)) + ;; replace (a b . c) with (pair . c) + (setf (car l2) code + (cdr l2) (cddr l2))) + do (setf l2 (cdr l2))) do (setf more (+ more (1- (length l)))) finally (return more)))) @@ -48,21 +48,21 @@ while (and pair (> frequency 1)) do (format t "~%;;; ~A, ~D -> ~D, ~D left" pair frequency new-symbol - (replace-pair pair new-symbol data)) + (replace-pair pair new-symbol data)) (setf pairs (acons new-symbol pair pairs)) finally ;; There are no redundant pairs. We just define ad-hoc new ;; symbols for all remaining strings. (loop with n = new-symbol - for (code name . l) in data - do (loop with l2 = l - for a = (first l2) - for b = (second l2) - while b - do (setf pairs (acons n (cons a b) pairs) - (car l2) n - (cdr l2) (cddr l2) - n (1+ n)))) + for (code name . l) in data + do (loop with l2 = l + for a = (first l2) + for b = (second l2) + while b + do (setf pairs (acons n (cons a b) pairs) + (car l2) n + (cdr l2) (cddr l2) + n (1+ n)))) (print 'finished) (return-from compress (nreverse pairs)))) @@ -75,13 +75,13 @@ (defparameter *code-ndx-size* (ceiling (integer-length *last-code*) 8)) (defparameter *pair-table-size* (* (length *paired-data*) - (* 2 *code-ndx-size*))) + (* 2 *code-ndx-size*))) (defparameter *code-to-name-bytes* (* (length *compressed-data*) (+ 3 ; Size of Unicode code - ;; Size of index into the data table - *code-ndx-size*))) + ;; Size of index into the data table + *code-ndx-size*))) (defparameter *sorted-names-bytes* ;; The sorted list of character names is just a list of indices into @@ -98,16 +98,16 @@ ;;; Names to codes table = ~D bytes ;;; Total = ~D bytes " - *word-dictionary* - *pair-table-size* - *code-to-name-bytes* - *sorted-names-bytes* - (+ - *word-dictionary* - *pair-table-size* - *code-to-name-bytes* - *sorted-names-bytes* - )) + *word-dictionary* + *pair-table-size* + *code-to-name-bytes* + *sorted-names-bytes* + (+ + *word-dictionary* + *pair-table-size* + *code-to-name-bytes* + *sorted-names-bytes* + )) ;;; WITH HANGUL ;;; Codes dictionary = 78566 bytes diff --git a/contrib/unicode/ucd.lisp b/contrib/unicode/ucd.lisp index 4b6c41d..3a0c5d8 100644 --- a/contrib/unicode/ucd.lisp +++ b/contrib/unicode/ucd.lisp @@ -104,8 +104,8 @@ (setq *decomposition-base* (make-array (total-ucd-pages) :initial-element nil)) (setq *ucd-base* (make-array (total-ucd-pages) :initial-element nil)) (with-open-file (*standard-input* - (make-pathname :name "UnicodeData" :type "txt" - :defaults *extension-directory*) + (make-pathname :name "UnicodeData" :type "txt" + :defaults *extension-directory*) :direction :input :external-format :default) (loop for line = (read-line nil nil) while line @@ -327,9 +327,9 @@ :element-type '(unsigned-byte 8) :if-exists :supersede :if-does-not-exist :create) - (let ((offset (* (length *misc-table*) 8))) - (write-byte (mod offset *page-size*) stream) - (write-byte (floor offset *page-size*) stream)) + (let ((offset (* (length *misc-table*) 8))) + (write-byte (mod offset *page-size*) stream) + (write-byte (floor offset *page-size*) stream)) (loop for (gc-index bidi-index ccc-index decimal-digit digit bidi-mirrored) across *misc-table* diff --git a/contrib/win32/lisp-kw.lisp b/contrib/win32/lisp-kw.lisp index 3da3bbf..c800ff4 100644 --- a/contrib/win32/lisp-kw.lisp +++ b/contrib/win32/lisp-kw.lisp @@ -1,371 +1,371 @@ (in-package "WIN32") (defparameter *txtedit-lisp-kw* -"* find-method pprint-indent - ** find-package pprint-linear - *** find-restart pprint-logical-block - + find-symbol pprint-newline - ++ finish-output pprint-pop - +++ first pprint-tab - - fixnum pprint-tabular - / flet prin1 - // float prin1-to-string - /// float-digits princ - /= float-precision princ-to-string - 1+ float-radix print - 1- float-sign print-not-readable - < floating-point-inexact print-not-readable-object - <= floating-point-invalid-operation print-object - = floating-point-overflow print-unreadable-object - > floating-point-underflow probe-file - >= floatp proclaim - abort floor prog - abs fmakunbound prog* - access force-output prog1 - acons format prog2 - acos formatter progn - acosh fourth program-error - add-method fresh-line progv - adjoin fround provide - adjust-array ftruncate psetf - adjustable-array-p ftype psetq - allocate-instance funcall push - alpha-char-p function pushnew - alphanumericp function-keywords putprop - and function-lambda-expression quote - append functionp random - apply gbitp random-state - applyhook gcd random-state-p - apropos generic-function rassoc - apropos-list gensym rassoc-if - aref gentemp rassoc-if-not - arithmetic-error get ratio - arithmetic-error-operands get-decoded-time rational - arithmetic-error-operation get-dispatch-macro-character rationalize - array get-internal-real-time rationalp - array-dimension get-internal-run-time read - array-dimension-limit get-macro-character read-byte - array-dimensions get-output-stream-string read-char - array-displacement get-properties read-char-no-hang - array-element-type get-setf-expansion read-delimited-list - array-has-fill-pointer-p get-setf-method read-eval-print - array-in-bounds-p get-universal-time read-from-string - array-rank getf read-line - array-rank-limit gethash read-preserving-whitespace - array-row-major-index go read-sequence - array-total-size graphic-char-p reader-error - array-total-size-limit handler-bind readtable - arrayp handler-case readtable-case - ash hash-table readtablep - asin hash-table-count real - asinh hash-table-p realp - assert hash-table-rehash-size realpart - assoc hash-table-rehash-threshold reduce - assoc-if hash-table-size reinitialize-instance - assoc-if-not hash-table-test rem - atan host-namestring remf - atanh identity remhash - atom if remove - base-char if-exists remove-duplicates - base-string ignorable remove-if - bignum ignore remove-if-not - bit ignore-errors remove-method - bit-and imagpart remprop - bit-andc1 import rename-file - bit-andc2 in-package rename-package - bit-eqv in-package replace - bit-ior incf require - bit-nand initialize-instance rest - bit-nor inline restart - bit-not input-stream-p restart-bind - bit-orc1 inspect restart-case - bit-orc2 int-char restart-name - bit-vector integer return - bit-vector-p integer-decode-float return-from - bit-xor integer-length revappend - block integerp reverse - boole interactive-stream-p room - boole-1 intern rotatef - boole-2 internal-time-units-per-second round - boole-and intersection row-major-aref - boole-andc1 invalid-method-error rplaca - boole-andc2 invoke-debugger rplacd - boole-c1 invoke-restart safety - boole-c2 invoke-restart-interactively satisfies - boole-clr isqrt sbit - boole-eqv keyword scale-float - boole-ior keywordp schar - boole-nand labels search - boole-nor lambda second - boole-orc1 lambda-list-keywords sequence - boole-orc2 lambda-parameters-limit serious-condition - boole-set last set - boole-xor lcm set-char-bit - boolean ldb set-difference - both-case-p ldb-test set-dispatch-macro-character - boundp ldiff set-exclusive-or - break least-negative-double-float set-macro-character - broadcast-stream least-negative-long-float set-pprint-dispatch - broadcast-stream-streams least-negative-normalized-double-float set-syntax-from-char - built-in-class least-negative-normalized-long-float setf - butlast least-negative-normalized-short-float setq - byte least-negative-normalized-single-float seventh - byte-position least-negative-short-float shadow - byte-size least-negative-single-float shadowing-import - call-arguments-limit least-positive-double-float shared-initialize - call-method least-positive-long-float shiftf - call-next-method least-positive-normalized-double-float short-float - capitalize least-positive-normalized-long-float short-float-epsilon - car least-positive-normalized-short-float short-float-negative-epsilon - case least-positive-normalized-single-float short-site-name - catch least-positive-short-float signal - ccase least-positive-single-float signed-byte - cdr length signum - ceiling let simle-condition - cell-error let* simple-array - cell-error-name lisp simple-base-string - cerror lisp-implementation-type simple-bit-vector - change-class lisp-implementation-version simple-bit-vector-p - char list simple-condition-format-arguments - char-bit list* simple-condition-format-control - char-bits list-all-packages simple-error - char-bits-limit list-length simple-string - char-code listen simple-string-p - char-code-limit listp simple-type-error - char-control-bit load simple-vector - char-downcase load-logical-pathname-translations simple-vector-p - char-equal load-time-value simple-warning - char-font locally sin - char-font-limit log single-flaot-epsilon - char-greaterp logand single-float - char-hyper-bit logandc1 single-float-epsilon - char-int logandc2 single-float-negative-epsilon - char-lessp logbitp sinh - char-meta-bit logcount sixth - char-name logeqv sleep - char-not-equal logical-pathname slot-boundp - char-not-greaterp logical-pathname-translations slot-exists-p - char-not-lessp logior slot-makunbound - char-super-bit lognand slot-missing - char-upcase lognor slot-unbound - char/= lognot slot-value - char< logorc1 software-type - char<= logorc2 software-version - char= logtest some - char> logxor sort - char>= long-float space - character long-float-epsilon special - characterp long-float-negative-epsilon special-form-p - check-type long-site-name special-operator-p - cis loop speed - class loop-finish sqrt - class-name lower-case-p stable-sort - class-of machine-instance standard - clear-input machine-type standard-char - clear-output machine-version standard-char-p - close macro-function standard-class - clrhash macroexpand standard-generic-function - code-char macroexpand-1 standard-method - coerce macroexpand-l standard-object - commonp macrolet step - compilation-speed make-array storage-condition - compile make-array store-value - compile-file make-broadcast-stream stream - compile-file-pathname make-char stream-element-type - compiled-function make-concatenated-stream stream-error - compiled-function-p make-condition stream-error-stream - compiler-let make-dispatch-macro-character stream-external-format - compiler-macro make-echo-stream streamp - compiler-macro-function make-hash-table streamup - complement make-instance string - complex make-instances-obsolete string-capitalize - complexp make-list string-char - compute-applicable-methods make-load-form string-char-p - compute-restarts make-load-form-saving-slots string-downcase - concatenate make-method string-equal - concatenated-stream make-package string-greaterp - concatenated-stream-streams make-pathname string-left-trim - cond make-random-state string-lessp - condition make-sequence string-not-equal - conjugate make-string string-not-greaterp - cons make-string-input-stream string-not-lessp - consp make-string-output-stream string-right-strim - constantly make-symbol string-right-trim - constantp make-synonym-stream string-stream - continue make-two-way-stream string-trim - control-error makunbound string-upcase - copy-alist map string/= - copy-list map-into string< - copy-pprint-dispatch mapc string<= - copy-readtable mapcan string= - copy-seq mapcar string> - copy-structure mapcon string>= - copy-symbol maphash stringp - copy-tree mapl structure - cos maplist structure-class - cosh mask-field structure-object - count max style-warning - count-if member sublim - count-if-not member-if sublis - ctypecase member-if-not subseq - debug merge subsetp - decf merge-pathname subst - declaim merge-pathnames subst-if - declaration method subst-if-not - declare method-combination substitute - decode-float method-combination-error substitute-if - decode-universal-time method-qualifiers substitute-if-not - defclass min subtypep - defconstant minusp svref - defgeneric mismatch sxhash - define-compiler-macro mod symbol - define-condition most-negative-double-float symbol-function - define-method-combination most-negative-fixnum symbol-macrolet - define-modify-macro most-negative-long-float symbol-name - define-setf-expander most-negative-short-float symbol-package - define-setf-method most-negative-single-float symbol-plist - define-symbol-macro most-positive-double-float symbol-value - defmacro most-positive-fixnum symbolp - defmethod most-positive-long-float synonym-stream - defpackage most-positive-short-float synonym-stream-symbol - defparameter most-positive-single-float sys - defsetf muffle-warning system - defstruct multiple-value-bind t - deftype multiple-value-call tagbody - defun multiple-value-list tailp - defvar multiple-value-prog1 tan - delete multiple-value-seteq tanh - delete-duplicates multiple-value-setq tenth - delete-file multiple-values-limit terpri - delete-if name-char the - delete-if-not namestring third - delete-package nbutlast throw - denominator nconc time - deposit-field next-method-p trace - describe nil translate-logical-pathname - describe-object nintersection translate-pathname - destructuring-bind ninth tree-equal - digit-char no-applicable-method truename - digit-char-p no-next-method truncase - directory not truncate - directory-namestring notany two-way-stream - disassemble notevery two-way-stream-input-stream - division-by-zero notinline two-way-stream-output-stream - do nreconc type - do* nreverse type-error - do-all-symbols nset-difference type-error-datum - do-exeternal-symbols nset-exclusive-or type-error-expected-type - do-external-symbols nstring type-of - do-symbols nstring-capitalize typecase - documentation nstring-downcase typep - dolist nstring-upcase unbound-slot - dotimes nsublis unbound-slot-instance - double-float nsubst unbound-variable - double-float-epsilon nsubst-if undefined-function - double-float-negative-epsilon nsubst-if-not unexport - dpb nsubstitute unintern - dribble nsubstitute-if union - dynamic-extent nsubstitute-if-not unless - ecase nth unread - echo-stream nth-value unread-char - echo-stream-input-stream nthcdr unsigned-byte - echo-stream-output-stream null untrace - ed number unuse-package - eighth numberp unwind-protect - elt numerator update-instance-for-different-class - encode-universal-time nunion update-instance-for-redefined-class - end-of-file oddp upgraded-array-element-type - endp open upgraded-complex-part-type - enough-namestring open-stream-p upper-case-p - ensure-directories-exist optimize use-package - ensure-generic-function or use-value - eq otherwise user - eql output-stream-p user-homedir-pathname - equal package values - equalp package-error values-list - error package-error-package vector - etypecase package-name vector-pop - eval package-nicknames vector-push - eval-when package-shadowing-symbols vector-push-extend - evalhook package-use-list vectorp - evenp package-used-by-list warn - every packagep warning - exp pairlis when - export parse-error wild-pathname-p - expt parse-integer with-accessors - extended-char parse-namestring with-compilation-unit - fboundp pathname with-condition-restarts - fceiling pathname-device with-hash-table-iterator - fdefinition pathname-directory with-input-from-string - ffloor pathname-host with-open-file - fifth pathname-match-p with-open-stream - file-author pathname-name with-output-to-string - file-error pathname-type with-package-iterator - file-error-pathname pathname-version with-simple-restart - file-length pathnamep with-slots - file-namestring peek-char with-standard-io-syntax - file-position phase write - file-stream pi write-byte - file-string-length plusp write-char - file-write-date pop write-line - fill position write-sequence - fill-pointer position-if write-string - find position-if-not write-to-string - find-all-symbols pprint y-or-n-p - find-class pprint-dispatch yes-or-no-p - find-if pprint-exit-if-list-exhausted zerop - find-if-not pprint-fill +"* find-method pprint-indent + ** find-package pprint-linear + *** find-restart pprint-logical-block + + find-symbol pprint-newline + ++ finish-output pprint-pop + +++ first pprint-tab + - fixnum pprint-tabular + / flet prin1 + // float prin1-to-string + /// float-digits princ + /= float-precision princ-to-string + 1+ float-radix print + 1- float-sign print-not-readable + < floating-point-inexact print-not-readable-object + <= floating-point-invalid-operation print-object + = floating-point-overflow print-unreadable-object + > floating-point-underflow probe-file + >= floatp proclaim + abort floor prog + abs fmakunbound prog* + access force-output prog1 + acons format prog2 + acos formatter progn + acosh fourth program-error + add-method fresh-line progv + adjoin fround provide + adjust-array ftruncate psetf + adjustable-array-p ftype psetq + allocate-instance funcall push + alpha-char-p function pushnew + alphanumericp function-keywords putprop + and function-lambda-expression quote + append functionp random + apply gbitp random-state + applyhook gcd random-state-p + apropos generic-function rassoc + apropos-list gensym rassoc-if + aref gentemp rassoc-if-not + arithmetic-error get ratio + arithmetic-error-operands get-decoded-time rational + arithmetic-error-operation get-dispatch-macro-character rationalize + array get-internal-real-time rationalp + array-dimension get-internal-run-time read + array-dimension-limit get-macro-character read-byte + array-dimensions get-output-stream-string read-char + array-displacement get-properties read-char-no-hang + array-element-type get-setf-expansion read-delimited-list + array-has-fill-pointer-p get-setf-method read-eval-print + array-in-bounds-p get-universal-time read-from-string + array-rank getf read-line + array-rank-limit gethash read-preserving-whitespace + array-row-major-index go read-sequence + array-total-size graphic-char-p reader-error + array-total-size-limit handler-bind readtable + arrayp handler-case readtable-case + ash hash-table readtablep + asin hash-table-count real + asinh hash-table-p realp + assert hash-table-rehash-size realpart + assoc hash-table-rehash-threshold reduce + assoc-if hash-table-size reinitialize-instance + assoc-if-not hash-table-test rem + atan host-namestring remf + atanh identity remhash + atom if remove + base-char if-exists remove-duplicates + base-string ignorable remove-if + bignum ignore remove-if-not + bit ignore-errors remove-method + bit-and imagpart remprop + bit-andc1 import rename-file + bit-andc2 in-package rename-package + bit-eqv in-package replace + bit-ior incf require + bit-nand initialize-instance rest + bit-nor inline restart + bit-not input-stream-p restart-bind + bit-orc1 inspect restart-case + bit-orc2 int-char restart-name + bit-vector integer return + bit-vector-p integer-decode-float return-from + bit-xor integer-length revappend + block integerp reverse + boole interactive-stream-p room + boole-1 intern rotatef + boole-2 internal-time-units-per-second round + boole-and intersection row-major-aref + boole-andc1 invalid-method-error rplaca + boole-andc2 invoke-debugger rplacd + boole-c1 invoke-restart safety + boole-c2 invoke-restart-interactively satisfies + boole-clr isqrt sbit + boole-eqv keyword scale-float + boole-ior keywordp schar + boole-nand labels search + boole-nor lambda second + boole-orc1 lambda-list-keywords sequence + boole-orc2 lambda-parameters-limit serious-condition + boole-set last set + boole-xor lcm set-char-bit + boolean ldb set-difference + both-case-p ldb-test set-dispatch-macro-character + boundp ldiff set-exclusive-or + break least-negative-double-float set-macro-character + broadcast-stream least-negative-long-float set-pprint-dispatch + broadcast-stream-streams least-negative-normalized-double-float set-syntax-from-char + built-in-class least-negative-normalized-long-float setf + butlast least-negative-normalized-short-float setq + byte least-negative-normalized-single-float seventh + byte-position least-negative-short-float shadow + byte-size least-negative-single-float shadowing-import + call-arguments-limit least-positive-double-float shared-initialize + call-method least-positive-long-float shiftf + call-next-method least-positive-normalized-double-float short-float + capitalize least-positive-normalized-long-float short-float-epsilon + car least-positive-normalized-short-float short-float-negative-epsilon + case least-positive-normalized-single-float short-site-name + catch least-positive-short-float signal + ccase least-positive-single-float signed-byte + cdr length signum + ceiling let simle-condition + cell-error let* simple-array + cell-error-name lisp simple-base-string + cerror lisp-implementation-type simple-bit-vector + change-class lisp-implementation-version simple-bit-vector-p + char list simple-condition-format-arguments + char-bit list* simple-condition-format-control + char-bits list-all-packages simple-error + char-bits-limit list-length simple-string + char-code listen simple-string-p + char-code-limit listp simple-type-error + char-control-bit load simple-vector + char-downcase load-logical-pathname-translations simple-vector-p + char-equal load-time-value simple-warning + char-font locally sin + char-font-limit log single-flaot-epsilon + char-greaterp logand single-float + char-hyper-bit logandc1 single-float-epsilon + char-int logandc2 single-float-negative-epsilon + char-lessp logbitp sinh + char-meta-bit logcount sixth + char-name logeqv sleep + char-not-equal logical-pathname slot-boundp + char-not-greaterp logical-pathname-translations slot-exists-p + char-not-lessp logior slot-makunbound + char-super-bit lognand slot-missing + char-upcase lognor slot-unbound + char/= lognot slot-value + char< logorc1 software-type + char<= logorc2 software-version + char= logtest some + char> logxor sort + char>= long-float space + character long-float-epsilon special + characterp long-float-negative-epsilon special-form-p + check-type long-site-name special-operator-p + cis loop speed + class loop-finish sqrt + class-name lower-case-p stable-sort + class-of machine-instance standard + clear-input machine-type standard-char + clear-output machine-version standard-char-p + close macro-function standard-class + clrhash macroexpand standard-generic-function + code-char macroexpand-1 standard-method + coerce macroexpand-l standard-object + commonp macrolet step + compilation-speed make-array storage-condition + compile make-array store-value + compile-file make-broadcast-stream stream + compile-file-pathname make-char stream-element-type + compiled-function make-concatenated-stream stream-error + compiled-function-p make-condition stream-error-stream + compiler-let make-dispatch-macro-character stream-external-format + compiler-macro make-echo-stream streamp + compiler-macro-function make-hash-table streamup + complement make-instance string + complex make-instances-obsolete string-capitalize + complexp make-list string-char + compute-applicable-methods make-load-form string-char-p + compute-restarts make-load-form-saving-slots string-downcase + concatenate make-method string-equal + concatenated-stream make-package string-greaterp + concatenated-stream-streams make-pathname string-left-trim + cond make-random-state string-lessp + condition make-sequence string-not-equal + conjugate make-string string-not-greaterp + cons make-string-input-stream string-not-lessp + consp make-string-output-stream string-right-strim + constantly make-symbol string-right-trim + constantp make-synonym-stream string-stream + continue make-two-way-stream string-trim + control-error makunbound string-upcase + copy-alist map string/= + copy-list map-into string< + copy-pprint-dispatch mapc string<= + copy-readtable mapcan string= + copy-seq mapcar string> + copy-structure mapcon string>= + copy-symbol maphash stringp + copy-tree mapl structure + cos maplist structure-class + cosh mask-field structure-object + count max style-warning + count-if member sublim + count-if-not member-if sublis + ctypecase member-if-not subseq + debug merge subsetp + decf merge-pathname subst + declaim merge-pathnames subst-if + declaration method subst-if-not + declare method-combination substitute + decode-float method-combination-error substitute-if + decode-universal-time method-qualifiers substitute-if-not + defclass min subtypep + defconstant minusp svref + defgeneric mismatch sxhash + define-compiler-macro mod symbol + define-condition most-negative-double-float symbol-function + define-method-combination most-negative-fixnum symbol-macrolet + define-modify-macro most-negative-long-float symbol-name + define-setf-expander most-negative-short-float symbol-package + define-setf-method most-negative-single-float symbol-plist + define-symbol-macro most-positive-double-float symbol-value + defmacro most-positive-fixnum symbolp + defmethod most-positive-long-float synonym-stream + defpackage most-positive-short-float synonym-stream-symbol + defparameter most-positive-single-float sys + defsetf muffle-warning system + defstruct multiple-value-bind t + deftype multiple-value-call tagbody + defun multiple-value-list tailp + defvar multiple-value-prog1 tan + delete multiple-value-seteq tanh + delete-duplicates multiple-value-setq tenth + delete-file multiple-values-limit terpri + delete-if name-char the + delete-if-not namestring third + delete-package nbutlast throw + denominator nconc time + deposit-field next-method-p trace + describe nil translate-logical-pathname + describe-object nintersection translate-pathname + destructuring-bind ninth tree-equal + digit-char no-applicable-method truename + digit-char-p no-next-method truncase + directory not truncate + directory-namestring notany two-way-stream + disassemble notevery two-way-stream-input-stream + division-by-zero notinline two-way-stream-output-stream + do nreconc type + do* nreverse type-error + do-all-symbols nset-difference type-error-datum + do-exeternal-symbols nset-exclusive-or type-error-expected-type + do-external-symbols nstring type-of + do-symbols nstring-capitalize typecase + documentation nstring-downcase typep + dolist nstring-upcase unbound-slot + dotimes nsublis unbound-slot-instance + double-float nsubst unbound-variable + double-float-epsilon nsubst-if undefined-function + double-float-negative-epsilon nsubst-if-not unexport + dpb nsubstitute unintern + dribble nsubstitute-if union + dynamic-extent nsubstitute-if-not unless + ecase nth unread + echo-stream nth-value unread-char + echo-stream-input-stream nthcdr unsigned-byte + echo-stream-output-stream null untrace + ed number unuse-package + eighth numberp unwind-protect + elt numerator update-instance-for-different-class + encode-universal-time nunion update-instance-for-redefined-class + end-of-file oddp upgraded-array-element-type + endp open upgraded-complex-part-type + enough-namestring open-stream-p upper-case-p + ensure-directories-exist optimize use-package + ensure-generic-function or use-value + eq otherwise user + eql output-stream-p user-homedir-pathname + equal package values + equalp package-error values-list + error package-error-package vector + etypecase package-name vector-pop + eval package-nicknames vector-push + eval-when package-shadowing-symbols vector-push-extend + evalhook package-use-list vectorp + evenp package-used-by-list warn + every packagep warning + exp pairlis when + export parse-error wild-pathname-p + expt parse-integer with-accessors + extended-char parse-namestring with-compilation-unit + fboundp pathname with-condition-restarts + fceiling pathname-device with-hash-table-iterator + fdefinition pathname-directory with-input-from-string + ffloor pathname-host with-open-file + fifth pathname-match-p with-open-stream + file-author pathname-name with-output-to-string + file-error pathname-type with-package-iterator + file-error-pathname pathname-version with-simple-restart + file-length pathnamep with-slots + file-namestring peek-char with-standard-io-syntax + file-position phase write + file-stream pi write-byte + file-string-length plusp write-char + file-write-date pop write-line + fill position write-sequence + fill-pointer position-if write-string + find position-if-not write-to-string + find-all-symbols pprint y-or-n-p + find-class pprint-dispatch yes-or-no-p + find-if pprint-exit-if-list-exhausted zerop + find-if-not pprint-fill - caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - *applyhook* *load-pathname* *print-pprint-dispatch* - *break-on-signals* *load-print* *print-pprint-dispatch* - *break-on-signals* *load-truename* *print-pretty* - *break-on-warnings* *load-verbose* *print-radix* - *compile-file-pathname* *macroexpand-hook* *print-readably* - *compile-file-pathname* *modules* *print-right-margin* - *compile-file-truename* *package* *print-right-margin* - *compile-file-truename* *print-array* *query-io* - *compile-print* *print-base* *random-state* - *compile-verbose* *print-case* *read-base* - *compile-verbose* *print-circle* *read-default-float-format* - *debug-io* *print-escape* *read-eval* - *debugger-hook* *print-gensym* *read-suppress* - *default-pathname-defaults* *print-length* *readtable* - *error-output* *print-level* *standard-input* - *evalhook* *print-lines* *standard-output* - *features* *print-miser-width* *terminal-io* - *gensym-counter* *print-miser-width* *trace-output*") + *applyhook* *load-pathname* *print-pprint-dispatch* + *break-on-signals* *load-print* *print-pprint-dispatch* + *break-on-signals* *load-truename* *print-pretty* + *break-on-warnings* *load-verbose* *print-radix* + *compile-file-pathname* *macroexpand-hook* *print-readably* + *compile-file-pathname* *modules* *print-right-margin* + *compile-file-truename* *package* *print-right-margin* + *compile-file-truename* *print-array* *query-io* + *compile-print* *print-base* *random-state* + *compile-verbose* *print-case* *read-base* + *compile-verbose* *print-circle* *read-default-float-format* + *debug-io* *print-escape* *read-eval* + *debugger-hook* *print-gensym* *read-suppress* + *default-pathname-defaults* *print-length* *readtable* + *error-output* *print-level* *standard-input* + *evalhook* *print-lines* *standard-output* + *features* *print-miser-width* *terminal-io* + *gensym-counter* *print-miser-width* *trace-output*") (defparameter *txtedit-lisp-kw2* -":abort :from-end :overwrite - :adjustable :gensym :predicate - :append :host :preserve-whitespace - :array :if-does-not-exist :pretty - :base :if-exists :print - :case :include :print-function - :circle :index :probe - :conc-name :inherited :radix - :constructor :initial-contents :read-only - :copier :initial-element :rehash-size - :count :initial-offset :rehash-threshold - :create :initial-value :rename - :default :input :rename-and-delete - :defaults :internal :size - :device :io :start - :direction :junk-allowed :start1 - :directory :key :start2 - :displaced-index-offset :length :stream - :displaced-to :level :supersede - :element-type :name :test - :end :named :test-not - :end1 :new-version :type - :end2 :nicknames :use - :error :output :verbose - :escape :output-file :version - :external :fill-pointer") +":abort :from-end :overwrite + :adjustable :gensym :predicate + :append :host :preserve-whitespace + :array :if-does-not-exist :pretty + :base :if-exists :print + :case :include :print-function + :circle :index :probe + :conc-name :inherited :radix + :constructor :initial-contents :read-only + :copier :initial-element :rehash-size + :count :initial-offset :rehash-threshold + :create :initial-value :rename + :default :input :rename-and-delete + :defaults :internal :size + :device :io :start + :direction :junk-allowed :start1 + :directory :key :start2 + :displaced-index-offset :length :stream + :displaced-to :level :supersede + :element-type :name :test + :end :named :test-not + :end1 :new-version :type + :end2 :nicknames :use + :error :output :verbose + :escape :output-file :version + :external :fill-pointer") (defparameter *txtedit-decl-forms* '(defmacro defsetf deftype defun defmethod defgeneric lambda diff --git a/contrib/win32/txtedit.lisp b/contrib/win32/txtedit.lisp index 9456904..8e014a9 100644 --- a/contrib/win32/txtedit.lisp +++ b/contrib/win32/txtedit.lisp @@ -65,35 +65,35 @@ Copyright (c) 2005, Michael Goffioul.") (defun create-menus () ;(return *NULL*) (let ((bar (createmenu)) - (file_pop (createpopupmenu)) - (edit_pop (createpopupmenu)) - (win_pop (createpopupmenu)) - (help_pop (createpopupmenu))) + (file_pop (createpopupmenu)) + (edit_pop (createpopupmenu)) + (win_pop (createpopupmenu)) + (help_pop (createpopupmenu))) ;; File menu (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "&File") - (appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New Ctrl+N") - (appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open... Ctrl+O") - (appendmenu file_pop *MF_STRING* +IDM_CLOSE+ "&Close Ctrl+W") + (appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New Ctrl+N") + (appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open... Ctrl+O") + (appendmenu file_pop *MF_STRING* +IDM_CLOSE+ "&Close Ctrl+W") (appendmenu file_pop *MF_SEPARATOR* 0 "") - (appendmenu file_pop *MF_STRING* +IDM_SAVE+ "&Save Ctrl+S") + (appendmenu file_pop *MF_STRING* +IDM_SAVE+ "&Save Ctrl+S") (appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save &As...") (appendmenu file_pop *MF_SEPARATOR* 0 "") - (appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q") + (appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit Ctrl+Q") ;; Edit menu (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "&Edit") - (appendmenu edit_pop *MF_STRING* +IDM_UNDO+ "&Undo Ctrl+Z") + (appendmenu edit_pop *MF_STRING* +IDM_UNDO+ "&Undo Ctrl+Z") (appendmenu edit_pop *MF_SEPARATOR* 0 "") - (appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut Ctrl+X") - (appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C") - (appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V") + (appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut Ctrl+X") + (appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y Ctrl+C") + (appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste Ctrl+V") (appendmenu edit_pop *MF_SEPARATOR* 0 "") - (appendmenu edit_pop *MF_STRING* +IDM_MATCH_PAREN+ "&Match parenthesis Ctrl+D") + (appendmenu edit_pop *MF_STRING* +IDM_MATCH_PAREN+ "&Match parenthesis Ctrl+D") (appendmenu edit_pop *MF_SEPARATOR* 0 "") - (appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A") + (appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All Ctrl+A") ;; Windows menu (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam win_pop) "&Window") - (appendmenu win_pop *MF_STRING* +IDM_NEXTWINDOW+ "&Next Ctrl+Right") - (appendmenu win_pop *MF_STRING* +IDM_PREVWINDOW+ "&Previous Ctrl+Left") + (appendmenu win_pop *MF_STRING* +IDM_NEXTWINDOW+ "&Next Ctrl+Right") + (appendmenu win_pop *MF_STRING* +IDM_PREVWINDOW+ "&Previous Ctrl+Left") ;; Help menu (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam help_pop) "&Help") (appendmenu help_pop *MF_STRING* +IDM_ABOUT+ "&About...") @@ -101,13 +101,13 @@ Copyright (c) 2005, Michael Goffioul.") (defun create-accels () (macrolet ((add-accel (key ID accTable pos) - `(with-foreign-object (a 'ACCEL) - (setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*)) - (setf (get-slot-value a 'ACCEL 'key) ,(if (characterp key) `(char-code ,key) key)) - (setf (get-slot-value a 'ACCEL 'cmd) ,ID) - (setf (deref-array ,accTable '(* ACCEL) ,pos) a)))) + `(with-foreign-object (a 'ACCEL) + (setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*)) + (setf (get-slot-value a 'ACCEL 'key) ,(if (characterp key) `(char-code ,key) key)) + (setf (get-slot-value a 'ACCEL 'cmd) ,ID) + (setf (deref-array ,accTable '(* ACCEL) ,pos) a)))) (let* ((accTableSize (if (= *txtedit-edit-class* 2) 10 9)) - (accTable (allocate-foreign-object 'ACCEL accTableSize))) + (accTable (allocate-foreign-object 'ACCEL accTableSize))) (add-accel #\Q +IDM_QUIT+ accTable 0) (add-accel #\N +IDM_NEW+ accTable 1) (add-accel #\O +IDM_OPEN+ accTable 2) @@ -118,10 +118,10 @@ Copyright (c) 2005, Michael Goffioul.") (add-accel #\W +IDM_CLOSE+ accTable 7) (add-accel #\F +IDM_FIND+ accTable 8) (when (= *txtedit-edit-class* 2) - (add-accel #\D +IDM_MATCH_PAREN+ accTable 9)) + (add-accel #\D +IDM_MATCH_PAREN+ accTable 9)) (prog1 - (createacceleratortable accTable accTableSize) - (free-foreign-object accTable))))) + (createacceleratortable accTable accTableSize) + (free-foreign-object accTable))))) (defun update-caption (hwnd) (let ((str (tab-name (current-editor) #'identity nil))) @@ -132,8 +132,8 @@ Copyright (c) 2005, Michael Goffioul.") (defun tab-name (editor &optional (fun #'file-namestring) (final-char #\Null)) (format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]" - (and (txtedit-title editor) (funcall fun (txtedit-title editor))) - (txtedit-dirty editor) final-char)) + (and (txtedit-title editor) (funcall fun (txtedit-title editor))) + (txtedit-dirty editor) final-char)) (defun update-tab (idx) (let ((editor (nth idx *txtedit-edit*))) @@ -146,37 +146,37 @@ Copyright (c) 2005, Michael Goffioul.") (defun set-current-editor (idx hwnd &optional force-p) (when (<= 0 idx (1- (length *txtedit-edit*))) (let ((old-ed (and *txtedit-current* - (current-editor))) - (new-ed (nth idx *txtedit-edit*))) + (current-editor))) + (new-ed (nth idx *txtedit-edit*))) (unless (and (null force-p) - (eq old-ed new-ed)) - (setq *txtedit-current* idx) - (setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*)) - (setfocus (txtedit-handle new-ed)) - (when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx) - (sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0)) - (update-caption hwnd))))) + (eq old-ed new-ed)) + (setq *txtedit-current* idx) + (setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*)) + (setfocus (txtedit-handle new-ed)) + (when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx) + (sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0)) + (update-caption hwnd))))) (defun close-editor (idx hwnd) (let ((editor (nth idx *txtedit-edit*))) (if (or (null (txtedit-dirty editor)) - (and (set-current-editor idx hwnd) nil) - (let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C" - (txtedit-title editor) #\Null) - "Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*)))) - (cond ((= m-result *IDNO*) t) - ((= m-result *IDCANCEL*) nil) - ((= m-result *IDYES*) (warn "Not implemented") nil)))) + (and (set-current-editor idx hwnd) nil) + (let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C" + (txtedit-title editor) #\Null) + "Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*)))) + (cond ((= m-result *IDNO*) t) + ((= m-result *IDCANCEL*) nil) + ((= m-result *IDYES*) (warn "Not implemented") nil)))) (progn - (destroywindow (txtedit-handle editor)) - (sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0) - (setq *txtedit-edit* (remove editor *txtedit-edit*)) - (when *txtedit-edit* - (set-current-editor (min (1- (length *txtedit-edit*)) - (max *txtedit-current* - 0)) - hwnd t)) - t) + (destroywindow (txtedit-handle editor)) + (sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0) + (setq *txtedit-edit* (remove editor *txtedit-edit*)) + (when *txtedit-edit* + (set-current-editor (min (1- (length *txtedit-edit*)) + (max *txtedit-current* + 0)) + hwnd t)) + t) nil))) (ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int)) @@ -214,7 +214,7 @@ Copyright (c) 2005, Michael Goffioul.") (unless (boundp '*txtedit-lisp-kw*) (load "lisp-kw.lisp")) (with-foreign-strings ((kwList *txtedit-lisp-kw*) - (kwList2 *txtedit-lisp-kw2*)) + (kwList2 *txtedit-lisp-kw2*)) (sendmessage hnd 4005 0 (make-lparam kwList)) (sendmessage hnd 4005 1 (make-lparam kwList2))) ;; Define margins @@ -228,21 +228,21 @@ Copyright (c) 2005, Michael Goffioul.") (defun scintilla-indent-position (pos line hnd) (+ (sendmessage hnd 2127 line 0) (- pos - (sendmessage hnd 2128 line 0)))) + (sendmessage hnd 2128 line 0)))) (defun scintilla-read-form (pos hnd) (read-from-string (with-output-to-string (s) (loop for k from pos - with style = (sendmessage hnd 2010 pos 0) - for ch = (code-char (sendmessage hnd 2007 k 0)) - for st = (sendmessage hnd 2010 k 0) - if (and (= st style) - (graphic-char-p ch) - (not (eq ch #\Space))) - do (write-char ch s) - else - return nil)) + with style = (sendmessage hnd 2010 pos 0) + for ch = (code-char (sendmessage hnd 2007 k 0)) + for st = (sendmessage hnd 2010 k 0) + if (and (= st style) + (graphic-char-p ch) + (not (eq ch #\Space))) + do (write-char ch s) + else + return nil)) nil nil)) (defun scintilla-declare-form-p (form) @@ -250,73 +250,73 @@ Copyright (c) 2005, Michael Goffioul.") (defun scintilla-compute-indentation (curPos curLine hnd) (loop for k from curPos downto 0 - for ch = (code-char (sendmessage hnd 2007 k 0)) - for st = (sendmessage hnd 2010 k 0) - with depth = 0 - with lineIndent = 0 - with lastCharPos = nil - with prevCharPos = nil - when (= st 10) - do (cond ((and (= depth 0) (eq ch #\()) - (if lastCharPos - (let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0))) - lastForm) - (cond ((member lastChar (list #\( #\;)) - (return (scintilla-indent-position lastCharPos curLine hnd))) - ((and (setq lastForm (scintilla-read-form lastCharPos hnd)) - (scintilla-declare-form-p lastForm)) - (return (+ (scintilla-indent-position k curLine hnd) 2))) - ((and prevCharPos (not (eq prevCharPos lastCharPos))) - (return (scintilla-indent-position prevCharPos curLine hnd))) - (t - (return (+ (scintilla-indent-position lastCharPos curLine hnd) 1))))) - (progn - (return (+ (scintilla-indent-position k curLine hnd) 1))))) - ((eq ch #\() (decf depth)) - ((eq ch #\)) (incf depth))) - if (and (graphic-char-p ch) (not (eq ch #\Space))) - do (setq lastCharPos k) - else - do (setq prevCharPos lastCharPos) - when (eq ch #\Newline) - do (decf curLine) and - do (case lineIndent - (0 (incf lineIndent)) - (1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0))))) - finally (return -1))) + for ch = (code-char (sendmessage hnd 2007 k 0)) + for st = (sendmessage hnd 2010 k 0) + with depth = 0 + with lineIndent = 0 + with lastCharPos = nil + with prevCharPos = nil + when (= st 10) + do (cond ((and (= depth 0) (eq ch #\()) + (if lastCharPos + (let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0))) + lastForm) + (cond ((member lastChar (list #\( #\;)) + (return (scintilla-indent-position lastCharPos curLine hnd))) + ((and (setq lastForm (scintilla-read-form lastCharPos hnd)) + (scintilla-declare-form-p lastForm)) + (return (+ (scintilla-indent-position k curLine hnd) 2))) + ((and prevCharPos (not (eq prevCharPos lastCharPos))) + (return (scintilla-indent-position prevCharPos curLine hnd))) + (t + (return (+ (scintilla-indent-position lastCharPos curLine hnd) 1))))) + (progn + (return (+ (scintilla-indent-position k curLine hnd) 1))))) + ((eq ch #\() (decf depth)) + ((eq ch #\)) (incf depth))) + if (and (graphic-char-p ch) (not (eq ch #\Space))) + do (setq lastCharPos k) + else + do (setq prevCharPos lastCharPos) + when (eq ch #\Newline) + do (decf curLine) and + do (case lineIndent + (0 (incf lineIndent)) + (1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0))))) + finally (return -1))) (defun scintilla-char-added (hnd ch) (cond ((eq ch #\Newline) - (let* ((curPos (sendmessage hnd 2008 0 0)) - (curLine (sendmessage hnd 2166 curPos 0)) - (indent (scintilla-compute-indentation (1- curPos) curLine hnd))) - (when (>= indent 0) - (sendmessage hnd 2126 curLine indent) - (sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0) - ))) - ;((eq ch #\() - ; (let ((curPos (1- (sendmessage hnd 2008 0 0)))) - ; (when (scintilla-valid-brace-p curPos hnd) - ; (with-foreign-string (s ")") - ; (sendmessage hnd 2003 (1+ curPos) (make-lparam s)))))) - (t - ))) + (let* ((curPos (sendmessage hnd 2008 0 0)) + (curLine (sendmessage hnd 2166 curPos 0)) + (indent (scintilla-compute-indentation (1- curPos) curLine hnd))) + (when (>= indent 0) + (sendmessage hnd 2126 curLine indent) + (sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0) + ))) + ;((eq ch #\() + ; (let ((curPos (1- (sendmessage hnd 2008 0 0)))) + ; (when (scintilla-valid-brace-p curPos hnd) + ; (with-foreign-string (s ")") + ; (sendmessage hnd 2003 (1+ curPos) (make-lparam s)))))) + (t + ))) (defun scintilla-get-matching-braces (hnd &aux curPos) (when (>= (setq curPos (1- (sendmessage hnd 2008 0 0))) 0) (let ((ch (code-char (sendmessage hnd 2007 curPos 0)))) (when (and (or (eq ch #\() (eq ch #\))) - (= (sendmessage hnd 2010 curPos 0) 10)) - (let ((matchPos (sendmessage hnd 2353 curPos 0))) - (return-from scintilla-get-matching-braces (values curPos matchPos)))))) + (= (sendmessage hnd 2010 curPos 0) 10)) + (let ((matchPos (sendmessage hnd 2353 curPos 0))) + (return-from scintilla-get-matching-braces (values curPos matchPos)))))) (values nil nil)) (defun scintilla-check-for-brace (hnd) (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd) (if curPos (if (>= matchPos 0) - (sendmessage hnd 2351 curPos matchPos) - (sendmessage hnd 2352 curPos 0)) + (sendmessage hnd 2351 curPos matchPos) + (sendmessage hnd 2352 curPos 0)) (sendmessage hnd 2351 #xFFFFFFFF -1)))) (defun create-editor (parent &optional (set-current t)) @@ -324,38 +324,38 @@ Copyright (c) 2005, Michael Goffioul.") (getclientrect parent r) (sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r)) (let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (txtedit-class-name) "" - (logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS* - *ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*) - (get-slot-value r 'RECT 'left) - (get-slot-value r 'RECT 'top) - (- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left)) - (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top)) - *txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*)))) + (logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS* + *ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*) + (get-slot-value r 'RECT 'left) + (get-slot-value r 'RECT 'top) + (- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left)) + (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top)) + *txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*)))) (sendmessage (txtedit-handle new-editor) *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0) (case *txtedit-edit-class* - (1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*)) - (2 (init-scintilla-component (txtedit-handle new-editor)))) + (1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*)) + (2 (init-scintilla-component (txtedit-handle new-editor)))) (with-foreign-object (tab 'TCITEM) (setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*) - (setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor)) - (sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab))) + (setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor)) + (sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab))) (setq *txtedit-edit* (append *txtedit-edit* (list new-editor))) (when set-current - (set-current-editor (1- (length *txtedit-edit*)) parent)) + (set-current-editor (1- (length *txtedit-edit*)) parent)) new-editor))) (defun unix2dos (str) (let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0)) - (return-p nil) - c) + (return-p nil) + c) (with-output-to-string (out new-str) (do ((it (si::make-seq-iterator str) (si::seq-iterator-next str it))) - ((null it)) + ((null it)) (case (setq c (si::seq-iterator-ref str it)) - (#\Return (setq return-p t)) - (#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil)) - (t (setq return-p nil))) - (write-char c out))) + (#\Return (setq return-p t)) + (#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil)) + (t (setq return-p nil))) + (write-char c out))) new-str)) (defun read-file (pn hwnd) @@ -363,13 +363,13 @@ Copyright (c) 2005, Michael Goffioul.") (if pn (with-open-file (f pn) (let* ((len (file-length f)) - (buf (make-string len))) - (read-sequence buf f) - (setwindowtext (txtedit-handle (current-editor)) (unix2dos buf)) - (setf (txtedit-dirty (current-editor)) nil) - (setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn))) - (update-caption hwnd) - (update-tab *txtedit-current*))) + (buf (make-string len))) + (read-sequence buf f) + (setwindowtext (txtedit-handle (current-editor)) (unix2dos buf)) + (setf (txtedit-dirty (current-editor)) nil) + (setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn))) + (update-caption hwnd) + (update-tab *txtedit-current*))) (messagebox hwnd "File does not exist." "Error" (logior *MB_OK* *MB_ICONERROR*)))) (defun save-file (pn hwnd) @@ -390,224 +390,224 @@ Copyright (c) 2005, Michael Goffioul.") (defun tab-proc (hwnd umsg wparam lparam) (cond ((or (= umsg *WM_COMMAND*) - (= umsg *WM_NOTIFY*)) - (txtedit-proc (getparent hwnd) umsg wparam lparam)) - (t - (callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam)))) + (= umsg *WM_NOTIFY*)) + (txtedit-proc (getparent hwnd) umsg wparam lparam)) + (t + (callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam)))) (defvar *txtedit-level* 0) (defun txtedit-proc (hwnd umsg wparam lparam &aux (*txtedit-level* (1+ *txtedit-level*))) ;(format t "txtedit-proc: ~D~%" *txtedit-level*) (cond ((= umsg *WM_DESTROY*) - (postquitmessage 0) - 0) - ((= umsg *WM_CLOSE*) - (if (do ((flag t)) - ((not (and *txtedit-edit* flag)) flag) - (setq flag (close-editor 0 hwnd))) - (destroywindow hwnd) - 0)) - ((= umsg *WM_CREATE*) - (when (null-pointer-p (getmodulehandle "comctl32")) - (initcommoncontrols)) - (setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* "" - (logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0 - hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*)) - (setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc)) - (sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) - (create-editor hwnd) - (with-cast-int-pointer (lparam CREATESTRUCT) - (let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams))) - (unless (null-pointer-p params) - (read-file (convert-from-foreign-string params) hwnd)))) - 0) - ((= umsg *WM_SIZE*) - (unless (null-pointer-p *txtedit-tab*) - (movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*) - (with-foreign-object (r 'RECT) - (setrect r 0 0 (loword lparam) (hiword lparam)) - (sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r)) - (dotimes (k (length *txtedit-edit*)) - (movewindow (txtedit-handle (nth k *txtedit-edit*)) - (get-slot-value r 'RECT 'left) (get-slot-value r 'RECT 'top) - (- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left)) - (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top)) - (if (= k *txtedit-current*) *TRUE* *FALSE*))))) - 0) - ((= umsg *WM_SETFOCUS*) - (unless (null-pointer-p (txtedit-handle (current-editor))) - (setfocus (txtedit-handle (current-editor)))) - 0) - ((= umsg *WM_NOTIFY*) - (with-cast-int-pointer (lparam NMHDR) - (let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom)) - (code (get-slot-value lparam 'NMHDR 'code)) - (hnd (get-slot-value lparam 'NMHDR 'hwndFrom))) - (cond ((= ctrl-ID +TABCTL_ID+) - (cond ((= code *TCN_SELCHANGE*) - (set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd)) - (t - ))) - ((and (= *txtedit-edit-class* 2) - (= code 2001)) - (with-cast-pointer (lparam SCNotification) - (scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch))))) - ((and (= *txtedit-edit-class* 2) - (= code 2007)) - (scintilla-check-for-brace hnd)) - (t - )))) - 0) - ((= umsg *WM_CONTEXTMENU*) - (let ((hnd (make-handle wparam)) - (x (get-x-lparam lparam)) - (y (get-y-lparam lparam))) - (cond ((equal hnd *txtedit-tab*) - (with-foreign-objects ((ht 'TCHITTESTINFO) - (pt 'POINT)) - (setf (get-slot-value pt 'POINT 'x) x) - (setf (get-slot-value pt 'POINT 'y) y) - (screentoclient *txtedit-tab* pt) - (setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt) - (let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht)))) - (when (>= tab 0) - (let ((hMenu (createpopupmenu)) - menu-ID) - (appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close") - (when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0) - (close-or-exit tab hwnd)) - (destroymenu hMenu)))))))) - 0) - ((= umsg *WM_INITMENUPOPUP*) - (case (loword lparam) - (2 (let* ((wMenu (make-handle wparam)) - (nPos (loword lparam)) - (nItems (getmenuitemcount wMenu))) - (dotimes (j (- nItems 2)) - (deletemenu wMenu 2 *MF_BYPOSITION*)) - (when *txtedit-edit* - (appendmenu wMenu *MF_SEPARATOR* 0 "") - (loop for e in *txtedit-edit* - for k from 0 - do (progn - (appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e)) - (when (= k *txtedit-current*) - (checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*)))))) - (enablemenuitem wMenu +IDM_PREVWINDOW+ (if (= *txtedit-current* 0) *MF_GRAYED* *MF_ENABLED*)) - (enablemenuitem wMenu +IDM_NEXTWINDOW+ (if (< *txtedit-current* (1- (length *txtedit-edit*))) *MF_ENABLED* *MF_GRAYED*)) - )) - ) - 0) - ((= umsg *WM_COMMAND*) - (let ((ctrl-ID (loword wparam)) - (nmsg (hiword wparam)) - (hnd (make-pointer lparam 'HANDLE))) - (cond ((= ctrl-ID +EDITCTL_ID+) - (cond ((= nmsg *EN_CHANGE*) - (unless (txtedit-dirty (current-editor)) - (setf (txtedit-dirty (current-editor)) t) - (update-caption hwnd) - (update-tab *txtedit-current*))) - (t - ))) - ((= ctrl-ID +IDM_QUIT+) - (sendmessage hwnd *WM_CLOSE* 0 0)) - ((= ctrl-ID +IDM_OPEN+) - (let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp") - ("All Files (*)" . "*"))))) - (when pn - (create-editor hwnd) - (read-file pn hwnd)))) - ((and (= ctrl-ID +IDM_SAVE+) - (txtedit-title (current-editor))) - (save-file nil hwnd)) - ((or (= ctrl-ID +IDM_SAVEAS+) - (and (= ctrl-ID +IDM_SAVE+) - (null (txtedit-title (current-editor))))) - (let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp") - ("All Files (*)" . "*")) - :dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*))) - (when pn - (save-file pn hwnd)))) - ((= ctrl-ID +IDM_NEW+) - (create-editor hwnd)) - ((= ctrl-ID +IDM_CUT+) - (sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0)) - ((= ctrl-ID +IDM_COPY+) - (sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0)) - ((= ctrl-ID +IDM_PASTE+) - (sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0)) - ((= ctrl-ID +IDM_UNDO+) - (unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0) - (sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0))) - ((= ctrl-ID +IDM_SELECTALL+) - (sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1)) - ((= ctrl-ID +IDM_ABOUT+) - (messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*))) - ((= ctrl-ID +IDM_NEXTWINDOW+) - (unless (>= (1+ *txtedit-current*) (length *txtedit-edit*)) - (set-current-editor (1+ *txtedit-current*) hwnd))) - ((= ctrl-ID +IDM_PREVWINDOW+) - (unless (= *txtedit-current* 0) - (set-current-editor (1- *txtedit-current*) hwnd))) - ((= ctrl-ID +IDM_CLOSE+) - (close-or-exit *txtedit-current* hwnd)) - ((= ctrl-ID +IDM_MATCH_PAREN+) - (let ((hnd (txtedit-handle (current-editor)))) - (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd) - (when (and curPos (>= matchPos 0)) - (sendmessage hnd 2025 (1+ matchPos) 0))))) - ((= ctrl-ID +IDM_FIND+) - (let* ((fr (allocate-foreign-object 'FINDREPLACE)) - (str (make-string 1024 :initial-element #\Null))) - (zeromemory fr (size-of-foreign-type 'FINDREPLACE)) - (setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE)) - (setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd) - (setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str) - (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024) - (setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*) - (setq *txtedit-dlg-handle* (findtext fr)))) - ((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+) - (set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd) - 0) - (t - ))) - 0) - ((= uMsg (1+ *WM_USER*)) - (print "Open file request received") - (let ((fname (pop *txtedit-files*))) - (when fname - (create-editor hwnd) - (read-file fname hwnd))) - 0) - ((= uMsg *txtedit-findreplace-msg*) - (with-cast-int-pointer (lparam FINDREPLACE) - (let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags)) - (hnd (txtedit-handle (current-editor)))) - (cond ((/= 0 (logand flags *FR_DIALOGTERM*)) - (free-foreign-object lparam) - (setq *txtedit-dlg-handle* *NULL*)) - ((/= 0 (logand flags *FR_FINDNEXT*)) - (let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat)) - pos - (down (/= (logand flags *FR_DOWN*) 0))) - (cond ((= *txtedit-edit-class* 2) - (let ((selStart (sendmessage hnd 2143 0 0)) - (selEnd (sendmessage hnd 2145 0 0))) - (sendmessage hnd 2025 (if down selEnd selStart) 0) - (sendmessage hnd 2366 0 0) - (with-foreign-string (s str) - (if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1) - (sendmessage hnd 2169 0 0) - (progn - (messagebox *txtedit-dlg-handle* "Finished searching the document" - "Find" (logior *MB_OK* *MB_ICONINFORMATION*)) - (sendmessage hnd 2160 selStart selEnd)))))) - ))) - ))) - 0) - (t - (defwindowproc hwnd umsg wparam lparam)) + (postquitmessage 0) + 0) + ((= umsg *WM_CLOSE*) + (if (do ((flag t)) + ((not (and *txtedit-edit* flag)) flag) + (setq flag (close-editor 0 hwnd))) + (destroywindow hwnd) + 0)) + ((= umsg *WM_CREATE*) + (when (null-pointer-p (getmodulehandle "comctl32")) + (initcommoncontrols)) + (setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* "" + (logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0 + hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*)) + (setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc)) + (sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) + (create-editor hwnd) + (with-cast-int-pointer (lparam CREATESTRUCT) + (let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams))) + (unless (null-pointer-p params) + (read-file (convert-from-foreign-string params) hwnd)))) + 0) + ((= umsg *WM_SIZE*) + (unless (null-pointer-p *txtedit-tab*) + (movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*) + (with-foreign-object (r 'RECT) + (setrect r 0 0 (loword lparam) (hiword lparam)) + (sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r)) + (dotimes (k (length *txtedit-edit*)) + (movewindow (txtedit-handle (nth k *txtedit-edit*)) + (get-slot-value r 'RECT 'left) (get-slot-value r 'RECT 'top) + (- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left)) + (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top)) + (if (= k *txtedit-current*) *TRUE* *FALSE*))))) + 0) + ((= umsg *WM_SETFOCUS*) + (unless (null-pointer-p (txtedit-handle (current-editor))) + (setfocus (txtedit-handle (current-editor)))) + 0) + ((= umsg *WM_NOTIFY*) + (with-cast-int-pointer (lparam NMHDR) + (let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom)) + (code (get-slot-value lparam 'NMHDR 'code)) + (hnd (get-slot-value lparam 'NMHDR 'hwndFrom))) + (cond ((= ctrl-ID +TABCTL_ID+) + (cond ((= code *TCN_SELCHANGE*) + (set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd)) + (t + ))) + ((and (= *txtedit-edit-class* 2) + (= code 2001)) + (with-cast-pointer (lparam SCNotification) + (scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch))))) + ((and (= *txtedit-edit-class* 2) + (= code 2007)) + (scintilla-check-for-brace hnd)) + (t + )))) + 0) + ((= umsg *WM_CONTEXTMENU*) + (let ((hnd (make-handle wparam)) + (x (get-x-lparam lparam)) + (y (get-y-lparam lparam))) + (cond ((equal hnd *txtedit-tab*) + (with-foreign-objects ((ht 'TCHITTESTINFO) + (pt 'POINT)) + (setf (get-slot-value pt 'POINT 'x) x) + (setf (get-slot-value pt 'POINT 'y) y) + (screentoclient *txtedit-tab* pt) + (setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt) + (let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht)))) + (when (>= tab 0) + (let ((hMenu (createpopupmenu)) + menu-ID) + (appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close") + (when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0) + (close-or-exit tab hwnd)) + (destroymenu hMenu)))))))) + 0) + ((= umsg *WM_INITMENUPOPUP*) + (case (loword lparam) + (2 (let* ((wMenu (make-handle wparam)) + (nPos (loword lparam)) + (nItems (getmenuitemcount wMenu))) + (dotimes (j (- nItems 2)) + (deletemenu wMenu 2 *MF_BYPOSITION*)) + (when *txtedit-edit* + (appendmenu wMenu *MF_SEPARATOR* 0 "") + (loop for e in *txtedit-edit* + for k from 0 + do (progn + (appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e)) + (when (= k *txtedit-current*) + (checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*)))))) + (enablemenuitem wMenu +IDM_PREVWINDOW+ (if (= *txtedit-current* 0) *MF_GRAYED* *MF_ENABLED*)) + (enablemenuitem wMenu +IDM_NEXTWINDOW+ (if (< *txtedit-current* (1- (length *txtedit-edit*))) *MF_ENABLED* *MF_GRAYED*)) + )) + ) + 0) + ((= umsg *WM_COMMAND*) + (let ((ctrl-ID (loword wparam)) + (nmsg (hiword wparam)) + (hnd (make-pointer lparam 'HANDLE))) + (cond ((= ctrl-ID +EDITCTL_ID+) + (cond ((= nmsg *EN_CHANGE*) + (unless (txtedit-dirty (current-editor)) + (setf (txtedit-dirty (current-editor)) t) + (update-caption hwnd) + (update-tab *txtedit-current*))) + (t + ))) + ((= ctrl-ID +IDM_QUIT+) + (sendmessage hwnd *WM_CLOSE* 0 0)) + ((= ctrl-ID +IDM_OPEN+) + (let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp") + ("All Files (*)" . "*"))))) + (when pn + (create-editor hwnd) + (read-file pn hwnd)))) + ((and (= ctrl-ID +IDM_SAVE+) + (txtedit-title (current-editor))) + (save-file nil hwnd)) + ((or (= ctrl-ID +IDM_SAVEAS+) + (and (= ctrl-ID +IDM_SAVE+) + (null (txtedit-title (current-editor))))) + (let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp") + ("All Files (*)" . "*")) + :dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*))) + (when pn + (save-file pn hwnd)))) + ((= ctrl-ID +IDM_NEW+) + (create-editor hwnd)) + ((= ctrl-ID +IDM_CUT+) + (sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0)) + ((= ctrl-ID +IDM_COPY+) + (sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0)) + ((= ctrl-ID +IDM_PASTE+) + (sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0)) + ((= ctrl-ID +IDM_UNDO+) + (unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0) + (sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0))) + ((= ctrl-ID +IDM_SELECTALL+) + (sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1)) + ((= ctrl-ID +IDM_ABOUT+) + (messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*))) + ((= ctrl-ID +IDM_NEXTWINDOW+) + (unless (>= (1+ *txtedit-current*) (length *txtedit-edit*)) + (set-current-editor (1+ *txtedit-current*) hwnd))) + ((= ctrl-ID +IDM_PREVWINDOW+) + (unless (= *txtedit-current* 0) + (set-current-editor (1- *txtedit-current*) hwnd))) + ((= ctrl-ID +IDM_CLOSE+) + (close-or-exit *txtedit-current* hwnd)) + ((= ctrl-ID +IDM_MATCH_PAREN+) + (let ((hnd (txtedit-handle (current-editor)))) + (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd) + (when (and curPos (>= matchPos 0)) + (sendmessage hnd 2025 (1+ matchPos) 0))))) + ((= ctrl-ID +IDM_FIND+) + (let* ((fr (allocate-foreign-object 'FINDREPLACE)) + (str (make-string 1024 :initial-element #\Null))) + (zeromemory fr (size-of-foreign-type 'FINDREPLACE)) + (setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE)) + (setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) hwnd) + (setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str) + (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024) + (setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*) + (setq *txtedit-dlg-handle* (findtext fr)))) + ((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+) + (set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd) + 0) + (t + ))) + 0) + ((= uMsg (1+ *WM_USER*)) + (print "Open file request received") + (let ((fname (pop *txtedit-files*))) + (when fname + (create-editor hwnd) + (read-file fname hwnd))) + 0) + ((= uMsg *txtedit-findreplace-msg*) + (with-cast-int-pointer (lparam FINDREPLACE) + (let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags)) + (hnd (txtedit-handle (current-editor)))) + (cond ((/= 0 (logand flags *FR_DIALOGTERM*)) + (free-foreign-object lparam) + (setq *txtedit-dlg-handle* *NULL*)) + ((/= 0 (logand flags *FR_FINDNEXT*)) + (let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat)) + pos + (down (/= (logand flags *FR_DOWN*) 0))) + (cond ((= *txtedit-edit-class* 2) + (let ((selStart (sendmessage hnd 2143 0 0)) + (selEnd (sendmessage hnd 2145 0 0))) + (sendmessage hnd 2025 (if down selEnd selStart) 0) + (sendmessage hnd 2366 0 0) + (with-foreign-string (s str) + (if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1) + (sendmessage hnd 2169 0 0) + (progn + (messagebox *txtedit-dlg-handle* "Finished searching the document" + "Find" (logior *MB_OK* *MB_ICONINFORMATION*)) + (sendmessage hnd 2160 selStart selEnd)))))) + ))) + ))) + 0) + (t + (defwindowproc hwnd umsg wparam lparam)) )) (defun txtedit-class-name () @@ -620,16 +620,16 @@ Copyright (c) 2005, Michael Goffioul.") (unless *txtedit-class-registered* (case *txtedit-edit-class* (-1 (or (and (not (null-pointer-p (loadlibrary "SciLexer.dll"))) - (setq *txtedit-edit-class* 2)) - (and (not (null-pointer-p (loadlibrary "riched20.dll"))) - (setq *txtedit-edit-class* 1)) - (setq *txtedit-edit-class* 0))) + (setq *txtedit-edit-class* 2)) + (and (not (null-pointer-p (loadlibrary "riched20.dll"))) + (setq *txtedit-edit-class* 1)) + (setq *txtedit-edit-class* 0))) (1 (and (null-pointer-p (loadlibrary "riched20.dll")) - (error "Cannot load WIN32 library: riched20.dll"))) + (error "Cannot load WIN32 library: riched20.dll"))) (2 (and (null-pointer-p (loadlibrary "SciLexer.dll")) - (error "Cannot load WIN32 library: SciLexer.dll")))) + (error "Cannot load WIN32 library: SciLexer.dll")))) (make-wndclass "SimpleTextEditor" - :lpfnWndProc #'txtedit-proc) + :lpfnWndProc #'txtedit-proc) (setq *txtedit-class-registered* t))) (defun unregister-txtedit-class () @@ -643,15 +643,15 @@ Copyright (c) 2005, Michael Goffioul.") (defun txtedit (&optional fname &key (class -1) &aux (*txtedit-edit-class* class)) (register-txtedit-class) (let* ((fname-str (if fname - (convert-to-foreign-string (coerce fname 'simple-string)) - *NULL*)) - (w (createwindow "SimpleTextEditor" - *txtedit-default-title* - (logior *WS_OVERLAPPEDWINDOW*) - *CW_USEDEFAULT* *CW_USEDEFAULT* - *txtedit-width* *txtedit-height* - *NULL* (create-menus) *NULL* fname-str)) - (accTable (create-accels))) + (convert-to-foreign-string (coerce fname 'simple-string)) + *NULL*)) + (w (createwindow "SimpleTextEditor" + *txtedit-default-title* + (logior *WS_OVERLAPPEDWINDOW*) + *CW_USEDEFAULT* *CW_USEDEFAULT* + *txtedit-width* *txtedit-height* + *NULL* (create-menus) *NULL* fname-str)) + (accTable (create-accels))) (setq *txtedit-handle* w) (showwindow w *SW_SHOWNORMAL*) (updatewindow w) @@ -669,9 +669,9 @@ Copyright (c) 2005, Michael Goffioul.") (if (or detach-p *txtedit-process*) (if (member :threads *features*) (if *txtedit-process* - (progn - (push fname *txtedit-files*) - (postmessage *txtedit-handle* (1+ *WM_USER*) 0 0)) - #+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class))))) + (progn + (push fname *txtedit-files*) + (postmessage *txtedit-handle* (1+ *WM_USER*) 0 0)) + #+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class))))) (error "No multi-threading environment detected.")) (txtedit fname :class class))) diff --git a/contrib/win32/win32.lisp b/contrib/win32/win32.lisp index 9794c78..2997b15 100644 --- a/contrib/win32/win32.lisp +++ b/contrib/win32/win32.lisp @@ -37,291 +37,291 @@ (define-win-constant *TRUE* 1) (define-win-constant *FALSE* 0) -(define-win-constant *WM_CLOSE* #x0010) -(define-win-constant *WM_COMMAND* #x0111) -(define-win-constant *WM_CONTEXTMENU* #x007b) -(define-win-constant *WM_COPY* #x0301) -(define-win-constant *WM_CREATE* #x0001) -(define-win-constant *WM_CUT* #x0300) -(define-win-constant *WM_DESTROY* #x0002) -(define-win-constant *WM_GETFONT* #x0031) -(define-win-constant *WM_GETMINMAXINFO* #x0024) -(define-win-constant *WM_INITMENU* #x0116) -(define-win-constant *WM_INITMENUPOPUP* #x0117) -(define-win-constant *WM_NCPAINT* #x0085) -(define-win-constant *WM_NOTIFY* #x004e) -(define-win-constant *WM_PAINT* #x000f) -(define-win-constant *WM_PASTE* #x0302) -(define-win-constant *WM_QUIT* #x0012) -(define-win-constant *WM_SETFOCUS* #x0007) -(define-win-constant *WM_SETFONT* #x0030) -(define-win-constant *WM_SIZE* #x0005) -(define-win-constant *WM_UNDO* #x0304) -(define-win-constant *WM_USER* #x0400) - -(define-win-constant *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 @@ -337,9 +337,9 @@ old-proc))) (defun get-wndproc (obj) (let ((entry (or (assoc obj *wndproc-db* :test #'equal) - (assoc (getclassname obj) *wndproc-db* :test #'equal)))) + (assoc (getclassname obj) *wndproc-db* :test #'equal)))) (and entry - (cdr entry)))) + (cdr entry)))) (defcallback (wndproc-proxy :stdcall) :int ((hnd :pointer-void) (umsg :unsigned-int) (wparam :unsigned-int) (lparam :int)) (let* ((wndproc (get-wndproc hnd))) (unless wndproc @@ -395,16 +395,16 @@ (with-foreign-object (s `(:array :char ,max-length)) (let ((n (getclassname-i hnd s max-length))) (when (= n 0) - (error "Unable to get class name for ~A" hnd)) + (error "Unable to get class name for ~A" hnd)) (convert-from-foreign-string s :length n)))) (def-win32-function ("RegisterClassA" registerclass) ((lpWndClass (* WNDCLASS))) :returning :int :module "user32") (def-win32-function ("UnregisterClassA" unregisterclass) ((lpClassName :cstring) (hInstance HANDLE)) :returning :int :module "user32") (def-win32-function ("GetWindowLongA" getwindowlong) ((hWnd HANDLE) (nIndex :int)) :returning :long :module "user32") (def-win32-function ("SetWindowLongA" setwindowlong) ((hWnd HANDLE) (nIndex :int) (dwNewLong :long)) :returning :long :module "user32") (def-win32-function ("CreateWindowExA" createwindowex) ((dwExStyle :unsigned-int) (lpClassName :cstring) (lpWindowName :cstring) (dwStyle :unsigned-int) - (x :int) (y :int) (nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE) - (lpParam :pointer-void)) - :returning HANDLE :module "user32") + (x :int) (y :int) (nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE) + (lpParam :pointer-void)) + :returning HANDLE :module "user32") (defun createwindow (&rest args) (apply #'createwindowex 0 args)) (def-win32-function ("DestroyWindow" destroywindow) ((hWnd HANDLE)) :returning :int :module "user32") @@ -413,7 +413,7 @@ (def-win32-function ("RedrawWindow" redrawwindow) ((hWnd HANDLE) (lprcUpdate (* RECT)) (hrgnUpdate HANDLE) (flags :unsigned-int)) :returning :int :module "user32") (def-win32-function ("MoveWindow" movewindow) ((hWnd HANDLE) (x :int) (y :int) (nWidth :int) (nHeight :int) (bRepaint :int)) :returning :int :module "user32") (def-win32-function ("SetWindowPos" setwindowpos) ((hWnd HANDLE) (hWndInsertAfter HANDLE) (x :int) - (y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int :module "user32") + (y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int :module "user32") (def-win32-function ("BringWindowToTop" bringwindowtotop) ((hWnd HANDLE)) :returning :int :module "user32") (def-win32-function ("GetWindowTextA" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int :module "user32") (defun getwindowtext (hnd) @@ -461,9 +461,9 @@ (def-win32-function ("CheckMenuItem" checkmenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32") (def-win32-function ("EnableMenuItem" enablemenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32") (def-win32-function ("TrackPopupMenu" trackpopupmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (x :int) (y :int) - (nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32") + (nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32") (def-win32-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int) - (hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32") + (hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32") (def-win32-function ("CreateAcceleratorTableA" createacceleratortable) ((lpaccl (* ACCEL)) (cEntries :int)) :returning HANDLE :module "user32") (def-win32-function ("TranslateAcceleratorA" translateaccelerator) ((hWnd HANDLE) (hAccTable HANDLE) (lpMsg (* MSG))) :returning :int :module "user32") (def-win32-function ("DestroyAcceleratorTable" destroyacceleratortable) ((hAccTable HANDLE)) :returning :int :module "user32") @@ -472,19 +472,19 @@ (defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*) (dlgSym nil)) (with-foreign-object (msg 'MSG) (loop for bRet = (getmessage msg *NULL* 0 0) - when (= bRet 0) return bRet - if (= bRet -1) - do (error "GetMessage failed!!!") - else - do (or (and (not (null-pointer-p accelTable)) - (not (null-pointer-p accelMain)) - (/= (translateaccelerator accelMain accelTable msg) 0)) - (and dlgSym - (not (null-pointer-p (symbol-value dlgSym))) - (/= (isdialogmessage (symbol-value dlgSym) msg) 0)) - (progn - (translatemessage msg) - (dispatchmessage msg)))))) + when (= bRet 0) return bRet + if (= bRet -1) + do (error "GetMessage failed!!!") + else + do (or (and (not (null-pointer-p accelTable)) + (not (null-pointer-p accelMain)) + (/= (translateaccelerator accelMain accelTable msg) 0)) + (and dlgSym + (not (null-pointer-p (symbol-value dlgSym))) + (/= (isdialogmessage (symbol-value dlgSym) msg) 0)) + (progn + (translatemessage msg) + (dispatchmessage msg)))))) (defun y-or-no-p (&optional control &rest args) (let ((s (coerce (apply #'format nil control args) 'simple-string))) @@ -492,24 +492,24 @@ *IDYES*))) (defun get-open-filename (&key (owner *NULL*) initial-dir filter (dlgfn #'getopenfilename) - (flags 0) &aux (max-fn-size 1024)) + (flags 0) &aux (max-fn-size 1024)) (flet ((null-concat (x &optional y &aux (xx (if y x (car x))) (yy (if y y (cdr x)))) - (concatenate 'string xx (string #\Null) yy))) + (concatenate 'string xx (string #\Null) yy))) (when filter (setq filter (format nil "~A~C~C" (reduce #'null-concat (mapcar #'null-concat filter)) #\Null #\Null))) (with-foreign-object (ofn 'OPENFILENAME) (with-cstrings ((fn (make-string max-fn-size :initial-element #\Null)) - (filter filter)) + (filter filter)) (zeromemory ofn (size-of-foreign-type 'OPENFILENAME)) - (setf (get-slot-value ofn 'OPENFILENAME 'lStructSize) (size-of-foreign-type 'OPENFILENAME)) - (setf (get-slot-value ofn 'OPENFILENAME 'hwndOwner) owner) - (setf (get-slot-value ofn 'OPENFILENAME 'lpstrFile) fn) - (setf (get-slot-value ofn 'OPENFILENAME 'nMaxFile) max-fn-size) - (setf (get-slot-value ofn 'OPENFILENAME 'Flags) flags) - (when filter - (setf (get-slot-value ofn 'OPENFILENAME 'lpstrFilter) filter)) - (unless (= (funcall dlgfn ofn) 0) - (pathname (string-trim (string #\Null) fn))))))) + (setf (get-slot-value ofn 'OPENFILENAME 'lStructSize) (size-of-foreign-type 'OPENFILENAME)) + (setf (get-slot-value ofn 'OPENFILENAME 'hwndOwner) owner) + (setf (get-slot-value ofn 'OPENFILENAME 'lpstrFile) fn) + (setf (get-slot-value ofn 'OPENFILENAME 'nMaxFile) max-fn-size) + (setf (get-slot-value ofn 'OPENFILENAME 'Flags) flags) + (when filter + (setf (get-slot-value ofn 'OPENFILENAME 'lpstrFilter) filter)) + (unless (= (funcall dlgfn ofn) 0) + (pathname (string-trim (string #\Null) fn))))))) (defun find-text (&key (owner *NULL*) &aux (max-txt-size 1024)) (with-foreign-object (fr 'FINDREPLACE) @@ -520,13 +520,13 @@ (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) max-txt-size) ;(setf (get-slot-value fr 'FINDREPLACE 'Flags) 1) (let ((result (findtext fr))) - (print result) - txt)))) + (print result) + txt)))) #| (defun set-wndproc (obj fun) (let ((cb (si:make-dynamic-callback fun (read-from-string (format nil "~A-WNDPROC" (gensym))) :int '(:pointer-void :unsigned-int :unsigned-int :int))) - (old-wndproc (make-pointer (getwindowlong obj *GWL_WNDPROC*) 'HANDLE))) + (old-wndproc (make-pointer (getwindowlong obj *GWL_WNDPROC*) 'HANDLE))) (setwindowlong obj *GWL_WNDPROC* (make-lparam cb)) old-wndproc)) |# @@ -543,17 +543,17 @@ (defun button-min-size (hnd) (let ((fnt (make-pointer (sendmessage hnd *WM_GETFONT* 0 0) :pointer-void)) - (hdc (getdc hnd)) - (txt (getwindowtext hnd))) + (hdc (getdc hnd)) + (txt (getwindowtext hnd))) (unless (null-pointer-p fnt) (selectobject hdc fnt)) (with-foreign-objects ((sz 'SIZE) - (tm 'TEXTMETRIC)) + (tm 'TEXTMETRIC)) (gettextextentpoint32 hdc txt (length txt) sz) (gettextmetrics hdc tm) (releasedc hnd hdc) (list (+ (get-slot-value sz 'SIZE 'cx) 20) - (+ (get-slot-value tm 'TEXTMETRIC 'tmHeight) 10))))) + (+ (get-slot-value tm 'TEXTMETRIC 'tmHeight) 10))))) (defun get-titlebar-rect (hnd) (with-foreign-object (ti 'TITLEBARINFO) @@ -561,74 +561,74 @@ (gettitlebarinfo hnd ti) (let ((rc (get-slot-value ti 'TITLEBARINFO 'rcTitlebar))) (list (get-slot-value rc 'RECT 'left) - (get-slot-value rc 'RECT 'top) - (get-slot-value rc 'RECT 'right) - (get-slot-value rc 'RECT 'bottom))))) + (get-slot-value rc 'RECT 'top) + (get-slot-value rc 'RECT 'right) + (get-slot-value rc 'RECT 'bottom))))) (defun test-wndproc (hwnd umsg wparam lparam) (cond ((= umsg *WM_DESTROY*) - (setq hBtn nil hOk nil) - (postquitmessage 0) - 0) - ((= umsg *WM_CREATE*) - (setq hBtn (createwindowex 0 "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*) - 0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*)) - (setq hOk (createwindowex 0 "BUTTON" "Close" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*) - 0 0 50 20 hwnd (make-ID *OK_ID*) *NULL* *NULL*)) - (sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) - (sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) - 0) - ((= umsg *WM_SIZE*) - (let* ((new-w (loword lparam)) - (new-h (hiword lparam)) - (wb (- new-w 20)) - (hb (/ (- new-h 30) 2))) - (movewindow hBtn 10 10 wb hb *TRUE*) - (movewindow hOk 10 (+ 20 hb) wb hb *TRUE*)) - 0) - ((= umsg *WM_GETMINMAXINFO*) - (let* ((btn1-sz (and hBtn (button-min-size hBtn))) - (btn2-sz (and hOk (button-min-size hOk))) - #|(rc (get-titlebar-rect hWnd))|# - (titleH #|(1+ (- (fourth rc) (second rc)))|# 30)) - (when (and btn1-sz btn2-sz (> titleH 0)) - (with-foreign-object (minSz 'POINT) - (setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20)) - (setf (get-slot-value minSz 'POINT 'y) (+ (second btn1-sz) (second btn2-sz) 30 titleH)) - (with-cast-int-pointer (lparam MINMAXINFO) - (setf (get-slot-value lparam 'MINMAXINFO 'ptMinTrackSize) minSz))))) - 0) - ((= umsg *WM_COMMAND*) - (let ((n (hiword wparam)) - (id (loword wparam))) - (cond ((= n *BN_CLICKED*) - (cond ((= id *HELLO_ID*) - (format t "~&Hellow World!~%") - (get-open-filename :owner hwnd)) - ((= id *OK_ID*) - (destroywindow hwnd)))) - (t - (format t "~&Un-handled notification: ~D~%" n)))) - 0) - (t - (defwindowproc hwnd umsg wparam lparam)))) + (setq hBtn nil hOk nil) + (postquitmessage 0) + 0) + ((= umsg *WM_CREATE*) + (setq hBtn (createwindowex 0 "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*) + 0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*)) + (setq hOk (createwindowex 0 "BUTTON" "Close" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*) + 0 0 50 20 hwnd (make-ID *OK_ID*) *NULL* *NULL*)) + (sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) + (sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0) + 0) + ((= umsg *WM_SIZE*) + (let* ((new-w (loword lparam)) + (new-h (hiword lparam)) + (wb (- new-w 20)) + (hb (/ (- new-h 30) 2))) + (movewindow hBtn 10 10 wb hb *TRUE*) + (movewindow hOk 10 (+ 20 hb) wb hb *TRUE*)) + 0) + ((= umsg *WM_GETMINMAXINFO*) + (let* ((btn1-sz (and hBtn (button-min-size hBtn))) + (btn2-sz (and hOk (button-min-size hOk))) + #|(rc (get-titlebar-rect hWnd))|# + (titleH #|(1+ (- (fourth rc) (second rc)))|# 30)) + (when (and btn1-sz btn2-sz (> titleH 0)) + (with-foreign-object (minSz 'POINT) + (setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20)) + (setf (get-slot-value minSz 'POINT 'y) (+ (second btn1-sz) (second btn2-sz) 30 titleH)) + (with-cast-int-pointer (lparam MINMAXINFO) + (setf (get-slot-value lparam 'MINMAXINFO 'ptMinTrackSize) minSz))))) + 0) + ((= umsg *WM_COMMAND*) + (let ((n (hiword wparam)) + (id (loword wparam))) + (cond ((= n *BN_CLICKED*) + (cond ((= id *HELLO_ID*) + (format t "~&Hellow World!~%") + (get-open-filename :owner hwnd)) + ((= id *OK_ID*) + (destroywindow hwnd)))) + (t + (format t "~&Un-handled notification: ~D~%" n)))) + 0) + (t + (defwindowproc hwnd umsg wparam lparam)))) (defun do-test () (make-wndclass "MyClass" :lpfnWndProc #'test-wndproc) (let* ((hwnd (createwindowex - 0 - "MyClass" - "ECL/Win32 test" - *WS_OVERLAPPEDWINDOW* - *CW_USEDEFAULT* - *CW_USEDEFAULT* - 130 - 120 - *NULL* - *NULL* - *NULL* - *NULL*))) + 0 + "MyClass" + "ECL/Win32 test" + *WS_OVERLAPPEDWINDOW* + *CW_USEDEFAULT* + *CW_USEDEFAULT* + 130 + 120 + *NULL* + *NULL* + *NULL* + *NULL*))) (when (si::null-pointer-p hwnd) (error "Unable to create window")) (showwindow hwnd *SW_SHOWNORMAL*) diff --git a/examples/asdf/readme.lisp b/examples/asdf/readme.lisp index aea2e29..a48e882 100644 --- a/examples/asdf/readme.lisp +++ b/examples/asdf/readme.lisp @@ -92,5 +92,5 @@ Executing standalone file 'example' ;;; (mapc #'delete-file (append (directory "*.o") - (directory "*.obj") - (directory "example-mono*"))) + (directory "*.obj") + (directory "example-mono*"))) diff --git a/examples/build/hello.lisp b/examples/build/hello.lisp index 02223f5..c54dddd 100644 --- a/examples/build/hello.lisp +++ b/examples/build/hello.lisp @@ -5,7 +5,7 @@ ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; -;;; See file '../Copyright' for full details. +;;; See file '../Copyright' for full details. (ffi::clines "extern const char *hello_string;") diff --git a/examples/build/hello_aux.c b/examples/build/hello_aux.c index 0e2fd65..5f3206b 100644 --- a/examples/build/hello_aux.c +++ b/examples/build/hello_aux.c @@ -5,7 +5,7 @@ * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * - * See file '../Copyright' for full details. + * See file '../Copyright' for full details. */ const char *hello_string = "Hello world!"; diff --git a/examples/build/readme.lisp b/examples/build/readme.lisp index 0d5890e..396c3c5 100644 --- a/examples/build/readme.lisp +++ b/examples/build/readme.lisp @@ -5,7 +5,7 @@ ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; -;;; See file '../Copyright' for full details. +;;; See file '../Copyright' for full details. ;;; ;;; DESCRIPTION: @@ -14,15 +14,15 @@ ;;; file called hello_aux.c. Both hello.lisp and hello_aux.c are ;;; compiled and linked into either ;;; -;;; 1) a FASL file (see build_fasl.lisp) -;;; 2) a shared library (see build_dll.lisp) -;;; 3) or a standalone executable file. (build_exe.lisp) +;;; 1) a FASL file (see build_fasl.lisp) +;;; 2) a shared library (see build_dll.lisp) +;;; 3) or a standalone executable file. (build_exe.lisp) ;;; ;;; USE: ;;; ;;; Launch a copy of ECL and load this file in it ;;; -;;; (load "readme.lisp") +;;; (load "readme.lisp") ;;; (format t " @@ -46,10 +46,10 @@ (defconstant +compound-fasl+ (compile-file-pathname "compound" :type :fasl)) (c::build-fasl +compound-fasl+ - :lisp-files - (list (compile-file-pathname "hello.lisp" :type :object)) - :ld-flags - (list (namestring (compile-file-pathname "hello_aux.c" :type :object)))) + :lisp-files + (list (compile-file-pathname "hello.lisp" :type :object)) + :ld-flags + (list (namestring (compile-file-pathname "hello_aux.c" :type :object)))) ;;; ;;; * We load both files @@ -73,12 +73,12 @@ (defconstant +standalone-exe+ (compile-file-pathname "standalone" :type :program)) (c::build-program +standalone-exe+ - :lisp-files - (list (compile-file-pathname "hello.lisp" :type :object)) - :ld-flags - (list (namestring (compile-file-pathname "hello_aux.c" :type :object))) - :epilogue-code - '(si::quit)) + :lisp-files + (list (compile-file-pathname "hello.lisp" :type :object)) + :ld-flags + (list (namestring (compile-file-pathname "hello_aux.c" :type :object))) + :epilogue-code + '(si::quit)) ;; ;; * Test the program diff --git a/examples/threads/import/import.c b/examples/threads/import/import.c index 1c5cea4..ff67407 100644 --- a/examples/threads/import/import.c +++ b/examples/threads/import/import.c @@ -18,13 +18,13 @@ #include /* - * GOAL: To execute lisp code from threads which have not - * been generated by our lisp environment. + * GOAL: To execute lisp code from threads which have not + * been generated by our lisp environment. * - * ASSUMES: ECL has been configured with threads (--enable-threads) - * and installed somewhere on the path. + * ASSUMES: ECL has been configured with threads (--enable-threads) + * and installed somewhere on the path. * - * COMPILE: Run "make" from the command line. + * COMPILE: Run "make" from the command line. * * * When this example is compiled and run, it generates a number of @@ -51,70 +51,70 @@ static void * thread_entry_point(void *data) { - cl_object form = (cl_object)data; - - /* - * 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 , 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 , 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; } diff --git a/examples/threads/import_win32/import.c b/examples/threads/import_win32/import.c index f08fd2f..e8af4cc 100644 --- a/examples/threads/import_win32/import.c +++ b/examples/threads/import_win32/import.c @@ -20,13 +20,13 @@ #endif /* - * GOAL: To execute lisp code from threads which have not - * been generated by our lisp environment. + * GOAL: To execute lisp code from threads which have not + * been generated by our lisp environment. * - * ASSUMES: ECL has been configured with threads (--enable-threads) - * and installed somewhere on the path. + * ASSUMES: ECL has been configured with threads (--enable-threads) + * and installed somewhere on the path. * - * COMPILE: Run "make" from the command line. + * COMPILE: Run "make" from the command line. * * * When this example is compiled and run, it generates a number of diff --git a/src/clx/excldep.c b/src/clx/excldep.c index c6fe25c..a6a834d 100644 --- a/src/clx/excldep.c +++ b/src/clx/excldep.c @@ -19,7 +19,7 @@ #define SUCCESS 1 #ifdef FD_SETSIZE -#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ +#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ #else #define NUMBER_OF_FDS 32 #endif @@ -45,8 +45,8 @@ int fd_wait_for_input(fd, timeout) int checkfds[CHECKLEN]; if (fd < 0 || fd >= NUMBER_OF_FDS) { - fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); - fflush(stderr); + fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); + fflush(stderr); } for (i = 0; i < CHECKLEN; i++) @@ -54,18 +54,18 @@ int fd_wait_for_input(fd, timeout) checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); if (timeout) { - timer.tv_sec = timeout; - timer.tv_usec = 0; - i = select(32, checkfds, (int *)0, (int *)0, &timer); + timer.tv_sec = timeout; + timer.tv_usec = 0; + i = select(32, checkfds, (int *)0, (int *)0, &timer); } else i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); if (i < 0) /* error condition */ if (errno == EINTR) - return (INTERRUPT); + return (INTERRUPT); else - return (ERROR); + return (ERROR); else if (i == 0) return (TIMEOUT); else