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

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

18 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 18 Sep '10

18 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 18 Sep '10

18 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

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

17 Sep '10

Date: Friday, September 17, 2010 @ 18:41:26 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: unidata.lisp Optimize the completion of the Hangul syllables and the CJK unified ideographs by using dictionaries. (Should these dictionaries be part of unidata.bin so they don't have to be built at run time? One the one hand, it makes things simpler, but unnecessarily bloats unidata.in. I suspect the hangul syllables and cjk ideographs characters not not used very often.) o Change NODE-NEXT and CLOSE-NODE to have an optional parameter for the dictionary to use. o Update UNICODE-COMPLETE-NAME to pass the dictionary to NODE-NEXT and CLOSE-NODE. o Update UNICODE-COMPLETE to use the hangul syllable dictionary and the cjk ideograph dictionary when searching. o Fix typo in UNICODE-COMPLETE. o Add defvars for dictionaries for hangul syllables and cjk ideographs. o Add functions to build the hangul and cjk dictionaries. o Steal the implementations of BUILD-DICTIONARY, NAME-LOOKUP, and ENCODE-NAME from tools/build-unidata.lisp. --------------+ unidata.lisp | 240 +++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 198 insertions(+), 42 deletions(-) Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.12 src/code/unidata.lisp:1.13 --- src/code/unidata.lisp:1.12 Fri Sep 17 11:59:45 2010 +++ src/code/unidata.lisp Fri Sep 17 18:41:26 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.12 2010-09-17 15:59:45 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.13 2010-09-17 22:41:26 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,7 +15,7 @@ (defconstant +unidata-path+ #p"ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.12 $") +(defvar *unidata-version* "$Revision: 1.13 $") (defstruct unidata range @@ -1112,17 +1112,20 @@ ;; ;; Code written by Paul Foley, with some modifications by Raymond Toy. ;; + +(defvar *hangul-syllable-dictionary* nil + "Dictionary of Hangul syllables") +(defvar *cjk-unified-ideograph-dictionary* nil + "Dictionary of CJK Unified ideographs") + +;; (defun unicode-complete-name (prefix &optional (dict (unidata-name+ *unicode-data*))) "Try to complete the string Prefix using the dictionary in Dict. Three values are returned: (1) The best match of prefix, (2) a list of possible completions, (3) a boolean indicating whether the best - match is a complete unicode name. - - The search is only done in the given dictionary so names that are - derived algorithmically like Hangul syllables and CJK Unified - Ideographs are not found." + match is a complete unicode name. " (unless dict ;; Load the names dictionary, if needed. @@ -1143,7 +1146,7 @@ ;; The prefix is an exact match to something in the code ;; book. Try to find possible completions of this ;; prefix. - (let ((x (node-next n)) + (let ((x (node-next n dict)) (suffix "")) #+(or debug-uc) (format t "init x = ~S~%" x) @@ -1154,7 +1157,7 @@ (format t "extending~%") (setq suffix (caar x) n (cdar x) - x (node-next (cdar x)))) + x (node-next (cdar x) dict))) #+(or debug-uc) (progn (format t "x = ~S~%" x) @@ -1172,7 +1175,7 @@ (t ;; The prefix was not an exact match of some entry in the ;; codebook. Try to find some completions from there. - (let* ((nodex (node-next n)) + (let* ((nodex (node-next n dict)) (x (remove-if-not (lambda (x) (%match (car x) prefix p)) nodex))) @@ -1186,7 +1189,7 @@ ;; the completions from there. (setq prefix (concatenate 'string prefix (caar x)) n (cdar x) - x (node-next (cdar x))) + x (node-next (cdar x) dict)) (values (%str prefix) (sort (mapcar #'%strx x) #'string<) (> (aref (dictionary-codev dict) n) -1))) @@ -1195,11 +1198,11 @@ ;; Try to extend each of those completions one ;; more step. (let* ((p (mapcan #'(lambda (ex) - (let ((next (node-next (cdr ex)))) + (let ((next (node-next (cdr ex) dict))) (if next (mapcar #'(lambda (n) (concatenate 'string (car ex) (car n))) - (node-next (cdr ex))) + (node-next (cdr ex) dict)) (list (car ex))))) x)) (q (%mip p))) @@ -1223,32 +1226,29 @@ (let (names) (cond ((search "Hangul_Syllable_" prefix) (initialize-reverse-hangul-tables) - ;; We should probably do something better than return all - ;; the possible matches, but this works. We remove the - ;; things that can't possibly match so that slime has less - ;; work. - (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 (format nil "Hangul_Syllable_~A~A~A" - (car choseong) - (car junseong) - (car jongseong)) - names)))) - ;; Remove things that can't have prefix as its prefix. - (setf names (delete-if-not #'(lambda (x) - (search prefix x :test #'char-equal)) - names))) + (unless *hangul-syllable-dictionary* + (build-hangul-syllable-dictionary)) + (multiple-value-bind (prefix-match next completep) + (unicode-complete-name (subseq prefix 16) + *hangul-syllable-dictionary*) + (loop for x in next + do (push (concatenate 'string "Hangul_Syllable_" prefix-match x) + names)) + (when completep + (push (concatenate 'string "Hangul_Syllable_" prefix-match) + names)))) ((search "Cjk_Unified_Ideograph-" prefix) - ;; We should do something better than this! There are a - ;; lot of completions here. - (setf names - (loop for x from #x4e00 upto #x9fff - collect (format nil "Cjk_Unified_Ideograph-~X" x))) - ;; Remove things that can't have prefix as its prefix. - (setf names (delete-if-not #'(lambda (x) - (search prefix x :test #'char-equal)) - names)))) + (unless *cjk-unified-ideograph-dictionary* + (build-cjk-unified-ideograph-dictionary)) + (multiple-value-bind (prefix-match next completep) + (unicode-complete-name (subseq prefix 22) + *cjk-unified-ideograph-dictionary*) + (loop for x in next + do (push (concatenate 'string "Cjk_Unified_Ideograph-" prefix-match x) + names)) + (when completep + (push (concatenate 'string "Cjk_Unified_Ideograph-" prefix-match) + names))))) (multiple-value-bind (prefix-match next completep) (unicode-complete-name prefix dict) (loop for x in next @@ -1260,7 +1260,7 @@ (search "Hangul_Syllable_" prefix-match :end1 (min 16 (length prefix-match)))) ;; Add syllable as possible completion (push "Hangul_Syllable_" names)) - ((or11111 ;;(string= prefix-match "Cjk_") + ((or ;;(string= prefix-match "Cjk_") (search "Cjk_Unified_Ideograph-" prefix-match :end1 (min 22 (length prefix-match)))) ;; Add Unified (push "Cjk_Unified_Ideograph-" names))) @@ -1293,16 +1293,17 @@ (setq posn (mismatch first string :end1 posn))) (subseq first 0 posn))) -(defun node-next (i &aux (dict (unidata-name+ *unicode-data*))) +(defun node-next (i &optional (dict (unidata-name+ *unicode-data*))) (let* ((j (aref (dictionary-nextv dict) i)) (x (ldb (byte 14 18) j)) (y (ldb (byte 18 0) j))) (loop for i from 0 below (aref (dictionary-keyl dict) x) collect (close-node (cons (aref (dictionary-cdbk dict) (aref (dictionary-keyv dict) (+ x i))) - (+ y i)))))) + (+ y i)) + dict)))) -(defun close-node (i &aux (dict (unidata-name+ *unicode-data*))) +(defun close-node (i &optional (dict (unidata-name+ *unicode-data*))) (loop (if (> (aref (dictionary-codev dict) (cdr i)) -1) (return i) @@ -1315,3 +1316,158 @@ (aref (dictionary-keyv dict) x)))) (setf (car i) (concatenate 'string (car i) k) (cdr i) y))))))) + +(defun build-hangul-syllable-dictionary () + "Build the dictionary for Hangul syllables" + (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))) + (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)))) + (setf *hangul-syllable-dictionary* + (build-dictionary hangul-codebook (nreverse names))))) + +(defun build-cjk-unified-ideograph-dictionary () + "Build the dictionary for CJK Unified Ideographs" + (let ((codebook (coerce (loop for k from 0 to 15 + collect (format nil "~X" k)) + 'vector)) + (names (loop for codepoint from 0 below codepoint-limit + when (cjk-ideograph-p codepoint) + collect (cons (format nil "~X" codepoint) + codepoint)))) + (setf *cjk-unified-ideograph-dictionary* + (build-dictionary codebook names)))) + +;; The definitions of BUILD-DICTIONARY, NAME-LOOKUP, and ENCODE-NAME +;; were taken from build-unidata.lisp. +(defun build-dictionary (codebook entries) + (let ((khash (make-hash-table :test 'equalp)) + (thash (make-hash-table)) + (top 0) + (keyl (make-array 0 :element-type '(unsigned-byte 8))) + (keyv (make-array 0 :element-type '(unsigned-byte 8))) + vec1 vec2 vec3) + (labels ((add-to-trie (trie name codepoint) + (loop for ch across (encode-name name codebook) do + (let ((sub (cdr (assoc ch (rest trie))))) + (if sub + (setq trie sub) + (setq trie (cdar (push (cons ch (cons nil nil)) + (rest trie))))))) + (unless (or (null (car trie)) (= (car trie) codepoint)) + (error "Codepoints #x~4,'0X and #x~4,'0X are both named ~S." + (car trie) codepoint name)) + (setf (car trie) codepoint)) + (key (trie) + (map '(simple-array (unsigned-byte 8) (*)) #'car (rest trie))) + (pass1 (trie depth) + (setf (rest trie) (sort (rest trie) #'< :key #'car)) + (setf (gethash trie thash) + (list depth (1- (incf top)) (length (rest trie)))) + (setf (gethash (key trie) khash) t) + (mapc (lambda (x) (pass1 (cdr x) (1+ depth))) (rest trie))) + (pass2 (trie) + (let* ((x (gethash (gethash trie thash) thash)) + (n (car x))) + (setf (aref vec1 n) (if (first trie) (first trie) -1) + (aref vec2 n) (logior (ash (gethash (key trie) khash) + 18) + (cdr x)))) + (mapc (lambda (x) (pass2 (cdr x))) (rest trie)))) + (format t "~& Initializing...~%") + (let ((trie (cons nil nil))) + (loop for (name . code) in entries do (add-to-trie trie name code)) + (format t "~& Pass 1...~%") + (pass1 trie 0) + (format t "~& Sorting...~%") + (dolist (key (sort (loop for k being the hash-keys of khash + collect k) + #'> :key #'length)) + (let ((pos -1)) + (loop + (setq pos (search key keyv :start2 (1+ pos))) + (when (and pos (zerop (aref keyl pos))) + (setf (aref keyl pos) (length key))) + (when (and pos (= (aref keyl pos) (length key))) + (setf (gethash key khash) pos) + (return)) + (when (null pos) + (setf (gethash key khash) (length keyv)) + (setf keyl (adjust-array keyl (+ (length keyv) (length key)))) + (setf (aref keyl (length keyv)) (length key)) + (setf keyv (concatenate '(simple-array (unsigned-byte 8) (*)) + keyv key)) + (return))))) + (loop with off = 1 + for key in (sort (loop for x being the hash-values of thash + collect x) + (lambda (a b) (if (= (first a) (first b)) + (< (second a) (second b)) + (< (first a) (first b))))) + as i upfrom 0 + do (setf (gethash key thash) (cons i off) off (+ off (third key)))) + (setq vec1 (make-array top :element-type '(signed-byte 32)) + vec2 (make-array top :element-type '(unsigned-byte 32)) + vec3 (make-array top :element-type '(unsigned-byte 32))) + (format t "~& Pass 2...~%") + (pass2 trie) + (format t "~& Finalizing~%") + (dotimes (i top) + (let ((xxx (aref vec2 i))) + (dotimes (j (aref keyl (ash xxx -18))) + (setf (aref vec3 (+ (logand xxx #x3FFFF) j)) i)))) + (loop for (name . code) in entries do + (let ((n (name-lookup name codebook keyv keyl vec2))) + (unless n (error "Codepoint not found for ~S." name)) + (setf (ldb (byte 14 18) (aref vec3 n)) (length name)))))) + (make-dictionary :cdbk codebook + :keyv keyv :keyl keyl + :codev vec1 :nextv vec2 :namev vec3))) + +(defun name-lookup (name codebook keyv keyl nextv) + (let* ((current 0) + (posn 0)) + (loop + (let ((keyp (ash (aref nextv current) -18))) + (dotimes (i (aref keyl keyp) + (return-from name-lookup nil)) ; shouldn't happen + (let* ((str (aref codebook (aref keyv (+ keyp i)))) + (len (length str))) + (when (and (>= (length name) (+ posn len)) + (string= name str :start1 posn :end1 (+ posn len))) + (setq current + (+ (logand (aref nextv current) #x3FFFF) i)) + (if (= (incf posn len) (length name)) + (return-from name-lookup current) + (return))))))))) + +(defun encode-name (string codebook) + (let ((p 0) + (res '())) + (loop while (< p (length string)) do + (dotimes (i (length codebook) + (error "\"~C\" is not in the codebook." (char string p))) + (let ((code (aref codebook i))) + (when (and (<= (length code) (- (length string) p)) + (string= string code :start1 p :end1 (+ p (length code)))) + (push i res) + (incf p (length code)) + (return))))) + (nreverse (coerce res 'vector))))

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 17 Sep '10

17 Sep '10

Date: Friday, September 17, 2010 @ 12:01:05 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Note addition of character name completion functions. -----------------+ release-20c.txt | 2 ++ 1 file changed, 2 insertions(+) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.2 src/general-info/release-20c.txt:1.3 --- src/general-info/release-20c.txt:1.2 Wed Sep 15 20:58:23 2010 +++ src/general-info/release-20c.txt Fri Sep 17 12:01:05 2010 @@ -22,6 +22,8 @@ * Feature enhancements: - Update to Unicode 5.2.0. + - Add support for character name completion. This can be used by + Slime to do character name completion. * ANSI compliance fixes:

1 0

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

17 Sep '10

Date: Friday, September 17, 2010 @ 11:59:45 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: unidata.lisp Add support for character completion. This is primarily intended to support character completion for slime. The implementation is from Paul Foley, but some slight modifications by Raymond Toy to handle a few corner cases. o Modify SEARCH-DICTIONARY to take optional current and posn parameters so that SEARCH-DICTIONARY can be started from a different place. o Add UNICODE-COMPLETE, which is the main function for character name completion. o Add other support functions for UNICODE-COMPLETE. --------------+ unidata.lisp | 301 +++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 260 insertions(+), 41 deletions(-) Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.11 src/code/unidata.lisp:1.12 --- src/code/unidata.lisp:1.11 Thu Sep 16 22:11:09 2010 +++ src/code/unidata.lisp Fri Sep 17 11:59:45 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.11 2010-09-17 02:11:09 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.12 2010-09-17 15:59:45 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,7 +15,7 @@ (defconstant +unidata-path+ #p"ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.11 $") +(defvar *unidata-version* "$Revision: 1.12 $") (defstruct unidata range @@ -290,42 +290,51 @@ -(defun search-dictionary (string dictionary) +(defun search-dictionary (string dictionary &optional (current 0) (posn 0)) + "Search the Unicode name dictionary for the longest entry that + matches STRING. STRING must be in Unicode name format. That is, it + must be upper case with spaces separating each word. + + Two values are returned. The first value is index into the codebook + that continues the string.. The second value is the length of the + substring of string that matches the codebook. " + (declare (optimize (speed 3) (space 0) (safety 0) (ext:inhibit-warnings 3)) - (type string string) (type dictionary dictionary)) + (type string string) (type dictionary dictionary) + (type (unsigned-byte 32) current) (type lisp::index posn)) (let* ((codebook (dictionary-cdbk dictionary)) - (current 0) - (posn 0) (stack '())) - (declare (type (unsigned-byte 32) current) (type lisp::index posn)) (loop - (let ((keyv (ash (aref (dictionary-nextv dictionary) current) -18))) - (dotimes (i (aref (dictionary-keyl dictionary) keyv) - (if stack - (let ((next (pop stack))) - (setq posn (car next) current (cdr next))) - (return-from search-dictionary nil))) - (let* ((str (aref codebook (aref (dictionary-keyv dictionary) - (+ keyv i)))) - (len (length str))) - (declare (type simple-base-string str)) - (when (and (>= (length string) (+ posn len)) - (string= string str :start1 posn :end1 (+ posn len))) - (setq current - (+ (logand (aref (dictionary-nextv dictionary) current) - #x3FFFF) - i)) - (when (= (incf posn len) (length string)) - (return-from search-dictionary current)) - (return)) ; from DOTIMES - loop again - (when (or (string= str " ") (string= str "-")) - (push (cons posn - (+ (logand (aref (dictionary-nextv dictionary) - current) + (let ((keyv (ash (aref (dictionary-nextv dictionary) current) -18))) + (dotimes (i (aref (dictionary-keyl dictionary) keyv) + (if stack + (let ((next (pop stack))) + (setq posn (car next) current (cdr next))) + (return-from search-dictionary nil))) + (let* ((str (aref codebook (aref (dictionary-keyv dictionary) + (+ keyv i)))) + (len (length str))) + (declare (type simple-base-string str)) + (cond ((and (>= (length string) (+ posn len)) + (string= string str :start1 posn :end1 (+ posn len))) + (setq current + (+ (logand (aref (dictionary-nextv dictionary) current) #x3FFFF) i)) - stack)))))))) + (when (= (incf posn len) (length string)) + (return-from search-dictionary (values current posn))) + (return)) ; from DOTIMES - loop again + ((and (< (length string) (+ posn len)) + (string= string str :start1 posn :end2 (- (length string) posn))) + (return-from search-dictionary (values current posn)))) + (when (or (string= str " ") (string= str "-")) + (push (cons posn + (+ (logand (aref (dictionary-nextv dictionary) + current) + #x3FFFF) + i)) + stack)))))))) (defun search-range (code range) (declare (optimize (speed 3) (space 0) (safety 0)) @@ -715,20 +724,22 @@ nil))) (t (unless (unidata-name+ *unicode-data*) (load-names)) - (let* ((names (unidata-name+ *unicode-data*)) - (n (search-dictionary name names))) - (when n - (let ((cp (aref (dictionary-codev names) n))) - (if (minusp cp) nil cp))))))) + (let* ((names (unidata-name+ *unicode-data*))) + (multiple-value-bind (n p) + (search-dictionary name names) + (when (and n (= p (length name))) + (let ((cp (aref (dictionary-codev names) n))) + (if (minusp cp) nil cp)))))))) (defun unicode-1.0-name-to-codepoint (name) (declare (type string name)) (unless (unidata-name1+ *unicode-data*) (load-1.0-names)) - (let* ((names (unidata-name1+ *unicode-data*)) - (n (search-dictionary name names))) - (when n - (let ((cp (aref (dictionary-codev names) n))) - (if (minusp cp) nil cp))))) + (let* ((names (unidata-name1+ *unicode-data*))) + (multiple-value-bind (n p) + (search-dictionary name names) + (when (and n (= p (length name))) + (let ((cp (aref (dictionary-codev names) n))) + (if (minusp cp) nil cp)))))) (defun unicode-name+ (code ntrie dict) @@ -1096,3 +1107,211 @@ :katakana :aletter :midnumlet :midletter :midnum :numeric :extendnumlet) (unicode-word-break-code code))) + +;; Support for character name completion for slime. +;; +;; Code written by Paul Foley, with some modifications by Raymond Toy. +;; +(defun unicode-complete-name (prefix + &optional (dict (unidata-name+ + *unicode-data*))) + "Try to complete the string Prefix using the dictionary in Dict. + Three values are returned: (1) The best match of prefix, (2) a list + of possible completions, (3) a boolean indicating whether the best + match is a complete unicode name. + + The search is only done in the given dictionary so names that are + derived algorithmically like Hangul syllables and CJK Unified + Ideographs are not found." + + (unless dict + ;; Load the names dictionary, if needed. + (unless (unidata-name+ *unicode-data*) + (load-names)) + (setf dict (unidata-name+ *unicode-data*))) + (let ((prefix (nsubstitute #\Space #\_ (string-upcase prefix))) + completep) + (multiple-value-bind (n p) + (search-dictionary prefix dict) + (when n + (setq completep (> (aref (dictionary-codev dict) n) -1))) + #+(or debug-uc) + (format t "n,p,complete = ~S ~S ~S~%" n p completep) + (cond ((not p) + (values (%str prefix) nil nil)) + ((= p (length prefix)) + ;; The prefix is an exact match to something in the code + ;; book. Try to find possible completions of this + ;; prefix. + (let ((x (node-next n)) + (suffix "")) + #+(or debug-uc) + (format t "init x = ~S~%" x) + (when (= (length x) 1) + ;; There was only one possible extension. Try to + ;; extend from there. + #+(or debug-uc) + (format t "extending~%") + (setq suffix (caar x) + n (cdar x) + x (node-next (cdar x)))) + #+(or debug-uc) + (progn + (format t "x = ~S~%" x) + (format t "suffix = ~S~%" suffix)) + (when (<= (length x) 1) + (setq prefix (concatenate 'string prefix suffix)) + (setf suffix "")) + (values (%str prefix) + (sort (mapcar #'(lambda (e) + (%str (concatenate 'string suffix (car e)))) + x) + #'string<) + (or (> (aref (dictionary-codev dict) n) -1) + completep)))) + (t + ;; The prefix was not an exact match of some entry in the + ;; codebook. Try to find some completions from there. + (let* ((nodex (node-next n)) + (x (remove-if-not (lambda (x) + (%match (car x) prefix p)) + nodex))) + #+(or debug-uc) + (progn + (format t "nodex = ~S~%" nodex) + (format t "x = ~S~%" x)) + (setq prefix (subseq prefix 0 p)) + (cond ((= (length x) 1) + ;; Only one possible completion. Try to extend + ;; the completions from there. + (setq prefix (concatenate 'string prefix (caar x)) + n (cdar x) + x (node-next (cdar x))) + (values (%str prefix) + (sort (mapcar #'%strx x) #'string<) + (> (aref (dictionary-codev dict) n) -1))) + (t + ;; There's more than one possible completion. + ;; Try to extend each of those completions one + ;; more step. + (let* ((p (mapcan #'(lambda (ex) + (let ((next (node-next (cdr ex)))) + (if next + (mapcar #'(lambda (n) + (concatenate 'string (car ex) (car n))) + (node-next (cdr ex))) + (list (car ex))))) + x)) + (q (%mip p))) + (setq prefix (concatenate 'string prefix q)) + + (do ((tmp p (cdr tmp))) + ((endp tmp)) + (setf (car tmp) (subseq (car tmp) (length q)))) + (values (%str prefix) + (sort (mapcar #'%str p) #'string<) + nil)))))))))) + +;; Like unicode-complete-name, but we also try to handle the names +;; that can be computed algorithmically like the Hangul syllables and +;; the CJK Unified Ideographs. +(defun unicode-complete (prefix + &optional (dict (unidata-name+ *unicode-data*))) + "Search the dictionary in Dict and return a list of the possible + completions starting with Prefix. If there is no match, NIL is + returned." + (let (names) + (cond ((search "Hangul_Syllable_" prefix) + (initialize-reverse-hangul-tables) + ;; We should probably do something better than return all + ;; the possible matches, but this works. We remove the + ;; things that can't possibly match so that slime has less + ;; work. + (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 (format nil "Hangul_Syllable_~A~A~A" + (car choseong) + (car junseong) + (car jongseong)) + names)))) + ;; Remove things that can't have prefix as its prefix. + (setf names (delete-if-not #'(lambda (x) + (search prefix x :test #'char-equal)) + names))) + ((search "Cjk_Unified_Ideograph-" prefix) + ;; We should do something better than this! There are a + ;; lot of completions here. + (setf names + (loop for x from #x4e00 upto #x9fff + collect (format nil "Cjk_Unified_Ideograph-~X" x))) + ;; Remove things that can't have prefix as its prefix. + (setf names (delete-if-not #'(lambda (x) + (search prefix x :test #'char-equal)) + names)))) + (multiple-value-bind (prefix-match next completep) + (unicode-complete-name prefix dict) + (loop for x in next + do (push (concatenate 'string prefix-match x) names)) + (when completep + (push prefix-match names)) + ;; Match prefix against Hangul and/or Hangul_syllable + (cond ((or (string= prefix-match "Hangul_") + (search "Hangul_Syllable_" prefix-match :end1 (min 16 (length prefix-match)))) + ;; Add syllable as possible completion + (push "Hangul_Syllable_" names)) + ((or11111 ;;(string= prefix-match "Cjk_") + (search "Cjk_Unified_Ideograph-" prefix-match :end1 (min 22 (length prefix-match)))) + ;; Add Unified + (push "Cjk_Unified_Ideograph-" names))) + (setf names (mapcar #'string-capitalize names)) + ;;(format t "Final names = ~S~%" names) + names))) + +;; Convert the string into the form we want for character names. +(defun %str (x) + (nsubstitute #\_ #\Space (string-capitalize x))) + +(defun %strx (x) + (%str (car x))) + +#+(or) +(defun %match (part prefix posn) + (and (>= (length part) (- (length prefix) posn)) + (string= part prefix :start2 posn :end1 (- (length prefix) posn)))) + +(defun %match (part prefix posn) + (let ((s1 (search part prefix :start2 posn)) + (s2 (search prefix part :start1 posn))) + (or (and s1 (= s1 posn)) + (and s2 (zerop s2))))) + +(defun %mip (strings) + (let* ((first (first strings)) + (posn (length first))) + (dolist (string (rest strings)) + (setq posn (mismatch first string :end1 posn))) + (subseq first 0 posn))) + +(defun node-next (i &aux (dict (unidata-name+ *unicode-data*))) + (let* ((j (aref (dictionary-nextv dict) i)) + (x (ldb (byte 14 18) j)) + (y (ldb (byte 18 0) j))) + (loop for i from 0 below (aref (dictionary-keyl dict) x) + collect (close-node (cons (aref (dictionary-cdbk dict) + (aref (dictionary-keyv dict) (+ x i))) + (+ y i)))))) + +(defun close-node (i &aux (dict (unidata-name+ *unicode-data*))) + (loop + (if (> (aref (dictionary-codev dict) (cdr i)) -1) + (return i) + (let* ((j (aref (dictionary-nextv dict) (cdr i))) + (x (ldb (byte 14 18) j)) + (y (ldb (byte 18 0) j))) + (if (> (aref (dictionary-keyl dict) x) 1) + (return i) + (let ((k (aref (dictionary-cdbk dict) + (aref (dictionary-keyv dict) x)))) + (setf (car i) (concatenate 'string (car i) k) + (cdr i) y)))))))

1 0

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

16 Sep '10

Date: Thursday, September 16, 2010 @ 22:11:10 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: unidata.lisp o Fix typo in UNICODE-DECOMP. (It's hangul-syllable-p, not hangule-syllable-p.) o Move the computation of *reverse-hangule-choseong*, *reverse-hangul-jungseong*, and *reverse-hangul-jongseong* to its own routine. Call it in UNICODE-NAME-TO-CODEPOINT. --------------+ unidata.lisp | 47 +++++++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 22 deletions(-) Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.10 src/code/unidata.lisp:1.11 --- src/code/unidata.lisp:1.10 Wed Sep 15 19:32:06 2010 +++ src/code/unidata.lisp Thu Sep 16 22:11:09 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.10 2010-09-15 23:32:06 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.11 2010-09-17 02:11:09 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,7 +15,7 @@ (defconstant +unidata-path+ #p"ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.10 $") +(defvar *unidata-version* "$Revision: 1.11 $") (defstruct unidata range @@ -649,6 +649,27 @@ ;; the values here. (<= #xAC00 code #xD7A3)) +(defun initialize-reverse-hangul-tables () + (unless (boundp '*reverse-hangul-choseong*) + (setq *reverse-hangul-choseong* + (sort (coerce (loop for x across +hangul-choseong+ + as i upfrom 0 by 588 + collect (cons x i)) + 'vector) + #'> :key (lambda (x) (length (car x))))) + (setq *reverse-hangul-jungseong* + (sort (coerce (loop for x across +hangul-jungseong+ + as i upfrom 0 by 28 + collect (cons x i)) + 'vector) + #'> :key (lambda (x) (length (car x))))) + (setq *reverse-hangul-jongseong* + (sort (coerce (loop for x across +hangul-jongseong+ + as i upfrom 1 + collect (cons x i)) + 'vector) + #'> :key (lambda (x) (length (car x))))))) + (defun unicode-name-to-codepoint (name) (declare (type string name)) (cond ((and (> (length name) 22) @@ -669,25 +690,7 @@ :start (+ x 8))) (ll nil) (vv nil) (tt 0)) (unless n (return-from unicode-name-to-codepoint nil)) - (unless (boundp '*reverse-hangul-choseong*) - (setq *reverse-hangul-choseong* - (sort (coerce (loop for x across +hangul-choseong+ - as i upfrom 0 by 588 - collect (cons x i)) - 'vector) - #'> :key (lambda (x) (length (car x))))) - (setq *reverse-hangul-jungseong* - (sort (coerce (loop for x across +hangul-jungseong+ - as i upfrom 0 by 28 - collect (cons x i)) - 'vector) - #'> :key (lambda (x) (length (car x))))) - (setq *reverse-hangul-jongseong* - (sort (coerce (loop for x across +hangul-jongseong+ - as i upfrom 1 - collect (cons x i)) - 'vector) - #'> :key (lambda (x) (length (car x)))))) + (initialize-reverse-hangul-tables) (loop for (x . y) across *reverse-hangul-choseong* when (and (<= (+ n (length x)) (length name)) (string= name x :start1 n :end1 (+ n (length x)))) @@ -863,7 +866,7 @@ (defun unicode-decomp (code &optional (compatibility t)) (declare (optimize (speed 3) (space 0) (safety 0)) (type codepoint code)) - (if (hangule-syllable-p code) + (if (hangul-syllable-p code) ;; Hangul syllables. (See ;; http://www.unicode.org/reports/tr15/#Hangul for the ;; algorithm.)

1 0

[cmucl-cvs] CMUCL commit: RELEASE-20B-BRANCH src/i18n/locale (2 files)
by Raymond Toy 15 Sep '10

15 Sep '10

Date: Wednesday, September 15, 2010 @ 23:38:42 Author: rtoy Path: /project/cmucl/cvsroot/src/i18n/locale Tag: RELEASE-20B-BRANCH Modified: en(a)piglatin/LC_MESSAGES/cmucl.po ko/LC_MESSAGES/cmucl.po Regenerate. ----------------------------------+ en(a)piglatin/LC_MESSAGES/cmucl.po | 14 ------- ko/LC_MESSAGES/cmucl.po | 65 +++++++++++++++++++++++++++---------- 2 files changed, 48 insertions(+), 31 deletions(-) Index: src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po diff -u src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po:1.8.2.2 src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po:1.8.2.3 --- src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po:1.8.2.2 Wed Sep 15 12:16:44 2010 +++ src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po Wed Sep 15 23:38:40 2010 @@ -5688,20 +5688,6 @@ "ormalizednay, ethay originalway\n" " ingstray isway eturnedray." -#: src/code/string.lisp -msgid "" -"Convert a sequence of codepoints to a string. Codepoints outside\n" -" the basic multilingual plane (BMP) are converted into the\n" -" corresponding surrogate pairs." -msgstr "" - -#: src/code/string.lisp -msgid "" -"Convert a string to a list of corresponding code points. Surrogate\n" -" pairs in the string are converted into the correspoinding\n" -" codepoint." -msgstr "" - #: src/code/mipsstrops.lisp msgid "" "Compares the substrings specified by String1 and String2 and returns\n" Index: src/i18n/locale/ko/LC_MESSAGES/cmucl.po diff -u src/i18n/locale/ko/LC_MESSAGES/cmucl.po:1.9 src/i18n/locale/ko/LC_MESSAGES/cmucl.po:1.9.2.1 --- src/i18n/locale/ko/LC_MESSAGES/cmucl.po:1.9 Mon Jul 19 17:46:43 2010 +++ src/i18n/locale/ko/LC_MESSAGES/cmucl.po Wed Sep 15 23:38:41 2010 @@ -2357,6 +2357,10 @@ msgstr "" #: src/code/array.lisp +msgid "If non-NIL, print some debugging information when GC'ing static arrays" +msgstr "" + +#: src/code/array.lisp msgid "~&Freeing foreign vector at #x~X~%" msgstr "" @@ -8941,8 +8945,31 @@ " the length of String). If the string is not large enough to hold\n" " all of characters, then some octets will not be converted. A State\n" " may also be specified; this is used as the state of the external\n" +" format. An error method may also be specified by Error, which\n" +" defaults to NIL to mean the default handling of conversion errors is\n" +" done.\n" +"\n" +" Four values are returned: the string, the position of where the next\n" +" character would be read into the string, the number of octets\n" +" actually consumed and the new state of the external format." +msgstr "" + +#: src/code/extfmts.lisp +msgid "" +"Octets-to-string converts an array of octets in Octets to a string\n" +" according to the specified External-format. The array of octets is\n" +" bounded by Start (defaulting ot 0) and End (defaulting to the end of\n" +" the array. If String is not given, a new string is created. If\n" +" String is given, the converted octets are stored in String, starting\n" +" at S-Start (defaulting to the 0) and ending at S-End (defaulting to\n" +" the length of String). If the string is not large enough to hold\n" +" all of characters, then some octets will not be converted. A State\n" +" may also be specified; this is used as the state of the external\n" " format.\n" "\n" +" In Ocount, the number of octets read for each character in the\n" +" string is saved\n" +"\n" " Four values are returned: the string, the number of characters read,\n" " the number of octets actually consumed and the new state of the\n" " external format." @@ -9190,19 +9217,23 @@ " :external-format - an external format name\n" " :decoding-error - How to handle decoding errors from the external " "format.\n" -" Should be a symbol or function of 3 arguments. If " -"it\n" -" returns, it should return a code point to use as the\n" -" replacment. NIL means use the default replacement " -"scheme\n" -" specified by the external format. The function " -"arguments\n" -" are a format message string, the offending octet, and " -"the\n" -" number of octets read in the current encoding. \n" +" If a character, then that character is used as\n" +" the replacment character for all errors. If T,\n" +" then a continuable error is signaled. If\n" +" continued, the Unicode replacement character is\n" +" used. Otherwise, it should be a symbol or\n" +" function of 3 arguments. If it returns, it\n" +" should return a code point to use as the\n" +" replacment. The function arguments are a\n" +" format message string, the offending octet, and\n" +" the number of octets read in the current\n" +" encoding.\n" " :encoding-error - Like :decoding-error, but for errors when encoding the\n" -" stream. The function arguments are a format message\n" -" string and the incorrect codepoint.\n" +" stream. If a character, that character is used\n" +" as the replacment code point. Otherwise, it\n" +" should be a symbol or function oof two\n" +" arguments: a format message string and the\n" +" incorrect codepoint.\n" "\n" " See the manual for details." msgstr "" @@ -9264,23 +9295,23 @@ msgid "Setting external-format on Gray streams not supported." msgstr "" -#: src/code/fd-stream-extfmt.lisp +#: src/code/fd-stream-comp.lisp msgid "Surrogate codepoint #x~~4,'0X is illegal for ~A" msgstr "" -#: src/code/fd-stream-extfmt.lisp +#: src/code/fd-stream-comp.lisp msgid "Illegal codepoint on input: #x~X" msgstr "" -#: src/code/fd-stream-extfmt.lisp +#: src/code/fd-stream-comp.lisp msgid "Cannot output codepoint #x~X to ISO8859-1 stream" msgstr "" -#: src/code/fd-stream-extfmt.lisp +#: src/code/fd-stream-comp.lisp msgid "Cannot convert invalid surrogate #x~X to character" msgstr "" -#: src/code/fd-stream-extfmt.lisp +#: src/code/fd-stream-comp.lisp msgid "Cannot convert lone trailing surrogate #x~X to character" msgstr ""

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www (support.html)
by Raymond Toy 15 Sep '10

15 Sep '10

Date: Wednesday, September 15, 2010 @ 22:45:16 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www Modified: support.html Add link to the cmucl commit logs. --------------+ support.html | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) Index: cmucl-www/cmucl-www/www/support.html diff -u cmucl-www/cmucl-www/www/support.html:1.3 cmucl-www/cmucl-www/www/support.html:1.4 --- cmucl-www/cmucl-www/www/support.html:1.3 Mon Jan 19 10:05:16 2009 +++ cmucl-www/cmucl-www/www/support.html Wed Sep 15 22:45:16 2010 @@ -77,7 +77,10 @@ <dd> <p> is a mailing list that receives notifications of commits to the CMUCL CVS tree. This is intended primarily for developers, but may be of - interest to users who wish to follow development. </p> + interest to users who wish to follow development. There is also + an <a href=http://common-lisp.net/pipermail/cmucl-cvs/>archive</a> + of the commit messages. This archive only has messages starting + from Sept, 2010, however.</p> </dl>

1 0

[cmucl-cvs] CMUCL commit: src (lisp/GNUmakefile tools/make-extra-dist.sh)
by Raymond Toy 15 Sep '10

15 Sep '10

Date: Wednesday, September 15, 2010 @ 22:29:38 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: lisp/GNUmakefile tools/make-extra-dist.sh lisp/GNUmakefile: o Don't overwrite the CVS po file with the merged version; the merged version is written to the build directory. o The mo file is created from the merged version in the build directory. o Compare the newly merged version with the original CVS version and print a message if they are different. (Sort the files first to remove any issues with order of the various fields. It is known that the versions of msgmerge on FreeBSD and Mac OS X will put the Language line in different places. tools/make-extra-dist.sh: o Be sure to install the po file from the build directory and not the source directory. (But do we really need to distribute the po files?) --------------------------+ lisp/GNUmakefile | 23 +++++++++++++++++++---- tools/make-extra-dist.sh | 6 +++--- 2 files changed, 22 insertions(+), 7 deletions(-) Index: src/lisp/GNUmakefile diff -u src/lisp/GNUmakefile:1.37 src/lisp/GNUmakefile:1.38 --- src/lisp/GNUmakefile:1.37 Thu Jul 29 00:28:49 2010 +++ src/lisp/GNUmakefile Wed Sep 15 22:29:37 2010 @@ -1,4 +1,4 @@ -# $Header: /project/cmucl/cvsroot/src/lisp/GNUmakefile,v 1.37 2010-07-29 04:28:49 rtoy Exp $ +# $Header: /project/cmucl/cvsroot/src/lisp/GNUmakefile,v 1.38 2010-09-16 02:29:37 rtoy Exp $ all: lisp.nm @@ -74,16 +74,31 @@ # Convert locale names to the appropriate path where we want the mo files to go. LOCALE_DIRS = $(patsubst %, i18n/locale/%/LC_MESSAGES, $(LOCALES)) +# When processing the translations, we merge the po file from the src +# directory with the appropriate pot file. The result is placed in +# the build directory. Then we compare the original po file with the +# newly generated one (but sorting both before comparing). If they +# are different we print out a note so that we know to look into it +# and decide if the po file in the src directory needs to be updated. +# +# The sorting is done so that differences in order of the lines is not +# important. In particular, msgmerge on OSX wants to put the +# Language: line after the Content-Transfer-Encoding line. But on +# FreeBSD, it moves the line to after the Language-Team line. This +# makes things messy. Hence, sort and diff. translations: for pot in ../../src/i18n/locale/*.pot; do \ for po in $(LOCALE_DIRS); do \ d=`dirname $$pot`; \ f=`basename $$pot .pot`; \ - touch ../../src/$$po/$$f.po; \ echo ; \ echo '***' Processing $$f.pot: $$po; \ - msgmerge -v ../../src/$$po/$$f.po $$pot -o ../../src/$$po/$$f.po; \ - msgfmt -v ../../src/$$po/$$f.po -o ../$$po/$$f.mo; \ + msgmerge -v ../../src/$$po/$$f.po $$pot -o ../$$po/$$f.po; \ + msgfmt -v ../$$po/$$f.po -o ../$$po/$$f.mo; \ + sort < ../$$po/$$f.po > /tmp/$$$$-updated-$$f.po; \ + sort < ../../src/$$po/$$f.po > /tmp/$$$$-orig-$$f.po; \ + diff -uwB /tmp/$$$$-orig-$$f.po /tmp/$$$$-updated-$$f.po || echo "Warning: $$po/$$f.po changed"; \ + rm -f /tmp/$$$$-updated-$$f.po /tmp/$$$$-orig-$$f.po; \ done; done .PHONY : translations Index: src/tools/make-extra-dist.sh diff -u src/tools/make-extra-dist.sh:1.12 src/tools/make-extra-dist.sh:1.13 --- src/tools/make-extra-dist.sh:1.12 Mon Jul 5 16:32:33 2010 +++ src/tools/make-extra-dist.sh Wed Sep 15 22:29:37 2010 @@ -121,12 +121,12 @@ install ${GROUP} ${OWNER} -m 0644 $TARGET/i18n/$f $DESTDIR/lib/cmucl/lib/$DIR done -# Install po files -for f in `(cd src/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')` +# Install po files. (Do we really need to distribute the po files?) +for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')` do FILE=`basename $f` DIR=`dirname $f` - install ${GROUP} ${OWNER} -m 0644 src/i18n/$f $DESTDIR/lib/cmucl/lib/$DIR + install ${GROUP} ${OWNER} -m 0644 $TARGET/i18n/$f $DESTDIR/lib/cmucl/lib/$DIR done if [ -z "$INSTALL_DIR" ]; then

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 15 Sep '10

15 Sep '10

Date: Wednesday, September 15, 2010 @ 20:58:23 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt o Unicode 5.2.0 o Bug fix for pairwise composition table. -----------------+ release-20c.txt | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.1 src/general-info/release-20c.txt:1.2 --- src/general-info/release-20c.txt:1.1 Wed Sep 15 20:33:36 2010 +++ src/general-info/release-20c.txt Wed Sep 15 20:58:23 2010 @@ -21,11 +21,16 @@ * Known issues: * Feature enhancements: + - Update to Unicode 5.2.0. * ANSI compliance fixes: * Bugfixes: - + - The pairwise composition table is now correctly built. + Previously, it skipped over non-BMP codepoints. This also + requires a fix in %COMPOSE to handle non-BMP codepoints + correctly. The normalization test now passes. + * Trac Tickets: * Other changes: @@ -42,4 +47,3 @@ We hope you enjoy using this release of CMUCL! -

1 0

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

15 Sep '10

Date: Wednesday, September 15, 2010 @ 20:43:33 Author: rtoy Path: /project/cmucl/cvsroot/src/tools Modified: build.sh Remove redundant setting of MAKE_TARGET. (Noted by Alex.) ----------+ build.sh | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) Index: src/tools/build.sh diff -u src/tools/build.sh:1.33 src/tools/build.sh:1.34 --- src/tools/build.sh:1.33 Wed Sep 15 19:59:39 2010 +++ src/tools/build.sh Wed Sep 15 20:43:33 2010 @@ -32,7 +32,7 @@ # # For more information see src/BUILDING. # -# $Header: /project/cmucl/cvsroot/src/tools/build.sh,v 1.33 2010-09-15 23:59:39 rtoy Exp $ +# $Header: /project/cmucl/cvsroot/src/tools/build.sh,v 1.34 2010-09-16 00:43:33 rtoy Exp $ # ENABLE2="yes" @@ -190,7 +190,6 @@ buildit TARGET=$BASE-4 -MAKE_TARGET="all" CLEAN_FLAGS="-K all" OLDLISP="${BASE}-3/lisp/lisp -noinit $FPU_MODE" ENABLE=$ENABLE4

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 15 Sep '10

15 Sep '10

Date: Wednesday, September 15, 2010 @ 20:33:36 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Added: release-20c.txt Initial version. -----------------+ release-20c.txt | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) Index: src/general-info/release-20c.txt diff -u /dev/null src/general-info/release-20c.txt:1.1 --- /dev/null Wed Sep 15 20:33:36 2010 +++ src/general-info/release-20c.txt Wed Sep 15 20:33:36 2010 @@ -0,0 +1,45 @@ +========================== C M U C L 20 c ============================= + +[--- WORK IN PROGRESS ---] + +The CMUCL project is pleased to announce the release of CMUCL 20c. +This is a major release which contains numerous enhancements and +bug fixes from the 20b release. + +CMUCL is a free, high performance implementation of the Common Lisp +programming language which runs on most major Unix platforms. It +mainly conforms to the ANSI Common Lisp standard. CMUCL provides a +sophisticated native code compiler; a powerful foreign function +interface; an implementation of CLOS, the Common Lisp Object System, +which includes multi-methods and a meta-object protocol; a source-level +debugger and code profiler; and an Emacs-like editor implemented in +Common Lisp. CMUCL is maintained by a team of volunteers collaborating +over the Internet, and is mostly in the public domain. + +New in this release: + + * Known issues: + + * Feature enhancements: + + * ANSI compliance fixes: + + * Bugfixes: + + * Trac Tickets: + + * Other changes: + + * Improvements to the PCL implementation of CLOS: + + * Changes to building procedure: + +This release is not binary compatible with code compiled using CMUCL +20b; you will need to recompile FASL files. + +See <URL:http://www.cons.org/cmucl/> for download information, +guidelines on reporting bugs, and mailing list details. + + +We hope you enjoy using this release of CMUCL! +

1 0

[cmucl-cvs] CVS src
by rtoy 15 Sep '10

15 Sep '10

Update of /project/cmucl/cvsroot/src In directory cl-net:/tmp/cvs-serv27362 Modified Files: BUILDING Log Message: Add note about using -crl for cross-build-world.sh to combine some steps. (And test cmucl-cvs at common-lisp.net.) --- /project/cmucl/cvsroot/src/BUILDING 2010/08/01 14:33:45 1.22 +++ /project/cmucl/cvsroot/src/BUILDING 2010/09/16 00:13:01 1.23 @@ -669,4 +669,9 @@ good at this point too. Some of the details for each command may have changed; You can get -help for each command by using the -h argument. \ No newline at end of file +help for each command by using the -h argument. + +In particular steps 3, 4, and 5 can be combined into one by using the +-c, -r, and -l options for cross-build-world.sh. The -c option cleans +out the targe and cross directories; -r does step 4; and -l does step +5.

1 0