- cmucl-cvs - mailman3.common-lisp.net

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-14-g0653c41
by Raymond Toy 28 May '12

28 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 0653c4136d09939153698e149b55f493a42b349a (commit) via 4ffd5ed1ea819525878370bc988cd46386b8c1b2 (commit) via 7514638ff9ecc8d1f61c425feea45edf125d9e62 (commit) via fbced7f5db441d632c6ceb8eb53f598e0588551b (commit) via 38b90775ff86c404a507fda46eda01dc9bb2adab (commit) via 4bbfd80236161221c3271734cea742f11b25e334 (commit) via 9a2c833786572d84ca98de5e938e5ac4c42b4618 (commit) via 164dd1e02ab53a665e561b5e0a2369f19f73c3b0 (commit) from afd3451aeb9bb26e076e235c502c5b1a106081cf (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 0653c4136d09939153698e149b55f493a42b349a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon May 28 15:49:32 2012 -0700 Update with new :FILE-ATTRIBUTE external format, contributed by Douglas Crosher. diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index af8619d..f176b8b 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -28,6 +28,10 @@ New in this release: double-float) numbers. Utility functions are provided to set and access these packed numbers. * Added external format for EUC-KR. + * Added new external format, :FILE-ATTRIBUTE, which looks for an + emacs mode-line to determine the encoding to use for reading a + file. The end-of-line sequence is also determined from reading + the file. * Changes * ASDF2 updated to version 2.21. @@ -50,6 +54,11 @@ New in this release: enabling a trap when the current exception also listed that trap caused the exception to be immediately signaled. This no longer happens and now matches how ppc and sparc behave. + * The default external-format for COMPILE-FILE and LOAD is now + given by *DEFAULT-SOURCE-EXTERNAL-FORMAT*, instead of + *DEFAULT-EXTERNAL-FORMAT*. However, the default value of + *DEFAULT-SOURCE-EXTERNAL-FORMAT* is :DEFAULT, which means the + value of *DEFAULT-EXTERNAL-FORMAT* will be used. * ANSI compliance fixes: * CMUCL was not printing pathnames like (make-pathname :directory @@ -82,6 +91,10 @@ New in this release: * EXPORT and friends should not EVAL the form when compiling. This was probably a leftover from the time when CMUCL did not have DEFPACKAGE. (See ticket:60.) + * The debugger was not always opening the file in the correct + external format. It defaulted to using + *DEFAULT-EXTERNAL-FORMAT* instead of the format used when + compiling the file. * Trac Tickets: * #50: Print/read error with make-pathname. commit 4ffd5ed1ea819525878370bc988cd46386b8c1b2 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon May 28 09:47:36 2012 -0700 Remove extra closing parenthesis. diff --git a/src/tools/hemcom.lisp b/src/tools/hemcom.lisp index 949f3e0..c841aae 100644 --- a/src/tools/hemcom.lisp +++ b/src/tools/hemcom.lisp @@ -118,7 +118,7 @@ "WINDOW-DISPLAY-END" "WINDOW-DISPLAY-RECENTERING" "WINDOW-DISPLAY-START" "WINDOW-FONT" "WINDOW-HEIGHT" "WINDOW-POINT" "WINDOW-WIDTH" "WINDOWP" "WITH-INPUT-FROM-REGION" "WITH-MARK" "WITH-OUTPUT-TO-MARK" - "WITH-POP-UP-DISPLAY" "WITH-WRITABLE-BUFFER" "WRITE-FILE"))) + "WITH-POP-UP-DISPLAY" "WITH-WRITABLE-BUFFER" "WRITE-FILE")) (unless (find-package "HEMLOCK") (make-package "HEMLOCK" commit 7514638ff9ecc8d1f61c425feea45edf125d9e62 Merge: fbced7f afd3451 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon May 28 09:19:17 2012 -0700 Merge branch 'master' into ext-format-file-attribute commit fbced7f5db441d632c6ceb8eb53f598e0588551b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 26 11:13:01 2012 -0700 Fix so this can build on 8-bit cmucl. o Clean up reader conditionals in MAKE-FD-STREAM. o Add dummy %SET-FD-STREAM-EXTERNAL-FORMAT for non-unicode. diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 5f194a0..062a0d3 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -2136,6 +2136,12 @@ ;;;; Creation routines (MAKE-FD-STREAM and OPEN) +;; The unicode version of this is in fd-stream-extfmt.lisp +#-(and unicode (not unicode-boootstrap)) +(defun %set-fd-stream-external-format (stream extfmt &optional (updatep t)) + (declare (ignore stream extfmt updatep)) + (values)) + ;;; MAKE-FD-STREAM -- Public. ;;; ;;; Returns a FD-STREAM on the given file. @@ -2246,15 +2252,12 @@ ;; external format. ;; ;;#-unicode-bootstrap ; fails in stream-reinit otherwise - #+(and unicode (not unicode-bootstrap)) (cond ((and (eq external-format :file-attribute) input) ;; Read the encoding file option with the external-format set to ;; :iso8859-1, and then change the external-format if necessary. - #+(and unicode (not unicode-bootstrap)) (%set-fd-stream-external-format stream :iso8859-1 nil) (set-routines stream element-type input output input-buffer-p :binary-stream-p binary-stream-p) - #+(and unicode (not unicode-bootstrap)) (%set-fd-stream-external-format stream :iso8859-1 nil) (multiple-value-bind (encoding eol-mode) (stream-encoding-file-attribute stream) @@ -2271,18 +2274,14 @@ ((eq external-format :file-attribute) ;; Non-input stream, so can not read the file attributes, so use the ;; :default. - #+(and unicode (not unicode-bootstrap)) (%set-fd-stream-external-format stream :default nil) (set-routines stream element-type input output input-buffer-p :binary-stream-p binary-stream-p) - #+(and unicode (not unicode-bootstrap)) (%set-fd-stream-external-format stream :default nil)) (t - #+(and unicode (not unicode-bootstrap)) (%set-fd-stream-external-format stream external-format nil) (set-routines stream element-type input output input-buffer-p :binary-stream-p binary-stream-p) - #+(and unicode (not unicode-bootstrap)) (%set-fd-stream-external-format stream external-format nil))) stream)) commit 38b90775ff86c404a507fda46eda01dc9bb2adab Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 26 09:13:34 2012 -0700 Use concatenate instead of format because format isn't available when compiling. diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 85aa0b8..5f194a0 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1367,7 +1367,8 @@ (flet ((add-suffix (list suffix) (let ((list* nil)) (dolist (coding list) - (push (format nil "~A-~A" coding suffix) list*)) + (push (concatenate 'simple-string coding "-" suffix) + list*)) (nreverse list*)))) `((,target ,@list) ((,target :unix) ,@(add-suffix list "unix")) commit 4bbfd80236161221c3271734cea742f11b25e334 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 26 08:24:55 2012 -0700 Debugger needs to open file with the appropriate external format. Patch from Douglas. diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index a3a3dfb..014382e 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -4943,8 +4943,10 @@ The result is a symbol or nil if the routine cannot be found." (aref (or (debug-source-start-positions d-source) (error (intl:gettext "Cannot set breakpoints for editor when ~ there is no start positions map."))) - local-tlf-offset))) - (with-open-file (f name) + local-tlf-offset)) + (external-format (or (c::debug-source-info d-source) + ext:*default-source-external-format*))) + (with-open-file (f name :external-format external-format) (cond ((= (debug-source-created d-source) (file-write-date name)) (file-position f char-offset)) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 825ed0b..62bf986 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -1486,7 +1486,8 @@ See the CMU Common Lisp User's Manual for more information. (when *cached-source-stream* (close *cached-source-stream*)) (setq *cached-source-stream* (open name :if-does-not-exist nil - :external-format (or (c::debug-source-info d-source) :default))) + :external-format (or (c::debug-source-info d-source) + ext:*default-source-external-format*))) (unless *cached-source-stream* (error (intl:gettext "Source file no longer exists:~% ~A.") (namestring name))) (format t (intl:gettext "~%; File: ~A~%") (namestring name))) commit 9a2c833786572d84ca98de5e938e5ac4c42b4618 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 26 08:24:22 2012 -0700 Add all the emacs format encodings. From Douglas. diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 820c22d..85aa0b8 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1363,20 +1363,101 @@ ;;;; Utility functions (misc routines, etc) (defparameter *stream-encoding-file-attribute-translations* - '(;; Emacs specific codings. - ((:iso-8859-1 :unix) - "latin-1" "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") - ((:iso-8859-1 :dos) - "latin-1" "latin-1-dos" "iso-latin-1-dos" "iso-8859-1-dos") - ((:iso-8859-1 :max) - "latin-1" "latin-1-mac" "iso-latin-1-mac" "iso-8859-1-mac") - ((:utf-8 :unix) "utf-8-unix") - ((:utf-8 :dos) "utf-8-dos") - ((:utf-8 :mac) "utf-8-mac") - ((:euc-jp :unix) "euc-jp-unix") - ((:euc-jp :dos) "euc-jp-dos") - ((:euc-jp :mac) "euc-jp-mac") - ) + (flet ((emacs-coding (target &rest list) + (flet ((add-suffix (list suffix) + (let ((list* nil)) + (dolist (coding list) + (push (format nil "~A-~A" coding suffix) list*)) + (nreverse list*)))) + `((,target ,@list) + ((,target :unix) ,@(add-suffix list "unix")) + ((,target :dos) ,@(add-suffix list "dos")) + ((,target :mac) ,@(add-suffix list "mac")))))) + `(;; Emacs specific codings. + ,@(emacs-coding :utf-8 "utf-8" "utf-8-with-signature" "mule-utf-8") + ,@(emacs-coding :utf-16le "utf-16le" "utf-16-le") + ,@(emacs-coding :utf-16be "utf-16be" "utf-16-be") + ,@(emacs-coding :utf-16 "utf-16" "utf-16le-with-signature" "utf-16be-with-signature") + ,@(emacs-coding :us-ascii "us-ascii" "iso-safe") + ,@(emacs-coding :iso-8859-1 "iso-8859-1" "latin-1" "iso-latin-1") + ,@(emacs-coding :iso-8859-1 "binary" "no-conversion" "raw-text") + ,@(emacs-coding :iso-8859-2 "iso-8859-2" "latin-2" "iso-latin-2") + ,@(emacs-coding :iso-8859-3 "iso-8859-3" "latin-3" "iso-latin-3") + ,@(emacs-coding :iso-8859-4 "iso-8859-4" "latin-4" "iso-latin-4") + ,@(emacs-coding :iso-8859-5 "iso-8859-5" "cyrillic-iso-8bit") + ,@(emacs-coding :iso-8859-6 "iso-8859-6") + ,@(emacs-coding :iso-8859-7 "iso-8859-7" "greek-iso-8bit") + ,@(emacs-coding :iso-8859-8 "iso-8859-8" "hebrew-iso-8bit") + ,@(emacs-coding :iso-8859-9 "iso-8859-9" "latin-5" "iso-latin-5") + ,@(emacs-coding :iso-8859-10 "iso-8859-10" "latin-6" "iso-latin-6") + ,@(emacs-coding :iso-8859-11 "iso-8859-11") + ,@(emacs-coding :iso-8859-13 "iso-8859-13" "latin-7" "iso-latin-7") + ,@(emacs-coding :iso-8859-14 "iso-8859-14" "latin-8" "iso-latin-8") + ,@(emacs-coding :iso-8859-15 "iso-8859-15" "latin-9" "iso-latin-9" "latin-0") + ,@(emacs-coding :iso-8859-16 "iso-8859-16" "latin-10" "iso-latin-10") + ,@(emacs-coding :cp437 "cp437" "ibm437") + ,@(emacs-coding :cp850 "cp850" "ibm850") + ,@(emacs-coding :cp852 "cp852" "ibm852") + ,@(emacs-coding :cp857 "cp857" "ibm857") + ,@(emacs-coding :cp858 "cp858") + ,@(emacs-coding :cp860 "cp860" "ibm860") + ,@(emacs-coding :cp861 "cp861" "ibm861") + ,@(emacs-coding :cp862 "cp862" "ibm862") + ,@(emacs-coding :cp863 "cp863" "ibm863") + ,@(emacs-coding :cp865 "cp865" "ibm865") + ,@(emacs-coding :roman8 "roman8" "hp-roman8") + ,@(emacs-coding :macintosh "mac-roman") + ,@(emacs-coding :utf-7 "utf-7") + ,@(emacs-coding :cp1250 "cp1250" "windows-1250") + ,@(emacs-coding :cp1251 "cp1251" "windows-1251") + ,@(emacs-coding :cp1252 "cp1252" "windows-1252") + ,@(emacs-coding :cp1253 "cp1253" "windows-1253") + ,@(emacs-coding :cp1254 "cp1254" "windows-1254") + ,@(emacs-coding :cp1255 "cp1255" "windows-1255") + ,@(emacs-coding :cp1256 "cp1256" "windows-1256") + ,@(emacs-coding :cp1257 "cp1257" "windows-1257") + ,@(emacs-coding :cp1258 "cp1258" "windows-1258") + ,@(emacs-coding :cp851 "cp851" "ibm851") + ,@(emacs-coding :cp737 "cp737") + ,@(emacs-coding :cp869 "cp869" "ibm869") + ,@(emacs-coding :cp866 "cp866") + ,@(emacs-coding :koi8 "koi8" "koi8-r" "cyrillic-koi8" "cp878") + ,@(emacs-coding :koi8-u "koi8-u") + ,@(emacs-coding :koi8-t "koi8-t") + ,@(emacs-coding :cp1125 "cp1125" "ruscii" "cp866u") + ,@(emacs-coding :cp855 "cp855" "ibm855") + ,@(emacs-coding :mik "mik") + ,@(emacs-coding :pt154 "pt154") + ,@(emacs-coding :ebcdic-us "ebcdic-us") + ,@(emacs-coding :ebcdic-uk "ebcdic-uk") + ,@(emacs-coding :cp1047 "cp1047" "ibm1047") + ,@(emacs-coding :iso-2022-cn "iso-2022-cn" "chinese-iso-7bit") + ,@(emacs-coding :iso-2022-cn-ext "iso-2022-cn-ext") + ,@(emacs-coding :gb2312 "gb2312" "cn-gb" "euc-cn" "euc-china" + "cn-gb-2312" "chinese-iso-8bit") + ,@(emacs-coding :big5 "big5" "cp950" "cn-big5" "chinese-big5") + ,@(emacs-coding :big5hkscs "big5-hkscs" "cn-big5-hkscs" "chinese-big5-hkscs") + ,@(emacs-coding :euc-tw "euc-tw" "euc-taiwan") + ,@(emacs-coding :cp936 "cp936" "windows-936" "gbk" "chinese-gbk") + ,@(emacs-coding :gb18030 "gb18030" "chinese-gb18003") + ,@(emacs-coding :cp874 "ibm874" "cp874") + ,@(emacs-coding :tis-620 "tis-620" "tis620" "th-tis620" "thai-tis620") + ,@(emacs-coding :viscii "viscii" "vietnamese-viscii") + ,@(emacs-coding :tcvn "tcvn-5712" "tcvn" "vietnamese-tcvn") + ,@(emacs-coding :georgian-ps "georgian-ps") + ,@(emacs-coding :georgian-academy "georgian-academy") + ,@(emacs-coding :iso-2022-jp "iso-2022-jp" "junet") + ,@(emacs-coding :iso-2022-jp-2 "iso-2022-jp-2") + ,@(emacs-coding :shift-jis "shift_jis" "sjis" "japanese-shift-jis") + ,@(emacs-coding :cp932 "cp932" "japanese-cp932") + ,@(emacs-coding :euc-jp "euc-jp" "euc-japan" "euc-japan-1990" "japanese-iso-8bit") + ,@(emacs-coding :euc-ms "eucjp-ms") + ,@(emacs-coding :iso-2022-jp-3 "iso-2022-jp-3" "iso-2022-jp-2004") + ,@(emacs-coding :euc-jisx0213 "euc-jisx0213" "euc-jis-2004") + ,@(emacs-coding :euc-korea "euc-korea" "euc-kr" "korean-iso-8bit") + ,@(emacs-coding :iso-2022-kr "iso-2022-kr" "korean-iso-7bit-lock") + ,@(emacs-coding :cp949 "cp949" "korean-cp949") + )) "List of coding translations used by 'stream-encoding-file-attribute to map the read file coding into a native external-format. Each element is a list of a native external-format followed by a list of coding strings that are to be commit 164dd1e02ab53a665e561b5e0a2369f19f73c3b0 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri May 25 22:49:18 2012 -0700 First cut at :file-attribute external-format that determines the format from the file contents ala emacs. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index a46d5bb..d0cfe58 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1511,6 +1511,7 @@ "DESCRIBE-EXTERNAL-FORMAT") ;; Unicode (:export "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" + "*DEFAULT-SOURCE-EXTERNAL-FORMAT*" "DESCRIBE-EXTERNAL-FORMAT" "LIST-ALL-EXTERNAL-FORMATS" "STRING-ENCODE" "STRING-DECODE" diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 45b5847..820c22d 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1362,6 +1362,238 @@ ;;;; Utility functions (misc routines, etc) +(defparameter *stream-encoding-file-attribute-translations* + '(;; Emacs specific codings. + ((:iso-8859-1 :unix) + "latin-1" "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ((:iso-8859-1 :dos) + "latin-1" "latin-1-dos" "iso-latin-1-dos" "iso-8859-1-dos") + ((:iso-8859-1 :max) + "latin-1" "latin-1-mac" "iso-latin-1-mac" "iso-8859-1-mac") + ((:utf-8 :unix) "utf-8-unix") + ((:utf-8 :dos) "utf-8-dos") + ((:utf-8 :mac) "utf-8-mac") + ((:euc-jp :unix) "euc-jp-unix") + ((:euc-jp :dos) "euc-jp-dos") + ((:euc-jp :mac) "euc-jp-mac") + ) + "List of coding translations used by 'stream-encoding-file-attribute to map + the read file coding into a native external-format. Each element is a list of + a native external-format followed by a list of coding strings that are to be + mapped to this native format. The first element is the target encoding, + may be a list with the first element being the encoding and the second the + line termination style: :unix (linefeed), :dos (CR-LF), or :mac (CR).") + + +;;; stream-encoding-file-attribute -- Internal +;;; +;;; Read the encoding file option from the stream 's which is expected to be a +;;; character stream with an external-format of :iso8859-1. +;;; +(defun stream-encoding-file-attribute (s) + (let* ((initial-encoding nil) + (declared-encoding nil) + (eol-mode nil) + (buffer (make-array 1024 :element-type '(unsigned-byte 8))) + (available (do ((i 0 (1+ i))) + ((>= i 1024) i) + (declare (fixnum i)) + (let ((ch (read-char s nil nil))) + (unless ch (return i)) + (setf (aref buffer i) (char-code ch)))))) + (labels ((decode-ascii (start size offset) + (declare (type fixnum start) + (type (integer 1 4) size) + (type (integer 0 3) offset)) + (let ((ascii (make-array 64 :element-type 'character + :adjustable t :fill-pointer 0))) + (do () + ((< available (+ start size))) + (let* ((code (ecase size + (1 (aref buffer start)) + (2 (let ((b0 (aref buffer start)) + (b1 (aref buffer (1+ start)))) + (ecase offset + (0 (logior (ash b1 8) b0)) + (1 (logior (ash b0 8) b1))))) + (4 + (let ((b0 (aref buffer start)) + (b1 (aref buffer (+ start 1))) + (b2 (aref buffer (+ start 2))) + (b3 (aref buffer (+ start 3)))) + (ecase offset + (0 (logior (ash b3 24) (ash b2 16) (ash b1 8) b0)) + (1 (logior (ash b1 24) (ash b0 16) (ash b3 8) b2)) + (2 (logior (ash b2 24) (ash b3 16) (ash b0 8) b1)) + (3 (logior (ash b0 24) (ash b1 16) (ash b2 8) b3)))))))) + (incf start size) + (let ((ch (if (< 0 code #x80) (code-char code) #\?))) + (vector-push-extend ch ascii)))) + ascii)) + (parse-file-option (ascii) + ;; Parse the file options. + (let ((found (search "-*-" ascii)) + (options nil)) + (when found + (block do-file-options + (let* ((start (+ found 3)) + (end (search "-*-" ascii :start2 start))) + (unless end + (return-from do-file-options)) + (unless (find #\: ascii :start start :end end) + (return-from do-file-options)) + (do ((opt-start start (1+ semi)) colon semi) + (nil) + (setf colon (position #\: ascii :start opt-start :end end)) + (unless colon + (return-from do-file-options)) + (setf semi (or (position #\; ascii :start colon :end end) end)) + (let ((option (string-trim '(#\space #\tab) + (subseq ascii opt-start colon))) + (value (string-trim '(#\space #\tab) + (subseq ascii (1+ colon) semi)))) + (push (cons option value) options) + (when (= semi end) (return nil))))))) + (setf declared-encoding + (cond ((cdr (assoc "external-format" options :test 'equalp))) + ((cdr (assoc "encoding" options :test 'equalp))) + ((cdr (assoc "coding" options :test 'equalp))))))) + (detect-line-termination (ascii) + ;; Look for the first line termination and check the style. + (let ((p (position-if #'(lambda (c) (member c '(#\linefeed #\return))) + ascii))) + (when p + (let ((c1 (char ascii p))) + (cond ((char= c1 #\linefeed) + (setf eol-mode :unix)) + ((< (1+ p) (length ascii)) + (assert (char= c1 #\return)) + (let ((c2 (char ascii (1+ p)))) + (cond ((eql c2 #\linefeed) + (setf eol-mode :dos)) + (t + (setf eol-mode :mac))))))))))) + (cond ((>= available 4) + (let ((b1 (aref buffer 0)) + (b2 (aref buffer 1)) + (b3 (aref buffer 2)) + (b4 (aref buffer 3))) + (cond ((and (= b1 #x00) (= b2 #x00) (= b3 #xFE) (= b4 #xFF)) + (setf initial-encoding :ucs-4be) + (let ((ascii (decode-ascii 4 4 3))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ((and (= b1 #xff) (= b2 #xfe)) + (cond ((and (= b3 #x00) (= b4 #x00)) + (setf initial-encoding :ucs-4le) + (let ((ascii (decode-ascii 4 4 0))) + (parse-file-option ascii) + (detect-line-termination ascii))) + (t + (setf initial-encoding :utf-16) + (let ((ascii (decode-ascii 2 2 0))) + (parse-file-option ascii) + (detect-line-termination ascii))))) + ((and (= b1 #x00) (= b2 #x00) (= b3 #xFF) (= b4 #xFE)) + (let ((ascii (decode-ascii 4 4 2))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ((and (= b1 #xfe) (= b2 #xff)) + (cond ((and (= b3 #x00) (= b4 #x00)) + (let ((ascii (decode-ascii 4 4 1))) + (parse-file-option ascii) + (detect-line-termination ascii))) + (t + (setf initial-encoding :utf-16) + (let ((ascii (decode-ascii 2 2 1))) + (parse-file-option ascii) + (detect-line-termination ascii))))) + ;; + ((and (= b1 #xEF) (= b2 #xBB) (= b3 #xBF)) + (setf initial-encoding :utf-8) + (let ((ascii (decode-ascii 3 1 0))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ;; + ((and (> b1 0) (= b2 0) (= b3 0) (= b4 0)) + (setf initial-encoding :ucs-4le) + (let ((ascii (decode-ascii 0 4 0))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ((and (= b1 0) (> b2 0) (= b3 0) (= b4 0)) + (let ((ascii (decode-ascii 0 4 1))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ((and (= b1 0) (= b2 0) (> b3 0) (= b4 0)) + (let ((ascii (decode-ascii 0 4 2))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ((and (= b1 0) (= b2 0) (= b3 0) (> b4 0)) + (setf initial-encoding :ucs-4be) + (let ((ascii (decode-ascii 0 4 3))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ;; + ((and (> b1 0) (= b2 0) (> b3 0) (= b4 0)) + (setf initial-encoding :utf-16le) + (let ((ascii (decode-ascii 0 2 0))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ((and (= b1 0) (> b2 0) (= b3 0) (> b4 0)) + (setf initial-encoding :utf-16be) + (let ((ascii (decode-ascii 0 2 1))) + (parse-file-option ascii) + (detect-line-termination ascii))) + ;; + ((and (= b1 #x2B) (= b2 #x41) + (or (= b3 #x43) (= b3 #x44))) + (setf initial-encoding :utf-7) + (let ((ascii (decode-ascii 0 1 0))) + (detect-line-termination ascii))) + ((and (= b1 #x2F) (= b2 #x2B) (= b3 #x41)) + (setf initial-encoding :utf-7) + (let ((ascii (decode-ascii 0 1 0))) + (detect-line-termination ascii))) + (t + (let ((ascii (decode-ascii 0 1 0))) + (when (parse-file-option ascii) + (detect-line-termination ascii))))))) + ((= available 3) + (when (and (= (aref buffer 0) #xEF) + (= (aref buffer 1) #xBB) + (= (aref buffer 2) #xBF)) + (setf initial-encoding :utf-8))) + ((= available 2) + (let ((b1 (aref buffer 0)) + (b2 (aref buffer 1))) + (cond ((or (and (= b1 #xff) (= b2 #xfe)) + (and (= b1 #xfe) (= b2 #xff))) + (setf initial-encoding :utf-16))))))) + ;; + ;; + (cond ((and (not initial-encoding) (not declared-encoding)) + (values :default eol-mode)) + (t + (let ((encoding (or declared-encoding initial-encoding))) + (when (stringp encoding) + (setf encoding (string-upcase encoding)) + (dolist (translations *stream-encoding-file-attribute-translations*) + (when (member encoding (rest translations) :test 'equalp) + (let ((target (first translations))) + (cond ((consp target) + (setf encoding (first target)) + (setf eol-mode (second target))) + (t + (setf encoding (first translations))))) + (return)))) + (let ((external-format + (cond ((eq encoding :default) :default) + ((stringp encoding) + (intern encoding :keyword)) + (t + encoding)))) + (values external-format eol-mode))))))) + ;;; SET-ROUTINES -- internal ;;; ;;; Fill in the various routine slots for the given type. Input-p and @@ -1916,20 +2148,7 @@ (setf (fd-stream-flags stream) #b001)) (t (setf (fd-stream-flags stream) #b010))) - - ;; FIXME: setting the external format here should be better - ;; integrated into set-routines. We do it before so that - ;; set-routines can create an in-buffer if appropriate. But we - ;; need to do it after to put the correct input routines for the - ;; external format. ;; - ;;#-unicode-bootstrap ; fails in stream-reinit otherwise - #+(and unicode (not unicode-bootstrap)) - (%set-fd-stream-external-format stream external-format nil) - (set-routines stream element-type input output input-buffer-p - :binary-stream-p binary-stream-p) - #+(and unicode (not unicode-bootstrap)) - (%set-fd-stream-external-format stream external-format nil) (when (and auto-close (fboundp 'finalize)) (finalize stream #'(lambda () @@ -1937,6 +2156,52 @@ (format *terminal-io* (intl:gettext "** Closed ~A~%") name) (when original (revert-file file original))))) + ;; + ;; FIXME: setting the external format here should be better + ;; integrated into set-routines. We do it before so that + ;; set-routines can create an in-buffer if appropriate. But we + ;; need to do it after to put the correct input routines for the + ;; external format. + ;; + ;;#-unicode-bootstrap ; fails in stream-reinit otherwise + #+(and unicode (not unicode-bootstrap)) + (cond ((and (eq external-format :file-attribute) input) + ;; Read the encoding file option with the external-format set to + ;; :iso8859-1, and then change the external-format if necessary. + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream :iso8859-1 nil) + (set-routines stream element-type input output input-buffer-p + :binary-stream-p binary-stream-p) + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream :iso8859-1 nil) + (multiple-value-bind (encoding eol-mode) + (stream-encoding-file-attribute stream) + (unless (file-position stream :start) + (error (intl:gettext "The ~A external-format requires a file stream.") + external-format)) + (unless (and (member encoding '(:iso8859-1 :iso-8859-1)) + (member eol-mode '(nil :unix))) + (setf (stream-external-format stream) + (cond ((member eol-mode '(nil :unix)) + (or encoding :default)) + (t + (list (or encoding :default) eol-mode))))))) + ((eq external-format :file-attribute) + ;; Non-input stream, so can not read the file attributes, so use the + ;; :default. + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream :default nil) + (set-routines stream element-type input output input-buffer-p + :binary-stream-p binary-stream-p) + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream :default nil)) + (t + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream external-format nil) + (set-routines stream element-type input output input-buffer-p + :binary-stream-p binary-stream-p) + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream external-format nil))) stream)) diff --git a/src/code/load.lisp b/src/code/load.lisp index 832853b..89f7705 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -19,7 +19,7 @@ (in-package "EXTENSIONS") (export '(*load-if-source-newer* *load-source-types* *load-object-types* - invalid-fasl)) + invalid-fasl *default-source-external-format*)) (in-package "SYSTEM") (export '(foreign-symbol-address alternate-get-global-address)) @@ -94,6 +94,12 @@ (invalid-fasl-pathname condition) (invalid-fasl-version condition) (invalid-fasl-expected-version condition))))) + +(defvar *default-source-external-format* :default + "The external-format that 'load and 'compile-file use when given an + external-format of :default. The default value is :default which will open + the file using the 'ext:*default-external-format*") + ;;; LOAD-FRESH-LINE -- internal. ;;; @@ -523,6 +529,10 @@ defaulting. Probably only necessary if you have source files with a \"fasl\" type. + :EXTERNAL-FORMAT + The external-format to use when opening the FILENAME. The default is + :default which uses the EXT:*DEFAULT-SOURCE-EXTERNAL-FORMAT*. + The variables *LOAD-VERBOSE*, *LOAD-PRINT* and EXT:*LOAD-IF-SOURCE-NEWER* determine the defaults for the corresponding keyword arguments. These variables are also bound to the specified argument values, so specifying a @@ -604,6 +614,8 @@ (*load-pathname* pathname)) (case contents (:source + (when (eq external-format :default) + (setf external-format *default-source-external-format*)) (with-open-file (file truename :external-format external-format :direction :input :if-does-not-exist if-does-not-exist) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 544ccb0..066ff2d 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -738,12 +738,12 @@ :write-date (file-write-date x) :language :lisp)) files))) - + (when (eq external-format :default) + (setf external-format *default-source-external-format*)) (make-source-info :files file-info :current-file file-info #+unicode :external-format - #+unicode (stream::ef-name - (stream::find-external-format external-format)) + #+unicode external-format #+unicode :decoding-error #+unicode decoding-error))) diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 5b38108..bb807f4 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -9187,6 +9187,16 @@ msgid "Error reading ~S: ~A" msgstr "" #: src/code/fd-stream.lisp +msgid "" +"List of coding translations used by 'stream-encoding-file-attribute to map\n" +" the read file coding into a native external-format. Each element is a " +"list of\n" +" a native external-format followed byte a list of coding strings that are " +"to be\n" +" mapped to this native format." +msgstr "" + +#: src/code/fd-stream.lisp msgid "Could not find any input routine for ~S" msgstr "" @@ -9263,6 +9273,10 @@ msgid "** Closed ~A~%" msgstr "" #: src/code/fd-stream.lisp +msgid "The ~A external-format requires a file stream." +msgstr "" + +#: src/code/fd-stream.lisp msgid "" "This is a string that OPEN tacks on the end of a file namestring to produce\n" " a name for the :if-exists :rename-and-delete and :rename options. Also,\n" @@ -10064,6 +10078,14 @@ msgid "" msgstr "" #: src/code/load.lisp +msgid "" +"The external-format that 'load and 'compile-file use when given an\n" +" external-format of :default. The default value is :default which will " +"open\n" +" the file using the 'ext:*default-external-format*" +msgstr "" + +#: src/code/load.lisp msgid "List of free fop tables for the fasloader." msgstr "" @@ -10133,6 +10155,10 @@ msgid "" " defaulting. Probably only necessary if you have source files with a\n" " \"fasl\" type. \n" "\n" +" :EXTERNAL-FORMAT\n" +" The external-format to use when opening the FILENAME. The default is\n" +" :default which uses the EXT:*DEFAULT-SOURCE-EXTERNAL-FORMAT*.\n" +"\n" " The variables *LOAD-VERBOSE*, *LOAD-PRINT* and EXT:*LOAD-IF-SOURCE-NEWER" "*\n" " determine the defaults for the corresponding keyword arguments. These\n" ----------------------------------------------------------------------- Summary of changes: src/code/debug-int.lisp | 6 +- src/code/debug.lisp | 3 +- src/code/exports.lisp | 1 + src/code/fd-stream.lisp | 372 ++++++++++++++++++++++++++++++++++++-- src/code/load.lisp | 14 ++- src/compiler/main.lisp | 6 +- src/general-info/release-20d.txt | 13 ++ src/i18n/locale/cmucl.pot | 26 +++ src/tools/hemcom.lisp | 2 +- 9 files changed, 422 insertions(+), 21 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-6-gafd3451
by Raymond Toy 28 May '12

28 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via afd3451aeb9bb26e076e235c502c5b1a106081cf (commit) from 2970ca060d1c2677b00cec111d6e64d8c92ef42c (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit afd3451aeb9bb26e076e235c502c5b1a106081cf Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon May 28 09:18:47 2012 -0700 Update with changes. diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index 8c71e7f..af8619d 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -79,6 +79,9 @@ New in this release: * COMPILE-FILE should not signal an error when given a list for :EXTERNAL-FORMAT. Lists are needed to specify a composing external format like :DOS or :MAC. + * EXPORT and friends should not EVAL the form when compiling. + This was probably a leftover from the time when CMUCL did not + have DEFPACKAGE. (See ticket:60.) * Trac Tickets: * #50: Print/read error with make-pathname. @@ -86,6 +89,7 @@ New in this release: * #52: UNICODE-COMPLETE-NAME misses a completion. * #55: blocked signals. * #58: UTF-16 buffering problem. + * #60: compile-file and export problem * Other changes: * The layout of the cmucl directories has been changed. ----------------------------------------------------------------------- Summary of changes: src/general-info/release-20d.txt | 4 ++++ 1 files changed, 4 insertions(+), 0 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-5-g2970ca0
by Raymond Toy 28 May '12

28 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 2970ca060d1c2677b00cec111d6e64d8c92ef42c (commit) from 583fcce354c115bdba3ea1c01e2cd76da4251cc8 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 2970ca060d1c2677b00cec111d6e64d8c92ef42c Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon May 28 09:11:46 2012 -0700 Fix ticket:60 src/compiler/main.lisp: o Remove special treatment of EXPORT (and others) in the compiler. I think we only need to treat IN-PACKAGE and DEFPACKAGE specially. src/contrib/defsyste/defsystem.lisp: o Add FIND-SYSTEM to the defpackage export list for MAKE. src/tools/hemcom.lisp: o Add defpackage for hemlock-internals since export no longer has the compile-time effect. diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 544ccb0..be5f291 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1210,11 +1210,10 @@ (if (atom form) (convert-and-maybe-compile form path) (case (car form) - ((make-package shadow shadowing-import export - unexport use-package unuse-package import - old-in-package %in-package %defpackage) + ((%in-package %defpackage) (process-cold-load-form form path t)) - ((error cerror break signal) + ((error cerror break signal make-package use-package unuse-package shadow + shadowing-import export unexport import) (process-cold-load-form form path nil)) (kernel:%compiler-defstruct (convert-and-maybe-compile form path) diff --git a/src/contrib/defsystem/defsystem.lisp b/src/contrib/defsystem/defsystem.lisp index 2d7f0ea..ae23dbc 100644 --- a/src/contrib/defsystem/defsystem.lisp +++ b/src/contrib/defsystem/defsystem.lisp @@ -1035,7 +1035,10 @@ ;;; Here I add the proper defpackage for CMU #+:CMU (defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS") - (:nicknames "MK")) + (:nicknames "MK") + (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM" + "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*" + "FIND-SYSTEM")) #+:sbcl (defpackage "MAKE" (:use "COMMON-LISP") diff --git a/src/tools/hemcom.lisp b/src/tools/hemcom.lisp index ee56f5c..949f3e0 100644 --- a/src/tools/hemcom.lisp +++ b/src/tools/hemcom.lisp @@ -32,6 +32,94 @@ :nicknames '("HI") :use '("LISP" "EXTENSIONS" "SYSTEM"))) +(defpackage "HEMLOCK-INTERNALS" + (:nicknames "HI") + (:export + "*BUFFER-LIST*" "*BUFFER-NAMES*" "*CHARACTER-ATTRIBUTE-NAMES*" + "*COMMAND-NAMES*" "*CREATE-INITIAL-WINDOWS-HOOK*" "*CREATE-WINDOW-HOOK*" + "*DELETE-WINDOW-HOOK*" "*ECHO-AREA-BUFFER*" "*ECHO-AREA-STREAM*" + "*ECHO-AREA-WINDOW*" "*EDITOR-INPUT*" "*GLOBAL-VARIABLE-NAMES*" + "*INPUT-TRANSCRIPT*" "*INVOKE-HOOK*" "*KEY-EVENT-HISTORY*" + "*LAST-KEY-EVENT-TYPED*" "*LOGICAL-KEY-EVENT-NAMES*" "*MODE-NAMES*" + "*PARSE-DEFAULT*" "*PARSE-DEFAULT-STRING*" "*PARSE-HELP*" + "*PARSE-INPUT-REGION*" "*PARSE-PROMPT*" "*PARSE-STARTING-MARK*" + "*PARSE-STRING-TABLES*" "*PARSE-TYPE*" "*PARSE-VALUE-MUST-EXIST*" + "*PARSE-VERIFICATION-FUNCTION*" "*PRINT-REGION*" + "*RANDOM-TYPEOUT-BUFFERS*" "*RANDOM-TYPEOUT-HOOK*" "*REAL-EDITOR-INPUT*" + "*WINDOW-LIST*" "ABORT-RECURSIVE-EDIT" "ADD-HOOK" + "AFTER-EDITOR-INITIALIZATIONS" "BIND-KEY" "BLANK-AFTER-P" + "BLANK-BEFORE-P" "BLANK-LINE-P" "BUFFER" "BUFFER-DELETE-HOOK" + "BUFFER-END" "BUFFER-END-MARK" "BUFFER-MAJOR-MODE" "BUFFER-MINOR-MODE" + "BUFFER-MODELINE-FIELD-P" "BUFFER-MODELINE-FIELDS" "BUFFER-MODES" + "BUFFER-MODIFIED" "BUFFER-NAME" "BUFFER-PATHNAME" "BUFFER-POINT" + "BUFFER-REGION" "BUFFER-SIGNATURE" "BUFFER-START" "BUFFER-START-MARK" + "BUFFER-VARIABLES" "BUFFER-WINDOWS" "BUFFER-WRITABLE" "BUFFER-WRITE-DATE" + "BUFFERP" "CENTER-WINDOW" "CHARACTER-ATTRIBUTE" + "CHARACTER-ATTRIBUTE-DOCUMENTATION" "CHARACTER-ATTRIBUTE-HOOKS" + "CHARACTER-ATTRIBUTE-NAME" "CHARACTER-ATTRIBUTE-P" "CHARACTER-OFFSET" + "CLEAR-ECHO-AREA" "CLEAR-EDITOR-INPUT" "CLRSTRING" "COMMAND" + "COMMAND-BINDINGS" "COMMAND-CASE" "COMMAND-DOCUMENTATION" + "COMMAND-FUNCTION" "COMMAND-NAME" "COMMANDP" "COMPLETE-STRING" + "COPY-MARK" "COPY-REGION" "COUNT-CHARACTERS" "COUNT-LINES" + "CURRENT-BUFFER" "CURRENT-POINT" "CURRENT-VARIABLE-TABLES" + "CURRENT-WINDOW" "CURSORPOS-TO-MARK" "DEFATTRIBUTE" "DEFAULT-FONT" + "DEFCOMMAND" "DEFHVAR" "DEFINE-LOGICAL-KEY-EVENT" "DEFINE-TTY-FONT" + "DEFMODE" "DELETE-AND-SAVE-REGION" "DELETE-BUFFER" "DELETE-CHARACTERS" + "DELETE-FONT-MARK" "DELETE-KEY-BINDING" "DELETE-LINE-FONT-MARKS" + "DELETE-MARK" "DELETE-REGION" "DELETE-STRING" "DELETE-VARIABLE" + "DELETE-WINDOW" "DIRECTORYP" "DISPLAYED-P" "DO-ALPHA-CHARS" "DO-STRINGS" + "EDITOR-DESCRIBE-FUNCTION" "EDITOR-ERROR" "EDITOR-ERROR-FORMAT-ARGUMENTS" + "EDITOR-ERROR-FORMAT-STRING" "EDITOR-FINISH-OUTPUT" "EDITOR-SLEEP" + "EMPTY-LINE-P" "END-LINE-P" "ENTER-WINDOW-AUTORAISE" "EXIT-HEMLOCK" + "EXIT-RECURSIVE-EDIT" "FETCH-CUT-STRING" "FILTER-REGION" "FIND-AMBIGUOUS" + "FIND-ATTRIBUTE" "FIND-CONTAINING" "FIND-PATTERN" "FIRST-LINE-P" + "FONT-MARK" "FUN-DEFINED-FROM-PATHNAME" "GET-COMMAND" "GET-KEY-EVENT" + "GETSTRING" "HANDLE-LISP-ERRORS" "HEMLOCK-BOUND-P" + "HEMLOCK-OUTPUT-STREAM" "HEMLOCK-OUTPUT-STREAM-P" "HEMLOCK-REGION-STREAM" + "HEMLOCK-REGION-STREAM-P" "HLET" "IN-RECURSIVE-EDIT" "INPUT-WAITING" + "INSERT-CHARACTER" "INSERT-REGION" "INSERT-STRING" "INVOKE-HOOK" + "KEY-TRANSLATION" "LAST-COMMAND-TYPE" "LAST-KEY-EVENT-CURSORPOS" + "LAST-LINE-P" "LINE" "LINE-BUFFER" "LINE-CHARACTER" "LINE-END" + "LINE-LENGTH" "LINE-NEXT" "LINE-OFFSET" "LINE-PLIST" "LINE-PREVIOUS" + "LINE-SIGNATURE" "LINE-START" "LINE-STRING" "LINE-TO-REGION" "LINE<" + "LINE<=" "LINE>" "LINE>=" "LINEP" "LINES-RELATED" "LISTEN-EDITOR-INPUT" + "LOGICAL-KEY-EVENT-DOCUMENTATION" "LOGICAL-KEY-EVENT-KEY-EVENTS" + "LOGICAL-KEY-EVENT-NAME" "LOGICAL-KEY-EVENT-P" "LOUD-MESSAGE" + "MAKE-BUFFER" "MAKE-COMMAND" "MAKE-EMPTY-REGION" + "MAKE-HEMLOCK-OUTPUT-STREAM" "MAKE-HEMLOCK-REGION-STREAM" + "MAKE-KBDMAC-STREAM" "MAKE-MODELINE-FIELD" "MAKE-RING" + "MAKE-STRING-TABLE" "MAKE-WINDOW" "MAKE-XWINDOW-LIKE-HWINDOW" + "MAP-BINDINGS" "MARK" "MARK-AFTER" "MARK-BEFORE" "MARK-CHARPOS" + "MARK-COLUMN" "MARK-KIND" "MARK-LINE" "MARK-TO-CURSORPOS" "MARK/=" + "MARK<" "MARK<=" "MARK=" "MARK>" "MARK>=" "MARKP" + "MERGE-RELATIVE-PATHNAMES" "MESSAGE" "MODE-DOCUMENTATION" "MODE-MAJOR-P" + "MODE-VARIABLES" "MODELINE-FIELD" "MODELINE-FIELD-FUNCTION" + "MODELINE-FIELD-NAME" "MODELINE-FIELD-P" "MODELINE-FIELD-WIDTH" + "MODIFY-KBDMAC-STREAM" "MOVE-FONT-MARK" "MOVE-MARK" "MOVE-TO-COLUMN" + "MOVE-TO-POSITION" "NEW-SEARCH-PATTERN" "NEXT-CHARACTER" "NEXT-WINDOW" + "NINSERT-REGION" "PAUSE-HEMLOCK" "PREFIX-ARGUMENT" "PREVIOUS-CHARACTER" + "PREVIOUS-WINDOW" "PROMPT-FOR-BUFFER" "PROMPT-FOR-EXPRESSION" + "PROMPT-FOR-FILE" "PROMPT-FOR-INTEGER" "PROMPT-FOR-KEY" + "PROMPT-FOR-KEY-EVENT" "PROMPT-FOR-KEYWORD" "PROMPT-FOR-STRING" + "PROMPT-FOR-VARIABLE" "PROMPT-FOR-Y-OR-N" "PROMPT-FOR-YES-OR-NO" + "READ-FILE" "RECURSIVE-EDIT" "REDISPLAY" "REDISPLAY-ALL" "REGION" + "REGION-BOUNDS" "REGION-END" "REGION-START" "REGION-TO-STRING" "REGIONP" + "REMOVE-HOOK" "REMOVE-SCHEDULED-EVENT" "REPLACE-PATTERN" "REPROMPT" + "REVERSE-FIND-ATTRIBUTE" "RING" "RING-LENGTH" "RING-POP" "RING-PUSH" + "RING-REF" "RINGP" "ROTATE-RING" "SAME-LINE-P" "SCHEDULE-EVENT" + "SCROLL-WINDOW" "SEARCH-CHAR-CODE-LIMIT" "SEARCH-PATTERN" + "SEARCH-PATTERN-P" "SET-REGION-BOUNDS" "SETV" "SHADOW-ATTRIBUTE" + "SHOW-MARK" "START-LINE-P" "STORE-CUT-STRING" "STRING-TABLE" + "STRING-TABLE-P" "STRING-TABLE-SEPARATOR" "STRING-TO-REGION" + "STRING-TO-VARIABLE" "SYNTAX-CHAR-CODE-LIMIT" "UNGET-KEY-EVENT" + "UNSHADOW-ATTRIBUTE" "UPDATE-MODELINE-FIELD" "UPDATE-MODELINE-FIELDS" + "USE-BUFFER" "VALUE" "VARIABLE-DOCUMENTATION" "VARIABLE-HOOKS" + "VARIABLE-NAME" "VARIABLE-VALUE" "WINDOW" "WINDOW-BUFFER" + "WINDOW-DISPLAY-END" "WINDOW-DISPLAY-RECENTERING" "WINDOW-DISPLAY-START" + "WINDOW-FONT" "WINDOW-HEIGHT" "WINDOW-POINT" "WINDOW-WIDTH" "WINDOWP" + "WITH-INPUT-FROM-REGION" "WITH-MARK" "WITH-OUTPUT-TO-MARK" + "WITH-POP-UP-DISPLAY" "WITH-WRITABLE-BUFFER" "WRITE-FILE"))) + (unless (find-package "HEMLOCK") (make-package "HEMLOCK" :nicknames '("ED") ----------------------------------------------------------------------- Summary of changes: src/compiler/main.lisp | 7 +-- src/contrib/defsystem/defsystem.lisp | 5 ++- src/tools/hemcom.lisp | 88 ++++++++++++++++++++++++++++++++++ 3 files changed, 95 insertions(+), 5 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-4-g583fcce
by Raymond Toy 26 May '12

26 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 583fcce354c115bdba3ea1c01e2cd76da4251cc8 (commit) from c4ee759adf765707fba62c154315f0ed3e9036db (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 583fcce354c115bdba3ea1c01e2cd76da4251cc8 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri May 25 22:50:38 2012 -0700 * {{{COMPILE-FILE}}} should not signal an error when given a list for {{{:EXTERNAL-FORMAT}}}. Lists are needed to specify a composing external format like {{{:DOS}}} or {{{:MAC}}}. diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 6dcd544..5229915 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1153,7 +1153,7 @@ (:block-compile (member t nil :specified)) (:entry-points list) (:byte-compile (member t nil :maybe)) - (:external-format symbol) + (:external-format (or symbol list)) (:decoding-error (or null symbol function)) (:xref t)) (values (or pathname null) boolean boolean)) diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index 9dbf560..8c71e7f 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -76,6 +76,9 @@ New in this release: * Fix typo in ISO8859-2 external format that caused it not to work correctly. This type potentially also caused failures for all other external formats that were based on ISO8859-2. + * COMPILE-FILE should not signal an error when given a list for + :EXTERNAL-FORMAT. Lists are needed to specify a composing + external format like :DOS or :MAC. * Trac Tickets: * #50: Print/read error with make-pathname. ----------------------------------------------------------------------- Summary of changes: src/compiler/fndb.lisp | 2 +- src/general-info/release-20d.txt | 3 +++ 2 files changed, 4 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-3-gc4ee759
by Raymond Toy 25 May '12

25 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via c4ee759adf765707fba62c154315f0ed3e9036db (commit) from c17392f461f177128fe189fc3f3efe30f836eec3 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c4ee759adf765707fba62c154315f0ed3e9036db Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu May 24 20:27:37 2012 -0700 Clear matching current exceptions when enabling new exceptions. This prevents the exception from being resignaled immediately. src/code/float-trap.lisp: o Clear current and accrued exception bits that match any new enabled exceptions specified by :traps. src/general-info/release-20d.txt: o Update. diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index d800e14..6616146 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -155,7 +155,19 @@ currently in effect." (let ((modes (floating-point-modes))) (when traps-p - (setf (ldb float-traps-byte modes) (float-trap-mask traps))) + (let ((trap-mask-bits (float-trap-mask traps))) + (setf (ldb float-traps-byte modes) trap-mask-bits) + #+(and x86 sse2) + (progn + ;; Clear out any current or accrued exceptions that match + ;; the traps that we are enabling. If we don't then + ;; enabling the traps causes the exceptions to be signaled + ;; immediately. This is a bit annoying. If the user really + ;; wants to resignal the exceptions, he can do that himself. + (setf (ldb float-sticky-bits modes) + (logandc2 (ldb float-sticky-bits modes) trap-mask-bits)) + (setf (ldb float-exceptions-byte modes) + (logandc2 (ldb float-exceptions-byte modes) trap-mask-bits))))) (when round-p (setf (ldb float-rounding-mode modes) (or (cdr (assoc rounding-mode rounding-mode-alist)) @@ -175,6 +187,7 @@ (when (member :invalid current-exceptions) ;; Clear out the bits for the detected invalid operation (setf (ldb vm:float-invalid-op-1-byte modes) 0))) + (when fast-mode-p (if fast-mode (setq modes (logior float-fast-bit modes)) diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index 0a5c224..9dbf560 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -42,7 +42,14 @@ New in this release: * Updated to Unicode 6.1.0. * Many additional aliases for external formats added that match the glibc iconv aliases. - * Implement faster LOGCOUNT function, if :SSE3 feature is available. + * Implement faster LOGCOUNT function on x86, if :SSE3 feature is + available. (Only applies to new uses of LOGCOUNT. The core + uses the default version.) + * On x86, SET-FLOATING-POINT-MODES clears any current and accrued + exceptions that match exceptions in :TRAPS. Previously, + enabling a trap when the current exception also listed that trap + caused the exception to be immediately signaled. This no longer + happens and now matches how ppc and sparc behave. * ANSI compliance fixes: * CMUCL was not printing pathnames like (make-pathname :directory ----------------------------------------------------------------------- Summary of changes: src/code/float-trap.lisp | 15 ++++++++++++++- src/general-info/release-20d.txt | 9 ++++++++- 2 files changed, 22 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-2-gc17392f
by Raymond Toy 10 May '12

10 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via c17392f461f177128fe189fc3f3efe30f836eec3 (commit) from c4379fd583a6142446a1b07fb80da52108a9899f (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c17392f461f177128fe189fc3f3efe30f836eec3 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed May 9 23:14:00 2012 -0700 Add popcnt instruction and use it in logcount vop if :sse3 is a feature. * src/compiler/x86/arith.lisp * Add vop for logcount that uses popcnt instruction. * src/compiler/x86/insts.lisp * Define popcnt instruction (but only for :sse3) * src/general-info/release-20d.txt: * Update. diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index 69d3426..b4b43f7 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -900,6 +900,18 @@ (inst and temp #x0000ffff) (inst add result temp))) +(define-vop (sse3-unsigned-byte-32-count) + (:translate logcount) + (:note _N"inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg :from (:argument 0)) temp) + (:guard (backend-featurep :sse3)) + (:generator 2 + (inst popcnt result arg))) ;;;; Binary conditional VOPs: diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index b7dad15..e22a013 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -3091,6 +3091,17 @@ :type 'sized-xmmreg/mem) (reg :field (byte 3 27) :type 'reg)) +;;; Like ext-reg-xmm/mem, but both are registers +(disassem:define-instruction-format (ext-reg-reg/mem 32 + :default-printer + '(:name :tab reg ", " reg/mem)) + (prefix :field (byte 8 0)) + (x0f :field (byte 8 8) :value #x0f) + (op :field (byte 8 16)) + (reg/mem :fields (list (byte 2 30) (byte 3 24)) + :type 'reg/mem) + (reg :field (byte 3 27) :type 'reg)) + (disassem:define-instruction-format (ext-xmm-xmm/mem-imm 32 :include 'ext-xmm-xmm/mem @@ -3182,9 +3193,12 @@ ;; dst[63:0] = dst[63:0] ;; dst[127:64] = src[63:0] (define-regular-sse-inst unpcklpd #x66 #x14 t) - (define-regular-sse-inst unpcklps nil #x14 t) + (define-regular-sse-inst unpcklps nil #x14 t)) - ) +(define-instruction popcnt (segment dst src) + (:printer ext-reg-reg/mem + ((prefix #xf3) (op #xb8))) + (:emitter (emit-sse-inst segment dst src #xf3 #xb8))) ;;; MOVSD, MOVSS (macrolet ((define-movsd/ss-sse-inst (name prefix op) diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index 5d4bce9..0a5c224 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -42,6 +42,7 @@ New in this release: * Updated to Unicode 6.1.0. * Many additional aliases for external formats added that match the glibc iconv aliases. + * Implement faster LOGCOUNT function, if :SSE3 feature is available. * ANSI compliance fixes: * CMUCL was not printing pathnames like (make-pathname :directory ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/arith.lisp | 12 ++++++++++++ src/compiler/x86/insts.lisp | 18 ++++++++++++++++-- src/general-info/release-20d.txt | 1 + 3 files changed, 29 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-1-gc4379fd
by Raymond Toy 06 May '12

06 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via c4379fd583a6142446a1b07fb80da52108a9899f (commit) from 58af4a63cfcb6e4030b23122bde9550e9b54b8f8 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c4379fd583a6142446a1b07fb80da52108a9899f Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 5 23:33:11 2012 -0700 Link to www.cmucl.org. diff --git a/src/code/generic-site.lisp b/src/code/generic-site.lisp index e554d6d..c422621 100644 --- a/src/code/generic-site.lisp +++ b/src/code/generic-site.lisp @@ -25,7 +25,7 @@ (rplaca (cdr (member :bugs *herald-items*)) '("Send questions and bug reports to your local CMUCL maintainer, " terpri - "or see <http://www.cons.org/cmucl/support.html>." terpri + "or see <http://www.cmucl.org/support.html>." terpri "Loaded subsystems:" terpri))) ;;; If you have sources installed on your system, un-comment the following form @@ -39,6 +39,9 @@ ;;; top ;;; bin/ ;;; lib/ +;;; cmucl/ +;;; lib/ +;;; lisp*.coore ;;; man/ ;;; src/ ;;; ----------------------------------------------------------------------- Summary of changes: src/code/generic-site.lisp | 5 ++++- 1 files changed, 4 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp annotated tag snapshot-2012-05 created. snapshot-2012-05
by Raymond Toy 05 May '12

05 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2012-05 has been created at 2431a78849464d863886c5b6aaca39cf09ed3aae (tag) tagging 58af4a63cfcb6e4030b23122bde9550e9b54b8f8 (commit) replaces snapshot-2012-04 tagged by Raymond Toy on Fri May 4 19:40:29 2012 -0700 - Log ----------------------------------------------------------------- Snapshot 2012-05 Raymond Toy (16): Fix typo in external format for utf-32. Add many additional aliases to match glibc iconv aliases. Donated by Fix ticket:58. Handle the BOM character for utf-16 and utf-32. This Test for state change was wrong. UTF-16-BE and UTF-16-LE external formats were returning the incorrect Oops. Debugging print accidentally left in. Fix bug in handling the state BOM marker and also extend to work Fix some typos, change url to cmucl.org and add url to Correct the type declarations for the state (for BOM). Fix typo in iso8859-2 external format. Add some comments on what INVERT-TABLE (and GET-INVERSE) does and what First cut at an external format for EUC-KR. Handle case where we run out of octets in the middle of a two-octet Update. Update to ASDF2 2.21. Update with more info that was left out. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-04-16-g58af4a6
by Raymond Toy 01 May '12

01 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 58af4a63cfcb6e4030b23122bde9550e9b54b8f8 (commit) from 115a05e600c434fc778221384b2e5c7655ec334d (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 58af4a63cfcb6e4030b23122bde9550e9b54b8f8 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Apr 30 20:10:53 2012 -0700 Update with more info that was left out. diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index 7c1a394..5d4bce9 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -27,6 +27,7 @@ New in this release: doubles. All operations are done on top of (complex double-float) numbers. Utility functions are provided to set and access these packed numbers. + * Added external format for EUC-KR. * Changes * ASDF2 updated to version 2.21. ----------------------------------------------------------------------- Summary of changes: src/general-info/release-20d.txt | 1 + 1 files changed, 1 insertions(+), 0 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-04-15-g115a05e
by Raymond Toy 01 May '12

01 May '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 115a05e600c434fc778221384b2e5c7655ec334d (commit) via a8aae09a20417cbe7bd5b353c1ba096754cbd551 (commit) from d31743b1d345c7c43b6a00324ab400c1d00f78f8 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 115a05e600c434fc778221384b2e5c7655ec334d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Apr 30 20:08:50 2012 -0700 Update to ASDF2 2.21. diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index a95826b..b7ad1dd 100644 --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ -;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.019: Another System Definition Facility. +;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- +;;; This is ASDF 2.21: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2011 Daniel Barlow and contributors +;;; Copyright (c) 2001-2012 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -47,26 +47,33 @@ #+xcvb (module ()) -(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) +(cl:in-package :common-lisp-user) +#+genera (in-package :future-common-lisp-user) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") +;;;; Create and setup packages in a way that is compatible with hot-upgrade. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; See these two eval-when forms, and more near the end of the file. + #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this -(eval-when (:compile-toplevel :load-toplevel :execute) - ;;; Implementation-dependent tweaks +(eval-when (:load-toplevel :compile-toplevel :execute) + ;;; Before we do anything, some implementation-dependent tweaks ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below - #+ecl (unless (member :ecl-bytecmp *features*) (require :cmp)) #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all (and (= system::*gcl-major-version* 2) (< system::*gcl-minor-version* 7))) (pushnew :gcl-pre2.7 *features*)) + #+(or abcl (and allegro ics) (and clisp unicode) clozure (and cmu unicode) + (and ecl unicode) lispworks (and sbcl sb-unicode) scl) + (pushnew :asdf-unicode *features*) ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. (unless (find-package :asdf) @@ -74,11 +81,13 @@ (in-package :asdf) -;;;; Create packages in a way that is compatible with hot-upgrade. -;;;; See https://bugs.launchpad.net/asdf/+bug/485687 -;;;; See more near the end of the file. - (eval-when (:load-toplevel :compile-toplevel :execute) + ;;; This would belong amongst implementation-dependent tweaks above, + ;;; except that the defun has to be in package asdf. + #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) + + ;;; Package setup, step 2. (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. @@ -107,7 +116,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.019") + (asdf-version "2.21") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -167,6 +176,12 @@ (ensure-shadow (package symbols) (shadow symbols package)) (ensure-use (package use) + (dolist (used (package-use-list package)) + (unless (member (package-name used) use :test 'string=) + (unuse-package used) + (do-external-symbols (sym used) + (when (eq sym (find-symbol* sym package)) + (remove-symbol sym package))))) (dolist (used (reverse use)) (do-external-symbols (sym used) (unless (eq sym (find-symbol* sym package)) @@ -198,10 +213,10 @@ (ensure-package (name &key nicknames use unintern shadow export redefined-functions) (let* ((p (ensure-exists name nicknames use))) - (ensure-unintern p unintern) + (ensure-unintern p (append unintern #+cmu redefined-functions)) (ensure-shadow p shadow) (ensure-export p export) - (ensure-fmakunbound p redefined-functions) + #-cmu (ensure-fmakunbound p redefined-functions) p))) (macrolet ((pkgdcl (name &key nicknames use export @@ -233,11 +248,12 @@ (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command #:system-definition-pathname #:with-system-definitions #:search-for-system-definition #:find-component #:component-find-path - #:compile-system #:load-system #:load-systems #:test-system #:clear-system + #:compile-system #:load-system #:load-systems + #:require-system #:test-system #:clear-system #:operation #:compile-op #:load-op #:load-source-op #:test-op #:feature #:version #:version-satisfies #:upgrade-asdf - #:implementation-identifier #:implementation-type + #:implementation-identifier #:implementation-type #:hostname #:input-files #:output-files #:output-file #:perform #:operation-done-p #:explain @@ -254,7 +270,7 @@ #:unix-dso #:module-components ; component accessors - #:module-components-by-name ; component accessors + #:module-components-by-name #:component-pathname #:component-relative-pathname #:component-name @@ -262,8 +278,9 @@ #:component-parent #:component-property #:component-system - #:component-depends-on + #:component-encoding + #:component-external-format #:system-description #:system-long-description @@ -280,9 +297,9 @@ #:operation-on-warnings #:operation-on-failure #:component-visited-p - ;;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables + + #:*system-definition-search-functions* ; variables + #:*central-registry* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* @@ -311,6 +328,11 @@ #:coerce-entry-to-directory #:remove-entry-from-registry + #:*encoding-detection-hook* + #:*encoding-external-format-hook* + #:*default-encoding* + #:*utf-8-external-format* + #:clear-configuration #:*output-translations-parameter* #:initialize-output-translations @@ -328,7 +350,8 @@ #:clear-source-registry #:ensure-source-registry #:process-source-registry - #:system-registered-p + #:system-registered-p #:registered-systems #:loaded-systems + #:resolve-location #:asdf-message #:user-output-translations-pathname #:system-output-translations-pathname @@ -340,28 +363,31 @@ #:system-source-registry-directory ;; Utilities - #:absolute-pathname-p ;; #:aif #:it - ;; #:appendf #:orf + #:appendf #:orf + #:length=n-p + #:remove-keys #:remove-keyword + #:first-char #:last-char #:ends-with #:coerce-name - #:directory-pathname-p - ;; #:ends-with - #:ensure-directory-pathname + #:directory-pathname-p #:ensure-directory-pathname + #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root #:getenv - ;; #:length=n-p - ;; #:find-symbol* - #:merge-pathnames* #:coerce-pathname #:subpathname - #:pathname-directory-pathname + #:probe-file* + #:find-symbol* #:strcat + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname* + #:pathname-directory-pathname #:pathname-parent-directory-pathname #:read-file-forms - ;; #:remove-keys - ;; #:remove-keyword - #:resolve-symlinks + #:resolve-symlinks #:truenamize #:split-string #:component-name-to-pathname-components #:split-name-type - #:subdirectories - #:truenamize - #:while-collecting))) + #:subdirectories #:directory-files + #:while-collecting + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* + #:*wild-path* #:wilden + #:directorize-pathname-host-device + ))) #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version @@ -480,6 +506,7 @@ Returns two values: \(A B C\) and \(1 2 3\)." (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (defmacro aif (test then &optional else) + "Anaphoric version of IF, On Lisp style" `(let ((it ,test)) (if it ,then ,else))) (defun* pathname-directory-pathname (pathname) @@ -489,8 +516,9 @@ and NIL NAME, TYPE and VERSION components" (make-pathname :name nil :type nil :version nil :defaults pathname))) (defun* normalize-pathname-directory-component (directory) + "Given a pathname directory component, return an equivalent form that is a list" (cond - #-(or cmu sbcl scl) + #-(or cmu sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory) directory) #+gcl ((and (consp directory) (stringp (first directory))) @@ -502,6 +530,7 @@ and NIL NAME, TYPE and VERSION components" (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) (defun* merge-pathname-directory-components (specified defaults) + ;; Helper for merge-pathnames* that handles directory components. (let ((directory (normalize-pathname-directory-component specified))) (ecase (first directory) ((nil) defaults) @@ -523,8 +552,23 @@ and NIL NAME, TYPE and VERSION components" :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) -(defun* ununspecific (x) - (if (eq x :unspecific) nil x)) +(defun* make-pathname-component-logical (x) + "Make a pathname component suitable for use in a logical-pathname" + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + +(defun* make-pathname-logical (pathname host) + "Take a PATHNAME's directory, name, type and version components, +and make a new pathname with corresponding components and specified logical HOST" + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname)))) (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that @@ -545,7 +589,7 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) (labels ((unspecific-handler (p) - (if (typep p 'logical-pathname) #'ununspecific #'identity))) + (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) ((:absolute) @@ -613,8 +657,9 @@ starting the separation from the end, e.g. when called with arguments (let ((unspecific ;; Giving :unspecific as argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. - ;; We only use it on implementations that support it. - (or #+(or clozure gcl lispworks sbcl) :unspecific))) + ;; We only use it on implementations that support it, + #+(or abcl allegro clozure cmu gcl genera lispworks sbcl scl xcl) :unspecific + #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") @@ -744,6 +789,56 @@ actually-existing directory." (and (typep pathspec '(or pathname string)) (eq :absolute (car (pathname-directory (pathname pathspec)))))) +(defun* coerce-pathname (name &key type defaults) + "coerce NAME into a PATHNAME. +When given a string, portably decompose it into a relative pathname: +#\\/ separates subdirectories. The last #\\/-separated string is as follows: +if TYPE is NIL, its last #\\. if any separates name and type from from type; +if TYPE is a string, it is the type, and the whole string is the name; +if TYPE is :DIRECTORY, the string is a directory component; +if the string is empty, it's a directory. +Any directory named .. is read as :BACK. +Host, device and version components are taken from DEFAULTS." + ;; The defaults are required notably because they provide the default host + ;; to the below make-pathname, which may crucially matter to people using + ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. + ;; NOTE that the host and device slots will be taken from the defaults, + ;; but that should only matter if you later merge relative pathnames with + ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* + (etypecase name + ((or null pathname) + name) + (symbol + (coerce-pathname (string-downcase name) :type type :defaults defaults)) + (string + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components name :force-directory (eq type :directory) + :force-relative t) + (multiple-value-bind (name type) + (cond + ((or (eq type :directory) (null filename)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (apply 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,defaults)))))))) + +(defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") + (coerce-pathname name :type type :defaults defaults)) + +(defun* subpathname (pathname subpath &key type) + (and pathname (merge-pathnames* (coerce-pathname subpath :type type) + (pathname-directory-pathname pathname)))) + +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + (defun* length=n-p (x n) ;is it that (= (length x) n) ? (check-type n (integer 0 *)) (loop @@ -895,21 +990,22 @@ with given pathname and if it exists return its truename." (host (pathname-host pathname)) (port (ext:pathname-port pathname)) (directory (pathname-directory pathname))) - (if (or (ununspecific port) - (and (ununspecific host) (plusp (length host))) - (ununspecific scheme)) + (flet ((specificp (x) (and x (not (eq x :unspecific))))) + (if (or (specificp port) + (and (specificp host) (plusp (length host))) + (specificp scheme)) (let ((prefix "")) - (when (ununspecific port) + (when (specificp port) (setf prefix (format nil ":~D" port))) - (when (and (ununspecific host) (plusp (length host))) + (when (and (specificp host) (plusp (length host))) (setf prefix (strcat host prefix))) (setf prefix (strcat ":" prefix)) - (when (ununspecific scheme) + (when (specificp scheme) (setf prefix (strcat scheme prefix))) (assert (and directory (eq (first directory) :absolute))) (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) :defaults pathname))) - pathname)) + pathname))) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -947,6 +1043,10 @@ another pathname in a degenerate way.")) (defgeneric* (setf component-property) (new-value component property)) +(defgeneric* component-external-format (component)) + +(defgeneric* component-encoding (component)) + (eval-when (#-gcl :compile-toplevel :load-toplevel :execute) (defgeneric* (setf module-components-by-name) (new-value module))) @@ -1024,22 +1124,22 @@ processed in order by OPERATE.")) ;;;; ------------------------------------------------------------------------- ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 (when *upgraded-p* - (when (find-class 'module nil) - (eval - '(defmethod update-instance-for-redefined-class :after - ((m module) added deleted plist &key) - (declare (ignorable deleted plist)) - (when *asdf-verbose* - (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") - m (asdf-version))) - (when (member 'components-by-name added) - (compute-module-components-by-name m)) - (when (typep m 'system) - (when (member 'source-file added) - (%set-system-source-file - (probe-asd (component-name m) (component-pathname m)) m) - (when (equal (component-name m) "asdf") - (setf (component-version m) *asdf-version*)))))))) + (when (find-class 'module nil) + (eval + '(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* + (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") + m (asdf-version))) + (when (member 'components-by-name added) + (compute-module-components-by-name m)) + (when (typep m 'system) + (when (member 'source-file added) + (%set-system-source-file + (probe-asd (component-name m) (component-pathname m)) m) + (when (equal (component-name m) "asdf") + (setf (component-version m) *asdf-version*)))))))) ;;;; ------------------------------------------------------------------------- ;;;; Classes, Conditions @@ -1149,6 +1249,8 @@ processed in order by OPERATE.")) ;; it needn't be recompiled just because one of these dependencies ;; hasn't yet been loaded in the current image (do-first). ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! + ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. + ;; Maybe rename the slots in ASDF? But that's not very backwards compatible. ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) @@ -1167,6 +1269,7 @@ processed in order by OPERATE.")) (operation-times :initform (make-hash-table) :accessor component-operation-times) (around-compile :initarg :around-compile) + (%encoding :accessor %component-encoding :initform nil :initarg :encoding) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties @@ -1277,6 +1380,58 @@ processed in order by OPERATE.")) (acons property new-value (slot-value c 'properties))))) new-value) +(defvar *default-encoding* :default + "Default encoding for source files. +The default value :default preserves the legacy behavior. +A future default might be :utf-8 or :autodetect +reading emacs-style -*- coding: utf-8 -*- specifications, +and falling back to utf-8 or latin1 if nothing is specified.") + +(defparameter *utf-8-external-format* + #+(and asdf-unicode (not clisp)) :utf-8 + #+(and asdf-unicode clisp) charset:utf-8 + #-asdf-unicode :default + "Default :external-format argument to pass to CL:OPEN and also +CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. +On modern implementations, this will decode UTF-8 code points as CL characters. +On legacy implementations, it may fall back on some 8-bit encoding, +with non-ASCII code points being read as several CL characters; +hopefully, if done consistently, that won't affect program behavior too much.") + +(defun* always-default-encoding (pathname) + (declare (ignore pathname)) + *default-encoding*) + +(defvar *encoding-detection-hook* #'always-default-encoding + "Hook for an extension to define a function to automatically detect a file's encoding") + +(defun* detect-encoding (pathname) + (funcall *encoding-detection-hook* pathname)) + +(defmethod component-encoding ((c component)) + (or (loop :for x = c :then (component-parent x) + :while x :thereis (%component-encoding x)) + (detect-encoding (component-pathname c)))) + +(defun* default-encoding-external-format (encoding) + (case encoding + (:default :default) ;; for backwards compatibility only. Explicit usage discouraged. + (:utf-8 *utf-8-external-format*) + (otherwise + (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding) + :default))) + +(defvar *encoding-external-format-hook* + #'default-encoding-external-format + "Hook for an extension to define a mapping between non-default encodings +and implementation-defined external-format's") + +(defun encoding-external-format (encoding) + (funcall *encoding-external-format-hook* encoding)) + +(defmethod component-external-format ((c component)) + (encoding-external-format (component-encoding c))) + (defclass proto-system () ; slots to keep when resetting a system ;; To preserve identity for all objects, we'd need keep the components slots ;; but also to modify parse-component-form to reset the recycled objects. @@ -1440,6 +1595,10 @@ of which is a system object.") (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) +(defun* registered-systems () + (loop :for (() . system) :being :the :hash-values :of *defined-systems* + :collect (coerce-name system))) + (defun* register-system (system) (check-type system system) (let ((name (component-name system))) @@ -1530,10 +1689,8 @@ Going forward, we recommend new users should be using the source-registry. (defun* probe-asd (name defaults) (block nil (when (directory-pathname-p defaults) - (let ((file (make-pathname - :defaults defaults :name name - :version :newest :case :local :type "asd"))) - (when (probe-file* file) + (let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) + (when file (return file))) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) (when (os-windows-p) @@ -1649,18 +1806,22 @@ Going forward, we recommend new users should be using the source-registry. :condition condition)))) (let ((*package* package) (*default-pathname-defaults* - (pathname-directory-pathname pathname))) + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (translate-logical-pathname pathname))) + (external-format (encoding-external-format (detect-encoding pathname)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") pathname package) - (load pathname))) + (load pathname :external-format external-format))) (delete-package package))))) (defun* locate-system (name) "Given a system NAME designator, try to locate where to load the system from. -Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME -FOUNDP is true when a new was found, either a new unregistered one or a previously registered one. +Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a system was found, +either a new unregistered one or a previously registered one. FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is -PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system. +PATHNAME when not null is a path from where to load the system, +either associated with FOUND-SYSTEM, or with the PREVIOUS system. PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." (let* ((name (coerce-name name)) @@ -1668,7 +1829,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (previous (cdr in-memory)) (previous (and (typep previous 'system) previous)) (previous-time (car in-memory)) - (found (search-for-system-definition name)) + (found (search-for-system-definition name)) (found-system (and (typep found 'system) found)) (pathname (or (and (typep found '(or pathname string)) (pathname found)) (and found-system (system-source-file found-system)) @@ -1714,7 +1875,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (error 'missing-component :requires name)))))) (reinitialize-source-registry-and-retry () :report (lambda (s) - (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name)) + (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) (initialize-source-registry)))))) (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) @@ -1788,48 +1949,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (declare (ignorable s)) (source-file-explicit-type component)) -(defun* coerce-pathname (name &key type defaults) - "coerce NAME into a PATHNAME. -When given a string, portably decompose it into a relative pathname: -#\\/ separates subdirectories. The last #\\/-separated string is as follows: -if TYPE is NIL, its last #\\. if any separates name and type from from type; -if TYPE is a string, it is the type, and the whole string is the name; -if TYPE is :DIRECTORY, the string is a directory component; -if the string is empty, it's a directory. -Any directory named .. is read as :BACK. -Host, device and version components are taken from DEFAULTS." - ;; The defaults are required notably because they provide the default host - ;; to the below make-pathname, which may crucially matter to people using - ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. - ;; NOTE that the host and device slots will be taken from the defaults, - ;; but that should only matter if you later merge relative pathnames with - ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* - (etypecase name - ((or null pathname) - name) - (symbol - (coerce-pathname (string-downcase name) :type type :defaults defaults)) - (string - (multiple-value-bind (relative path filename) - (component-name-to-pathname-components name :force-directory (eq type :directory) - :force-relative t) - (multiple-value-bind (name type) - (cond - ((or (eq type :directory) (null filename)) - (values nil nil)) - (type - (values filename type)) - (t - (split-name-type filename))) - (apply 'make-pathname :directory (cons relative path) :name name :type type - (when defaults `(:defaults ,defaults)))))))) - -(defun* merge-component-name-type (name &key type defaults) - ;; For backwards compatibility only, for people using internals. - ;; Will be removed in a future release, e.g. 2.016. - (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") - (coerce-pathname name :type type :defaults defaults)) - (defmethod component-relative-pathname ((component component)) (coerce-pathname (or (slot-value component 'relative-pathname) @@ -1837,14 +1956,6 @@ Host, device and version components are taken from DEFAULTS." :type (source-file-type component (component-system component)) :defaults (component-parent-pathname component))) -(defun* subpathname (pathname subpath &key type) - (and pathname (merge-pathnames* (coerce-pathname subpath :type type) - (pathname-directory-pathname pathname)))) - -(defun subpathname* (pathname subpath &key type) - (and pathname - (subpathname (ensure-directory-pathname pathname) subpath :type type))) - ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -1860,6 +1971,7 @@ Host, device and version components are taken from DEFAULTS." ;; to force systems named in a given list ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 (forced :initform nil :initarg :force :accessor operation-forced) + (forced-not :initform nil :initarg :force-not :accessor operation-forced-not) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) @@ -1872,10 +1984,15 @@ Host, device and version components are taken from DEFAULTS." (prin1 (operation-original-initargs o) stream)))) (defmethod shared-initialize :after ((operation operation) slot-names - &key force + &key force force-not &allow-other-keys) - (declare (ignorable operation slot-names force)) - ;; empty method to disable initarg validity checking + ;; the &allow-other-keys disables initarg validity checking + (declare (ignorable operation slot-names force force-not)) + (macrolet ((frob (x) ;; normalize forced and forced-not slots + `(when (consp (,x operation)) + (setf (,x operation) + (mapcar #'coerce-name (,x operation)))))) + (frob operation-forced) (frob operation-forced-not)) (values)) (defun* node-for (o c) @@ -2053,7 +2170,7 @@ recursive calls to traverse.") comp)) (retry () :report (lambda (s) - (format s "~@<Retry loading ~3i~_~A.~@:>" name)) + (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name)) :test (lambda (c) (or (null c) @@ -2143,14 +2260,17 @@ recursive calls to traverse.") (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (unwind-protect - (progn - (let ((f (operation-forced - (operation-ancestor operation)))) - (when (and f (or (not (consp f)) ;; T or :ALL - (and (typep c 'system) ;; list of names of systems to force - (member (component-name c) f - :test #'string=)))) - (setf *forcing* t))) + (block nil + (when (typep c 'system) ;; systems can be forced or forced-not + (let ((ancestor (operation-ancestor operation))) + (flet ((match? (f) + (and f (or (not (consp f)) ;; T or :ALL + (member (component-name c) f :test #'equal))))) + (cond + ((match? (operation-forced ancestor)) + (setf *forcing* t)) + ((match? (operation-forced-not ancestor)) + (return)))))) ;; first we check and do all the dependencies for the module. ;; Operations planned in this loop will show up ;; in the results, and are consumed below. @@ -2205,9 +2325,9 @@ recursive calls to traverse.") :do (do-dep operation c collect required-op deps))) (do-collect collect (vector module-ops)) (do-collect collect (cons operation c))))) - (setf (visiting-component operation c) nil))) - (visit-component operation c (when flag (incf *visit-count*))) - flag)) + (setf (visiting-component operation c) nil))) + (visit-component operation c (when flag (incf *visit-count*))) + flag)) (defun* flatten-tree (l) ;; You collected things into a list. @@ -2226,9 +2346,6 @@ recursive calls to traverse.") (r* l)))) (defmethod traverse ((operation operation) (c component)) - (when (consp (operation-forced operation)) - (setf (operation-forced operation) - (mapcar #'coerce-name (operation-forced operation)))) (flatten-tree (while-collecting (collect) (let ((*visit-count* 0)) @@ -2299,14 +2416,11 @@ recursive calls to traverse.") (first files))) (defun* ensure-all-directories-exist (pathnames) - (loop :for pn :in pathnames - :for pathname = (if (typep pn 'logical-pathname) - (translate-logical-pathname pn) - pn) - :do (ensure-directories-exist pathname))) + (dolist (pathname pathnames) + (ensure-directories-exist (translate-logical-pathname pathname)))) (defmethod perform :before ((operation compile-op) (c source-file)) - (ensure-all-directories-exist (asdf:output-files operation c))) + (ensure-all-directories-exist (output-files operation c))) (defmethod perform :after ((operation operation) (c component)) (mark-operation-done operation c)) @@ -2352,7 +2466,9 @@ recursive calls to traverse.") (call-with-around-compile-hook c #'(lambda () (apply *compile-op-compile-file-function* source-file - :output-file output-file (compile-op-flags operation)))) + :output-file output-file + :external-format (component-external-format c) + (compile-op-flags operation)))) (unless output (error 'compile-error :component c :operation operation)) (when failure-p @@ -2458,7 +2574,8 @@ recursive calls to traverse.") (declare (ignorable o)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) - (and (call-with-around-compile-hook c #'(lambda () (load source))) + (and (call-with-around-compile-hook + c #'(lambda () (load source :external-format (component-external-format c)))) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) @@ -2520,7 +2637,7 @@ recursive calls to traverse.") ;;;; Separating this into a different function makes it more forward-compatible (defun* cleanup-upgraded-asdf (old-version) - (let ((new-version (asdf:asdf-version))) + (let ((new-version (asdf-version))) (unless (equal old-version new-version) (cond ((version-satisfies new-version old-version) @@ -2546,7 +2663,7 @@ recursive calls to traverse.") ;;;; Try to upgrade of ASDF. If a different version was used, return T. ;;;; We need do that before we operate on anything that depends on ASDF. (defun* upgrade-asdf () - (let ((version (asdf:asdf-version))) + (let ((version (asdf-version))) (handler-bind (((or style-warning warning) #'muffle-warning)) (operate 'load-op :asdf :verbose nil)) (cleanup-upgraded-asdf version))) @@ -2628,9 +2745,18 @@ See OPERATE for details." (defun* load-systems (&rest systems) (map () 'load-system systems)) +(defun component-loaded-p (c) + (and (gethash 'load-op (component-operation-times (find-component c nil))) t)) + +(defun loaded-systems () + (remove-if-not 'component-loaded-p (registered-systems))) + +(defun require-system (s) + (load-system s :force-not (loaded-systems))) + (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) - "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE + "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply 'operate 'compile-op system args) @@ -2638,7 +2764,7 @@ for details." (defun* test-system (system &rest args &key force verbose version &allow-other-keys) - "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply 'operate 'test-op system args) @@ -2762,8 +2888,8 @@ Returns the new tree (which probably shares structure with the old one)" ;; remove-keys form. important to keep them in sync components pathname default-component-class perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to do-first + weakly-depends-on depends-on serial in-order-to + do-first (version nil versionp) ;; list ends &allow-other-keys) options @@ -2793,7 +2919,7 @@ Returns the new tree (which probably shares structure with the old one)" rest))) (ret (find-component parent name))) (when weakly-depends-on - (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) + (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) (if ret ; preserve identity @@ -2892,8 +3018,7 @@ Returns the new tree (which probably shares structure with the old one)" ;;;; ;;;; As a suggested replacement which is portable to all ASDF-supported ;;;; implementations and operating systems except Genera, I recommend -;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its -;;;; derivatives such as xcvb-driver:run-program/for-side-effects. +;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives. (defun* run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and @@ -3017,6 +3142,10 @@ if that's whay you mean." ;;) (system-source-file x)) (defmethod system-source-file ((system system)) + ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed + (unless (slot-boundp system 'source-file) + (%set-system-source-file + (probe-asd (component-name system) (component-pathname system)) system)) (%system-source-file system)) (defmethod system-source-file ((system-name string)) (%system-source-file (find-system system-name))) @@ -3085,6 +3214,15 @@ located." ;; we may have to segregate the code still by architecture. (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) +#+clozure +(defun* ccl-fasl-version () + ;; the fasl version is target-dependent from CCL 1.8 on. + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) + (and (boundp 'ccl::fasl-version) + (symbol-value 'ccl::fasl-version)) + (error "Can't determine fasl version."))) + (defun lisp-version-string () (let ((s (lisp-implementation-version))) (car ; as opposed to OR, this idiom prevents some unreachable code warning @@ -3104,11 +3242,11 @@ located." (format nil "~d.~d-f~d" ; shorten for windows ccl::*openmcl-major-version* ccl::*openmcl-minor-version* - (logand ccl::fasl-version #xFF)) + (logand (ccl-fasl-version) #xFF)) #+cmu (substitute #\- #\/ s) #+scl (format nil "~A~A" s - ;; ANSI upper case vs lower case. - (ecase ext:*case-mode* (:upper "") (:lower "l"))) + ;; ANSI upper case vs lower case. + (ecase ext:*case-mode* (:upper "") (:lower "l"))) #+ecl (format nil "~A~@[-~A~]" s (let ((vcs-id (ext:lisp-implementation-vcs-id))) (subseq vcs-id 0 (min (length vcs-id) 8)))) @@ -3128,6 +3266,14 @@ located." (or (operating-system) (software-type)) (or (architecture) (machine-type))))) +(defun* hostname () + ;; Note: untested on RMCL + #+(or abcl clozure cmucl ecl genera lispworks mcl sbcl scl xcl) (machine-instance) + #+cormanlisp "localhost" ;; is there a better way? Does it matter? + #+allegro (excl.osi:gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname)) + ;;; --------------------------------------------------------------------------- ;;; Generic support for configuration files @@ -3141,21 +3287,37 @@ located." #+mcl (current-user-homedir-pathname) #-mcl (user-homedir-pathname)))) +(defun* ensure-absolute-pathname* (x fmt &rest args) + (and (plusp (length x)) + (or (absolute-pathname-p x) + (cerror "ignore relative pathname" + "Invalid relative pathname ~A~@[ ~?~]" x fmt args)) + x)) +(defun* split-absolute-pathnames (x fmt &rest args) + (loop :for dir :in (split-string + x :separator (string (inter-directory-separator))) + :do (apply 'ensure-absolute-pathname* dir fmt args) + :collect dir)) +(defun getenv-absolute-pathname (x &aux (s (getenv x))) + (ensure-absolute-pathname* s "from (getenv ~S)" x)) +(defun getenv-absolute-pathnames (x &aux (s (getenv x))) + (and (plusp (length s)) + (split-absolute-pathnames s "from (getenv ~S) = ~S" x s))) + (defun* user-configuration-directories () (let ((dirs `(,@(when (os-unix-p) (cons - (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/") - (loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") + (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/") + (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS") :collect (subpathname* dir "common-lisp/")))) ,@(when (os-windows-p) `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) + (getenv-absolute-pathname "LOCALAPPDATA")) "common-lisp/config/") ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) + (getenv-absolute-pathname "APPDATA")) "common-lisp/config/"))) ,(subpathname (user-homedir) ".config/common-lisp/")))) (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) @@ -3168,8 +3330,8 @@ located." (aif ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")) + (getenv-absolute-pathname "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")) "common-lisp/config/") (list it))))) @@ -3293,12 +3455,12 @@ and the order is by decreasing length of namestring of the source pathname.") (defvar *user-cache* (flet ((try (x &rest sub) (and x `(,x ,@sub)))) (or - (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) + (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation) (when (os-windows-p) (try (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA") + (getenv-absolute-pathname "LOCALAPPDATA") #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) + (getenv-absolute-pathname "APPDATA")) "common-lisp" "cache" :implementation)) '(:home ".cache" "common-lisp" :implementation)))) @@ -3353,7 +3515,9 @@ with a different configuration, so the configuration would be re-read then." ((eql :implementation) (coerce-pathname (implementation-identifier) :type :directory)) ((eql :implementation-type) - (coerce-pathname (string-downcase (implementation-type)) :type :directory))))) + (coerce-pathname (string-downcase (implementation-type)) :type :directory)) + ((eql :hostname) + (coerce-pathname (hostname) :type :directory))))) (when (absolute-pathname-p r) (error (compatfmt "~@<pathname ~S is not relative~@:>") x)) (if (or (pathnamep x) (not wilden)) r (wilden r)))) @@ -3433,13 +3597,12 @@ Please remove it from your ASDF configuration")) (defun* location-function-p (x) (and - (consp x) (length=n-p x 2) - (or (and (equal (first x) :function) - (typep (second x) 'symbol)) - (and (equal (first x) 'lambda) - (cddr x) - (length=n-p (second x) 2))))) + (eq (car x) :function) + (or (symbolp (cadr x)) + (and (consp (cadr x)) + (eq (caadr x) 'lambda) + (length=n-p (cadadr x) 2))))) (defun* validate-output-translations-directive (directive) (or (member directive '(:enable-user-cache :disable-cache nil)) @@ -3840,23 +4003,29 @@ with a different configuration, so the configuration would be re-read then." (loop :for f :in entries :for p = (or (and (typep f 'logical-pathname) f) (let* ((u (ignore-errors (funcall merger f)))) - ;; The first u avoids a cumbersome (truename u) error - (and u (equal (ignore-errors (truename u)) f) u))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for doesn't have :version :newest + (and u (equal (ignore-errors (truename u)) (truename f)) u))) :when p :collect p) entries)) (defun* directory-files (directory &optional (pattern *wild-file*)) + (setf directory (pathname directory)) (when (wild-pathname-p directory) (error "Invalid wild in ~S" directory)) (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (error "Invalid file pattern ~S" pattern)) + (when (typep directory 'logical-pathname) + (setf pattern (make-pathname-logical pattern (pathname-host directory)))) (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory))))) (filter-logical-directory-results directory entries #'(lambda (f) (make-pathname :defaults directory - :name (pathname-name f) :type (ununspecific (pathname-type f)) - :version (ununspecific (pathname-version f))))))) + :name (pathname-name f) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -3889,15 +4058,14 @@ with a different configuration, so the configuration would be re-read then." #+(or cmu lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs - (let ((prefix (normalize-pathname-directory-component - (pathname-directory directory)))) + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" #'(lambda (d) - (let ((dir (normalize-pathname-directory-component - (pathname-directory d)))) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) (and (consp dir) (consp (cdr dir)) (make-pathname :defaults directory :name nil :type nil :version nil - :directory (append prefix (last dir)))))))))) + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) (defun* collect-asds-in-directory (directory collect) (map () collect (directory-asd-files directory))) @@ -4015,19 +4183,18 @@ with a different configuration, so the configuration would be re-read then." (:directory ,(default-directory)) ,@(loop :for dir :in `(,@(when (os-unix-p) - `(,(or (getenv "XDG_DATA_HOME") + `(,(or (getenv-absolute-pathname "XDG_DATA_HOME") (subpathname (user-homedir) ".local/share/")) - ,@(split-string (or (getenv "XDG_DATA_DIRS") - "/usr/local/share:/usr/share") - :separator ":"))) + ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS") + '("/usr/local/share" "/usr/share")))) ,@(when (os-windows-p) `(,(or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) + (getenv-absolute-pathname "LOCALAPPDATA")) ,(or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) + (getenv-absolute-pathname "APPDATA")) ,(or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))))) + (getenv-absolute-pathname "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))))) :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) :inherit-configuration)) @@ -4113,8 +4280,8 @@ with a different configuration, so the configuration would be re-read then." ,parameter ,@*default-source-registries*) :register #'(lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude))))) - :test 'equal :from-end t))) + (collect (list directory :recurse recurse :exclude exclude)))))) + :test 'equal :from-end t)) ;; Will read the configuration and initialize all internal variables. (defun* compute-source-registry (&optional parameter (registry *source-registry*)) @@ -4190,9 +4357,6 @@ with a different configuration, so the configuration would be re-read then." (progn (setf *compile-op-compile-file-function* 'ecl-compile-file) - (defun use-ecl-byte-compiler-p () - (member :ecl-bytecmp *features*)) - (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys) (if (use-ecl-byte-compiler-p) (apply 'compile-file* input-file keys) diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index 2368f89..7c1a394 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -29,7 +29,7 @@ New in this release: and access these packed numbers. * Changes - * ASDF2 updated to version 2.019. + * ASDF2 updated to version 2.21. * Behavior of STRING-TO-OCTETS has changed. This is an incompatible change from the previous version but should be more useful when a buffer is given which is not large enough to hold commit a8aae09a20417cbe7bd5b353c1ba096754cbd551 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Apr 30 20:07:49 2012 -0700 Update. diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 361d385..5b38108 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -21047,6 +21047,14 @@ msgid "" msgstr "" msgid "" +"EUC-KR is an variable-length character encoding generally intended for\n" +"Korean Hangul.\n" +"\n" +"By default, illegal inputs are replaced by the Unicode replacement\n" +"character and illegal outputs are replaced by a question mark." +msgstr "" + +msgid "" "ISO8859-2 is an 8-bit character encoding generally intended for\n" "Eastern European languages including Bosnian, Croation, Czech, German,\n" "Hungarian, Polish, Romanian, Serbian Latin, Slovak, Slovene, Upper\n" ----------------------------------------------------------------------- Summary of changes: src/contrib/asdf/asdf.lisp | 572 ++++++++++++++++++++++++-------------- src/general-info/release-20d.txt | 2 +- src/i18n/locale/cmucl.pot | 8 + 3 files changed, 377 insertions(+), 205 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0