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

[cmucl-cvs] CMUCL commit: RELEASE-20B-BRANCH src/tools (build-unidata.lisp)
by Raymond Toy 19 Sep '10

19 Sep '10

Date: Saturday, September 18, 2010 @ 23:31:40 Author: rtoy Path: /project/cmucl/cvsroot/src/tools Tag: RELEASE-20B-BRANCH Modified: build-unidata.lisp Merge fix for long standing bug where the trie for Unicode 1.0 names was given the wrong split value. --------------------+ build-unidata.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/tools/build-unidata.lisp diff -u src/tools/build-unidata.lisp:1.4 src/tools/build-unidata.lisp:1.4.14.1 --- src/tools/build-unidata.lisp:1.4 Fri Sep 11 12:22:35 2009 +++ src/tools/build-unidata.lisp Sat Sep 18 23:31:40 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/tools/build-unidata.lisp,v 1.4 2009-09-11 16:22:35 rtoy Rel $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/tools/build-unidata.lisp,v 1.4.14.1 2010-09-19 03:31:40 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -980,7 +980,7 @@ (multiple-value-bind (hvec mvec lvec) (pack ucd range (lambda (x) (pack-name x t dict)) 0 32 #x54) (setf (unidata-name1 *unicode-data*) - (make-ntrie32 :split #x72 :hvec hvec :mvec mvec :lvec lvec)))) + (make-ntrie32 :split #x54 :hvec hvec :mvec mvec :lvec lvec)))) (format t "~&Building general category table~%") (multiple-value-bind (hvec mvec lvec)

1 0

[cmucl-cvs] CMUCL commit: src/tools (build-unidata.lisp)
by Raymond Toy 19 Sep '10

19 Sep '10

Date: Saturday, September 18, 2010 @ 23:31:12 Author: rtoy Path: /project/cmucl/cvsroot/src/tools Modified: build-unidata.lisp Oops. Fix long standing bug where the trie for Unicode 1.0 names was given the wrong split value. --------------------+ build-unidata.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/tools/build-unidata.lisp diff -u src/tools/build-unidata.lisp:1.7 src/tools/build-unidata.lisp:1.8 --- src/tools/build-unidata.lisp:1.7 Sat Sep 18 16:58:28 2010 +++ src/tools/build-unidata.lisp Sat Sep 18 23:31:12 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/tools/build-unidata.lisp,v 1.7 2010-09-18 20:58:28 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/tools/build-unidata.lisp,v 1.8 2010-09-19 03:31:12 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -973,7 +973,7 @@ (multiple-value-bind (hvec mvec lvec) (pack ucd range (lambda (x) (pack-name x t dict)) 0 32 #x54) (setf (unidata-name1 *unicode-data*) - (make-ntrie32 :split #x72 :hvec hvec :mvec mvec :lvec lvec)))) + (make-ntrie32 :split #x54 :hvec hvec :mvec mvec :lvec lvec)))) (format t "~&Building general category table~%") (multiple-value-bind (hvec mvec lvec)

1 0

[cmucl-cvs] CMUCL commit: src/code (unidata.lisp)
by Raymond Toy 19 Sep '10

19 Sep '10

Date: Saturday, September 18, 2010 @ 22:37:11 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: unidata.lisp o Construction of the Hangul syllable codebook was wrong. To satisfy the constraints on the codebook, we just sort them in descreasing order of length. o In %MIP, it might happen that MISMATCH returns NIL, which means a match. In this case, don't change the position. --------------+ unidata.lisp | 33 ++++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.17 src/code/unidata.lisp:1.18 --- src/code/unidata.lisp:1.17 Sat Sep 18 17:38:10 2010 +++ src/code/unidata.lisp Sat Sep 18 22:37:10 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.17 2010-09-18 21:38:10 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.18 2010-09-19 02:37:10 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,7 +18,7 @@ (defconstant +unidata-path+ #p"ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.17 $") +(defvar *unidata-version* "$Revision: 1.18 $") (defstruct unidata range @@ -1304,7 +1304,7 @@ (let* ((first (first strings)) (posn (length first))) (dolist (string (rest strings)) - (setq posn (mismatch first string :end1 posn))) + (setq posn (or (mismatch first string :end1 posn) posn))) (subseq first 0 posn))) (defun node-next (i &optional (dict (unidata-name+ *unicode-data*))) @@ -1334,15 +1334,23 @@ (defun build-hangul-syllable-dictionary () "Build the dictionary for Hangul syllables" (format t "~&Building Hangul Syllable dictionary. Please wait...~%") + (force-output) (initialize-reverse-hangul-tables) (let ((hangul-codebook - (map 'vector #'car - (delete "" - (concatenate 'vector - *reverse-hangul-choseong* - *reverse-hangul-jungseong* - *reverse-hangul-jongseong*) - :test #'string= :key #'car))) + ;; For our codebook, combine all the choseong, jungseong, and + ;; jonseong syllables, but removing empty strings (there's at + ;; least one). Then sort these according to length. This + ;; ensures that if A is an initial substring of B, then B + ;; must come before A (or A will never be used). (See + ;; tools/build-unidata.lisp, *codebook*.) + (sort (map 'vector #'car + (delete "" + (concatenate 'vector + *reverse-hangul-choseong* + *reverse-hangul-jungseong* + *reverse-hangul-jongseong*) + :test #'string= :key #'car)) + #'> :key #'length)) (names (loop for codepoint from 0 below codepoint-limit when (hangul-syllable-p codepoint) @@ -1352,13 +1360,15 @@ codepoint)))) (setf *hangul-syllable-dictionary* - (build-dictionary hangul-codebook (nreverse names))) + (build-dictionary hangul-codebook names)) (format t "~&Done.~%") + (force-output) (values))) (defun build-cjk-unified-ideograph-dictionary () "Build the dictionary for CJK Unified Ideographs" (format t "~&Building CJK Unified Ideographs dictionary. Please wait...~%") + (force-output) (let ((codebook (coerce (loop for k from 0 to 15 collect (format nil "~X" k)) 'vector)) @@ -1369,6 +1379,7 @@ (setf *cjk-unified-ideograph-dictionary* (build-dictionary codebook names)) (format t "~&Done.~%") + (force-output) (values))) ;; The definitions of BUILD-DICTIONARY, NAME-LOOKUP, and ENCODE-NAME

1 0

[cmucl-cvs] CMUCL commit: src/code (unidata.lisp)
by Raymond Toy 18 Sep '10

18 Sep '10

Date: Saturday, September 18, 2010 @ 17:38:11 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: unidata.lisp Some Hangul syllables were left out of the Hangul syllable dictionary. Redo this by looping over all codepoints and selecting the codepoints that are Hangul syllables. --------------+ unidata.lisp | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.16 src/code/unidata.lisp:1.17 --- src/code/unidata.lisp:1.16 Sat Sep 18 17:10:42 2010 +++ src/code/unidata.lisp Sat Sep 18 17:38:10 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.16 2010-09-18 21:10:42 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.17 2010-09-18 21:38:10 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,7 +18,7 @@ (defconstant +unidata-path+ #p"ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.16 $") +(defvar *unidata-version* "$Revision: 1.17 $") (defstruct unidata range @@ -1343,18 +1343,14 @@ *reverse-hangul-jungseong* *reverse-hangul-jongseong*) :test #'string= :key #'car))) - (k 0) - names) - (loop for choseong across *reverse-hangul-choseong* do - (loop for junseong across *reverse-hangul-jungseong* do - (loop for jongseong across *reverse-hangul-jongseong* do - (push (cons (format nil "~A~A~A" - (car choseong) - (car junseong) - (car jongseong)) - k) - names) - (incf k)))) + (names + (loop for codepoint from 0 below codepoint-limit + when (hangul-syllable-p codepoint) + collect (cons (subseq (format nil "~A" + (string-upcase (char-name (code-char codepoint)))) + 16) + codepoint)))) + (setf *hangul-syllable-dictionary* (build-dictionary hangul-codebook (nreverse names))) (format t "~&Done.~%")

1 0

[cmucl-cvs] CMUCL commit: src (code/unidata.lisp i18n/unidata.bin)
by Raymond Toy 18 Sep '10

18 Sep '10

Date: Saturday, September 18, 2010 @ 17:10:42 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: code/unidata.lisp i18n/unidata.bin code/unidata.lisp: o Update constants to Unicode version 5.2.0. i18n/unidata.bin: o Regenerated using Unicode version 5.2.0. -------------------+ code/unidata.lisp | 6 +++--- i18n/unidata.bin | <<Binary file>> 2 files changed, 4 insertions(+), 3 deletions(-) Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.15 src/code/unidata.lisp:1.16 --- src/code/unidata.lisp:1.15 Sat Sep 18 16:47:51 2010 +++ src/code/unidata.lisp Sat Sep 18 17:10:42 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.15 2010-09-18 20:47:51 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.16 2010-09-18 21:10:42 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,7 +18,7 @@ (defconstant +unidata-path+ #p"ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.15 $") +(defvar *unidata-version* "$Revision: 1.16 $") (defstruct unidata range @@ -57,7 +57,7 @@ ;; The expected Unicode version. This needs to be synced with ;; build-unidata.lisp. (defconstant +unicode-major-version+ 5) -(defconstant +unicode-minor-version+ 1) +(defconstant +unicode-minor-version+ 2) (defconstant +unicode-update-version+ 0) ;;; These need to be synched with tools/build-unidata.lisp Index: src/i18n/unidata.bin <<Binary file>>

1 0

[cmucl-cvs] CMUCL commit: src/tools (build-unidata.lisp)
by Raymond Toy 18 Sep '10

18 Sep '10

Date: Saturday, September 18, 2010 @ 16:58:28 Author: rtoy Path: /project/cmucl/cvsroot/src/tools Modified: build-unidata.lisp Simple refactoring: Add function to write out a dictionary and use it to write out the unicode name dictionaries. --------------------+ build-unidata.lisp | 50 +++++++++++++++++++------------------------------- 1 file changed, 19 insertions(+), 31 deletions(-) Index: src/tools/build-unidata.lisp diff -u src/tools/build-unidata.lisp:1.6 src/tools/build-unidata.lisp:1.7 --- src/tools/build-unidata.lisp:1.6 Sat Sep 18 16:47:51 2010 +++ src/tools/build-unidata.lisp Sat Sep 18 16:58:28 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/tools/build-unidata.lisp,v 1.6 2010-09-18 20:47:51 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/tools/build-unidata.lisp,v 1.7 2010-09-18 20:58:28 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -460,6 +460,20 @@ (ntrie1-mvec data) (ntrie1-lvec data) stm)) + (write-dict (data stm) + (write-byte (1- (length (dictionary-cdbk data))) stm) + (write16 (length (dictionary-keyv data)) stm) + (write32 (length (dictionary-codev data)) stm) + (let ((codebook (dictionary-cdbk data))) + (dotimes (i (length codebook)) + (write-byte (length (aref codebook i)) stm) + (dotimes (j (length (aref codebook i))) + (write-byte (char-code (char (aref codebook i) j)) stm)))) + (write-vector (dictionary-keyv data) stm :endian-swap :network-order) + (write-vector (dictionary-keyl data) stm :endian-swap :network-order) + (write-vector (dictionary-codev data) stm :endian-swap :network-order) + (write-vector (dictionary-nextv data) stm :endian-swap :network-order) + (write-vector (dictionary-namev data) stm :endian-swap :network-order)) (update-index (val array) (let ((result (vector-push val array))) (unless result @@ -486,21 +500,8 @@ (write32 (length (range-codes data)) stm) (write-vector (range-codes data) stm :endian-swap :network-order)) ;; 1. Character name data - (let ((data (unidata-name+ *unicode-data*))) - (update-index (file-position stm) index) - (write-byte (1- (length (dictionary-cdbk data))) stm) - (write16 (length (dictionary-keyv data)) stm) - (write32 (length (dictionary-codev data)) stm) - (let ((codebook (dictionary-cdbk data))) - (dotimes (i (length codebook)) - (write-byte (length (aref codebook i)) stm) - (dotimes (j (length (aref codebook i))) - (write-byte (char-code (char (aref codebook i) j)) stm)))) - (write-vector (dictionary-keyv data) stm :endian-swap :network-order) - (write-vector (dictionary-keyl data) stm :endian-swap :network-order) - (write-vector (dictionary-codev data) stm :endian-swap :network-order) - (write-vector (dictionary-nextv data) stm :endian-swap :network-order) - (write-vector (dictionary-namev data) stm :endian-swap :network-order)) + (update-index (file-position stm) index) + (write-dict (unidata-name+ *unicode-data*) stm) ;; 2. Codepoint-to-name mapping (let ((data (unidata-name *unicode-data*))) (update-index (file-position stm) index) @@ -536,21 +537,8 @@ (write-byte (length (bidi-tabl data)) stm) (write-vector (bidi-tabl data) stm :endian-swap :network-order)) ;; 9. Unicode 1.0 names - (let ((data (unidata-name1+ *unicode-data*))) - (update-index (file-position stm) index) - (write-byte (1- (length (dictionary-cdbk data))) stm) - (write16 (length (dictionary-keyv data)) stm) - (write32 (length (dictionary-codev data)) stm) - (let ((codebook (dictionary-cdbk data))) - (dotimes (i (length codebook)) - (write-byte (length (aref codebook i)) stm) - (dotimes (j (length (aref codebook i))) - (write-byte (char-code (char (aref codebook i) j)) stm)))) - (write-vector (dictionary-keyv data) stm :endian-swap :network-order) - (write-vector (dictionary-keyl data) stm :endian-swap :network-order) - (write-vector (dictionary-codev data) stm :endian-swap :network-order) - (write-vector (dictionary-nextv data) stm :endian-swap :network-order) - (write-vector (dictionary-namev data) stm :endian-swap :network-order)) + (update-index (file-position stm) index) + (write-dict (unidata-name1+ *unicode-data*) stm) ;; 10. Codepoint to unicode-1.0 name (let ((data (unidata-name1 *unicode-data*))) (update-index (file-position stm) index)

1 0

[cmucl-cvs] CMUCL commit: src (code/unidata.lisp tools/build-unidata.lisp)
by Raymond Toy 18 Sep '10

18 Sep '10

Date: Saturday, September 18, 2010 @ 16:47:51 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: code/unidata.lisp tools/build-unidata.lisp code/unidata.lisp: o Just add some comments on why we don't put the dictionaries in unidata.bin. o Print out some messages when building the hangul and cjk dictionaries so the user knows what's happening. tools/build-unidata.lisp: o Add some comments on the various parts of unidata.bin. --------------------------+ code/unidata.lisp | 25 +++++++++++++++++++++---- tools/build-unidata.lisp | 41 +++++++++++++++++++++++------------------ 2 files changed, 44 insertions(+), 22 deletions(-) Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.14 src/code/unidata.lisp:1.15 --- src/code/unidata.lisp:1.14 Fri Sep 17 19:29:01 2010 +++ src/code/unidata.lisp Sat Sep 18 16:47:51 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.14 2010-09-17 23:29:01 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.15 2010-09-18 20:47:51 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,7 +18,7 @@ (defconstant +unidata-path+ #p"ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.14 $") +(defvar *unidata-version* "$Revision: 1.15 $") (defstruct unidata range @@ -1116,6 +1116,17 @@ ;; Code written by Paul Foley, with some modifications by Raymond Toy. ;; +;; These hold dictionaries for the Hangul syllables and the CJK +;; unified ideographs. Note that these could be stored in +;; unidata.bin, but that adds almost a megabyte to the size of +;; unidata.bin. That seems way to much bloat for something that is +;; probably not used that much. However, this incurs a runtime cost +;; the first time it needs to be accessed. On a 450 MHz sparc, it +;; takes 55 sec for the cjk dictionary and 9 sec for the Hangul +;; dictionary. A bit long but not too bad. On a 2 GHz mac mini, it +;; takes 5 sec and .8 sec, respectively. This seems reasonable, +;; especially since the intent is for character completion, which +;; doesn't have to be too fast. (defvar *hangul-syllable-dictionary* nil "Dictionary of Hangul syllables") (defvar *cjk-unified-ideograph-dictionary* nil @@ -1322,6 +1333,7 @@ (defun build-hangul-syllable-dictionary () "Build the dictionary for Hangul syllables" + (format t "~&Building Hangul Syllable dictionary. Please wait...~%") (initialize-reverse-hangul-tables) (let ((hangul-codebook (map 'vector #'car @@ -1344,10 +1356,13 @@ names) (incf k)))) (setf *hangul-syllable-dictionary* - (build-dictionary hangul-codebook (nreverse names))))) + (build-dictionary hangul-codebook (nreverse names))) + (format t "~&Done.~%") + (values))) (defun build-cjk-unified-ideograph-dictionary () "Build the dictionary for CJK Unified Ideographs" + (format t "~&Building CJK Unified Ideographs dictionary. Please wait...~%") (let ((codebook (coerce (loop for k from 0 to 15 collect (format nil "~X" k)) 'vector)) @@ -1356,7 +1371,9 @@ collect (cons (format nil "~X" codepoint) codepoint)))) (setf *cjk-unified-ideograph-dictionary* - (build-dictionary codebook names)))) + (build-dictionary codebook names)) + (format t "~&Done.~%") + (values))) ;; The definitions of BUILD-DICTIONARY, NAME-LOOKUP, and ENCODE-NAME ;; were taken from build-unidata.lisp. Index: src/tools/build-unidata.lisp diff -u src/tools/build-unidata.lisp:1.5 src/tools/build-unidata.lisp:1.6 --- src/tools/build-unidata.lisp:1.5 Wed Sep 15 17:06:39 2010 +++ src/tools/build-unidata.lisp Sat Sep 18 16:47:51 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/tools/build-unidata.lisp,v 1.5 2010-09-15 21:06:39 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/tools/build-unidata.lisp,v 1.6 2010-09-18 20:47:51 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -466,6 +466,8 @@ (error "Index array too short for the data being written"))))) (with-open-file (stm path :direction :io :if-exists :rename-and-delete :element-type '(unsigned-byte 8)) + ;; The length of the index array is the number of sections to be + ;; written. See below for each section. (let ((index (make-array 19 :fill-pointer 0))) ;; File header (write32 +unicode-magic-number+ stm) ; identification "magic" @@ -478,12 +480,12 @@ (dotimes (i (array-dimension index 0)) (write32 0 stm)) ; space for indices (write32 0 stm) ; end marker - ;; Range data + ;; 0. Range data (let ((data (unidata-range *unicode-data*))) (update-index (file-position stm) index) (write32 (length (range-codes data)) stm) (write-vector (range-codes data) stm :endian-swap :network-order)) - ;; Character name data + ;; 1. Character name data (let ((data (unidata-name+ *unicode-data*))) (update-index (file-position stm) index) (write-byte (1- (length (dictionary-cdbk data))) stm) @@ -499,41 +501,41 @@ (write-vector (dictionary-codev data) stm :endian-swap :network-order) (write-vector (dictionary-nextv data) stm :endian-swap :network-order) (write-vector (dictionary-namev data) stm :endian-swap :network-order)) - ;; Codepoint-to-name mapping + ;; 2. Codepoint-to-name mapping (let ((data (unidata-name *unicode-data*))) (update-index (file-position stm) index) (write-ntrie32 data stm)) - ;; Codepoint-to-category table + ;; 3. Codepoint-to-category table (let ((data (unidata-category *unicode-data*))) (update-index (file-position stm) index) (write-ntrie8 data stm)) - ;; Simple case mapping table + ;; 4. Simple case mapping table (let ((data (unidata-scase *unicode-data*))) (update-index (file-position stm) index) (write-ntrie32 data stm) (write-byte (length (scase-svec data)) stm) (write-vector (scase-svec data) stm :endian-swap :network-order)) - ;; Numeric data + ;; 5. Numeric data (let ((data (unidata-numeric *unicode-data*))) (update-index (file-position stm) index) (write-ntrie32 data stm)) - ;; Decomposition data + ;; 6. Decomposition data (let ((data (unidata-decomp *unicode-data*))) (update-index (file-position stm) index) (write-ntrie32 data stm) (write16 (length (decomp-tabl data)) stm) (write-vector (decomp-tabl data) stm :endian-swap :network-order)) - ;; Combining classes + ;; 7. Combining classes (let ((data (unidata-combining *unicode-data*))) (update-index (file-position stm) index) (write-ntrie8 data stm)) - ;; Bidi data + ;; 8. Bidi data (let ((data (unidata-bidi *unicode-data*))) (update-index (file-position stm) index) (write-ntrie16 data stm) (write-byte (length (bidi-tabl data)) stm) (write-vector (bidi-tabl data) stm :endian-swap :network-order)) - ;; Unicode 1.0 names + ;; 9. Unicode 1.0 names (let ((data (unidata-name1+ *unicode-data*))) (update-index (file-position stm) index) (write-byte (1- (length (dictionary-cdbk data))) stm) @@ -549,10 +551,11 @@ (write-vector (dictionary-codev data) stm :endian-swap :network-order) (write-vector (dictionary-nextv data) stm :endian-swap :network-order) (write-vector (dictionary-namev data) stm :endian-swap :network-order)) + ;; 10. Codepoint to unicode-1.0 name (let ((data (unidata-name1 *unicode-data*))) (update-index (file-position stm) index) (write-ntrie32 data stm)) - ;; Normalization quick-check data + ;; 11. Normalization quick-check data (update-index (file-position stm) index) (let ((data (unidata-qc-nfd *unicode-data*))) (write-ntrie1 data stm)) @@ -562,35 +565,37 @@ (write-ntrie2 data stm)) (let ((data (unidata-qc-nfkc *unicode-data*))) (write-ntrie2 data stm)) - ;; Write composition exclusion table + ;; 12. Write composition exclusion table (let ((data (unidata-comp-exclusions *unicode-data*))) (update-index (file-position stm) index) (write16 (length data) stm) (write-vector data stm :endian-swap :network-order)) - ;; Write full-case lower data (flet ((dump-full-case (data) (update-index (file-position stm) index) (write-ntrie32 data stm) (write16 (length (full-case-tabl data)) stm) (write-vector (full-case-tabl data) stm :endian-swap :network-order))) + ;; 13. Write full-case lower data (dump-full-case (unidata-full-case-lower *unicode-data*)) + ;; 14. Write full-case title data (dump-full-case (unidata-full-case-title *unicode-data*)) + ;; 15. Write full-case upper data (dump-full-case (unidata-full-case-upper *unicode-data*))) - ;; Write case folding data + ;; 16. Write case-folding simple data (let ((data (unidata-case-fold-simple *unicode-data*))) (update-index (file-position stm) index) (write-ntrie32 data stm)) - ;; case-folding full + ;; 17. Write case-folding full data (let ((data (unidata-case-fold-full *unicode-data*))) (update-index (file-position stm) index) (write-ntrie32 data stm) (write16 (length (case-folding-tabl data)) stm) (write-vector (case-folding-tabl data) stm :endian-swap :network-order)) - ;; Word-break + ;; 18. Word-break (let ((data (unidata-word-break *unicode-data*))) (update-index (file-position stm) index) (write-ntrie4 data stm)) - ;; Patch up index + ;; All components saved. Patch up index table now. (file-position stm 8) (dotimes (i (length index)) (write32 (aref index i) stm)))))

1 0

[cmucl-cvs] CMUCL commit: RELEASE-20B-BRANCH src/contrib/asdf (asdf.lisp)
by Raymond Toy 17 Sep '10

17 Sep '10

Date: Friday, September 17, 2010 @ 19:29:22 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Tag: RELEASE-20B-BRANCH Modified: asdf.lisp Update to upstream asdf 2.008. -----------+ asdf.lisp | 48 ++++++++++++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 20 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.6.4.1 src/contrib/asdf/asdf.lisp:1.6.4.2 --- src/contrib/asdf/asdf.lisp:1.6.4.1 Thu Aug 26 09:14:13 2010 +++ src/contrib/asdf/asdf.lisp Fri Sep 17 19:29:22 2010 @@ -72,7 +72,7 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.007" (1+ (length "VERSION")))) ; same as 2.124 + (subseq "VERSION:2.008" (1+ (length "VERSION")))) ; same as 2.128 (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -176,6 +176,9 @@ :shadow ',shadow :unintern ',(append #-(or gcl ecl) redefined-functions unintern) :fmakunbound ',(append fmakunbound)))) + (let ((u (find-package :asdf-utilities))) + (when u + (ensure-unintern u (loop :for s :being :each :present-symbol :in u :collect s)))) (pkgdcl :asdf :use (:common-lisp) @@ -287,29 +290,29 @@ #:clear-source-registry #:ensure-source-registry #:process-source-registry + #:system-registered-p + #:asdf-message ;; Utilities #:absolute-pathname-p - #:aif - #:appendf - #:asdf-message + ;; #:aif #:it + ;; #:appendf #:coerce-name #:directory-pathname-p - #:ends-with + ;; #:ends-with #:ensure-directory-pathname #:getenv - #:get-uid - #:length=n-p + ;; #:get-uid + ;; #:length=n-p #:merge-pathnames* #:pathname-directory-pathname #:read-file-forms - #:remove-keys - #:remove-keyword + ;; #:remove-keys + ;; #:remove-keyword #:resolve-symlinks #:split-string #:component-name-to-pathname-components #:split-name-type - #:system-registered-p #:truenamize #:while-collecting))) (setf *asdf-version* asdf-version @@ -531,7 +534,7 @@ (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) - #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory)) + #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory)) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) @@ -740,7 +743,9 @@ '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>")) (defun* get-uid () #+allegro (excl.osi:getuid) - #+clisp (posix:uid) + #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") + :for f = (ignore-errors (read-from-string s)) + :when f :return (funcall f)) #+(or cmu scl) (unix:unix-getuid) #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601) '(ffi:c-inline () () :int "getuid()" :one-liner t) @@ -764,11 +769,13 @@ (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." - (and (pathnamep p) (not (wild-pathname-p p)) - #+(or allegro clozure cmu ecl sbcl scl) (probe-file p) - #+clisp (ext:probe-pathname p) - #-(or allegro clisp clozure cmu ecl sbcl scl) - (ignore-errors (truename p)))) + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) + #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p)) + '(ignore-errors (truename p))))))) (defun* truenamize (p) "Resolve as much of a pathname as possible" @@ -779,7 +786,7 @@ (when (typep p 'logical-pathname) (return p)) (let ((found (probe-file* p))) (when found (return found))) - #-sbcl (when (stringp directory) (return p)) + #-(or sbcl cmu) (when (stringp directory) (return p)) (when (not (eq :absolute (car directory))) (return p)) (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) @@ -857,7 +864,8 @@ error-name error-pathname error-condition duplicate-names-name error-component error-operation - module-components module-components-by-name) + module-components module-components-by-name + circular-dependency-components) (ftype (function (t t) t) (setf module-components-by-name))) @@ -1353,7 +1361,7 @@ ;; NOTE that the host and device slots will be taken from the defaults, ;; but that should only matter if you either (a) use absolute pathnames, or ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of - ;; ASDF-UTILITIES:MERGE-PATHNAMES* + ;; ASDF:MERGE-PATHNAMES* (etypecase name (pathname name)

1 0

[cmucl-cvs] CMUCL commit: src/code (exports.lisp unidata.lisp)
by Raymond Toy 17 Sep '10

17 Sep '10

Date: Friday, September 17, 2010 @ 19:29:01 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: exports.lisp unidata.lisp exports.lisp: o Export STRING-TO-NFC, UNICODE-COMPLETE, and UNICODE-COMPLETE-NAME. unidata.lisp: o Add explicit exports. --------------+ exports.lisp | 6 ++++-- unidata.lisp | 7 +++++-- 2 files changed, 9 insertions(+), 4 deletions(-) Index: src/code/exports.lisp diff -u src/code/exports.lisp:1.300 src/code/exports.lisp:1.301 --- src/code/exports.lisp:1.300 Tue Aug 3 23:41:51 2010 +++ src/code/exports.lisp Fri Sep 17 19:29:00 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.300 2010-08-04 03:41:51 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.301 2010-09-17 23:29:00 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -891,7 +891,9 @@ "STRING-TO-NFC" "CODEPOINT-LIMIT" "CODEPOINT") #+unicode - (:export "STRING-TO-NFD" "STRING-TO-NFKC" "STRING-TO-NFKD")) + (:export "STRING-TO-NFC" "STRING-TO-NFD" + "STRING-TO-NFKC" "STRING-TO-NFKD" + "UNICODE-COMPLETE" "UNICODE-COMPLETE-NAME")) (defpackage "EVAL" (:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*" Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.13 src/code/unidata.lisp:1.14 --- src/code/unidata.lisp:1.13 Fri Sep 17 18:41:26 2010 +++ src/code/unidata.lisp Fri Sep 17 19:29:01 2010 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.13 2010-09-17 22:41:26 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.14 2010-09-17 23:29:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -13,9 +13,12 @@ (in-package "LISP") (intl:textdomain "cmucl") +(export '(string-to-nfd string-to-nfkc string-to-nfkd string-to-nfc + unicode-complete unicode-complete-name)) + (defconstant +unidata-path+ #p"ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.13 $") +(defvar *unidata-version* "$Revision: 1.14 $") (defstruct unidata range

1 0

[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
by Raymond Toy 17 Sep '10

17 Sep '10

Date: Friday, September 17, 2010 @ 19:25:58 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Modified: asdf.lisp Update to upstream asdf 2.008. -----------+ asdf.lisp | 48 ++++++++++++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 20 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.7 src/contrib/asdf/asdf.lisp:1.8 --- src/contrib/asdf/asdf.lisp:1.7 Thu Aug 26 09:09:22 2010 +++ src/contrib/asdf/asdf.lisp Fri Sep 17 19:25:58 2010 @@ -72,7 +72,7 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.007" (1+ (length "VERSION")))) ; same as 2.124 + (subseq "VERSION:2.008" (1+ (length "VERSION")))) ; same as 2.128 (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -176,6 +176,9 @@ :shadow ',shadow :unintern ',(append #-(or gcl ecl) redefined-functions unintern) :fmakunbound ',(append fmakunbound)))) + (let ((u (find-package :asdf-utilities))) + (when u + (ensure-unintern u (loop :for s :being :each :present-symbol :in u :collect s)))) (pkgdcl :asdf :use (:common-lisp) @@ -287,29 +290,29 @@ #:clear-source-registry #:ensure-source-registry #:process-source-registry + #:system-registered-p + #:asdf-message ;; Utilities #:absolute-pathname-p - #:aif - #:appendf - #:asdf-message + ;; #:aif #:it + ;; #:appendf #:coerce-name #:directory-pathname-p - #:ends-with + ;; #:ends-with #:ensure-directory-pathname #:getenv - #:get-uid - #:length=n-p + ;; #:get-uid + ;; #:length=n-p #:merge-pathnames* #:pathname-directory-pathname #:read-file-forms - #:remove-keys - #:remove-keyword + ;; #:remove-keys + ;; #:remove-keyword #:resolve-symlinks #:split-string #:component-name-to-pathname-components #:split-name-type - #:system-registered-p #:truenamize #:while-collecting))) (setf *asdf-version* asdf-version @@ -531,7 +534,7 @@ (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) - #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory)) + #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory)) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) @@ -740,7 +743,9 @@ '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>")) (defun* get-uid () #+allegro (excl.osi:getuid) - #+clisp (posix:uid) + #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") + :for f = (ignore-errors (read-from-string s)) + :when f :return (funcall f)) #+(or cmu scl) (unix:unix-getuid) #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601) '(ffi:c-inline () () :int "getuid()" :one-liner t) @@ -764,11 +769,13 @@ (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." - (and (pathnamep p) (not (wild-pathname-p p)) - #+(or allegro clozure cmu ecl sbcl scl) (probe-file p) - #+clisp (ext:probe-pathname p) - #-(or allegro clisp clozure cmu ecl sbcl scl) - (ignore-errors (truename p)))) + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) + #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p)) + '(ignore-errors (truename p))))))) (defun* truenamize (p) "Resolve as much of a pathname as possible" @@ -779,7 +786,7 @@ (when (typep p 'logical-pathname) (return p)) (let ((found (probe-file* p))) (when found (return found))) - #-sbcl (when (stringp directory) (return p)) + #-(or sbcl cmu) (when (stringp directory) (return p)) (when (not (eq :absolute (car directory))) (return p)) (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) @@ -857,7 +864,8 @@ error-name error-pathname error-condition duplicate-names-name error-component error-operation - module-components module-components-by-name) + module-components module-components-by-name + circular-dependency-components) (ftype (function (t t) t) (setf module-components-by-name))) @@ -1353,7 +1361,7 @@ ;; NOTE that the host and device slots will be taken from the defaults, ;; but that should only matter if you either (a) use absolute pathnames, or ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of - ;; ASDF-UTILITIES:MERGE-PATHNAMES* + ;; ASDF:MERGE-PATHNAMES* (etypecase name (pathname name)

1 0