cmucl-cvs

cmucl-cvs@common-lisp.net

2904 discussions

Start a nNew thread

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-30-ge7900f2
by Raymond Toy 04 Feb '12

04 Feb '12

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-29-gca2a2a4
by Raymond Toy 04 Feb '12

04 Feb '12

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-28-gd6cb31e
by Raymond Toy 04 Feb '12

04 Feb '12

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-27-gce8d55d
by Raymond Toy 01 Feb '12

01 Feb '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via ce8d55de55c26673c07c985bc21db14c2e2652b5 (commit) from 944c67fb1ed7eec21d223d3c82748ddd968cab61 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit ce8d55de55c26673c07c985bc21db14c2e2652b5 Author: Raymond Toy <rtoy(a)google.com> Date: Wed Feb 1 09:13:24 2012 -0800 Move common unicode fasl fops from the main ppc and sparc cross scripts to its own file so that they can be shared. diff --git a/src/tools/cross-scripts/cross-unicode-big-endian.lisp b/src/tools/cross-scripts/cross-unicode-big-endian.lisp new file mode 100644 index 0000000..74fffbb --- /dev/null +++ b/src/tools/cross-scripts/cross-unicode-big-endian.lisp @@ -0,0 +1,93 @@ +;; Common parts for cross-compiling from a little-ending machine to a +;; big-endian machine like sparc or ppc. Basically, we need to adjust +;; the fops that deal with strings (like symbols and strings). The +;; strings in the fasls are written in the target byte order, but the +;; compiling system (little-endian) needs to be able to read them back +;; in correctly to create kernel.core. + +(in-package "VM") +;; Define char-bytes. Don't know why this isn't defined for the new +;; backend on sparc and ppc. +(defconstant char-bytes #+unicode 2 #-unicode 1) +(export 'char-bytes) +(in-package "CL-USER") + +(in-package "LISP") +;; We need the the fops if the cross-compiled fasl file is in +;; big-endian order. When we read in a string, we need to +;; convert the big-endian string to little-endian for x86 so we can +;; process the symbols and such as expected. +#+unicode +(progn +(defun maybe-swap-string (f name &optional (len (length name))) + (declare (ignorable f)) + (unless (eq (c:backend-byte-order c:*backend*) + (c:backend-byte-order c:*native-backend*)) + (dotimes (k len) + (let ((code (char-code (aref name k)))) + (setf (aref name k) + (code-char (logior (ash (ldb (byte 8 0) code) 8) + (ldb (byte 8 8) code)))))) + ;;(format t "~S: new name = ~S~%" f (subseq name 0 len)) + name)) + +(macrolet ((frob (name code name-size package) + (let ((n-package (gensym "PACKAGE-")) + (n-size (gensym "SIZE-")) + (n-buffer (gensym "BUFFER-")) + (k (gensym "IDX-"))) + `(define-fop (,name ,code) + (prepare-for-fast-read-byte *fasl-file* + (let ((,n-package ,package) + (,n-size (fast-read-u-integer ,name-size))) + (when (> ,n-size *load-symbol-buffer-size*) + (setq *load-symbol-buffer* + (make-string (setq *load-symbol-buffer-size* + (* ,n-size vm:char-bytes))))) + (done-with-fast-read-byte) + (let ((,n-buffer *load-symbol-buffer*)) + (read-n-bytes *fasl-file* ,n-buffer 0 + (* old-vm:char-bytes ,n-size)) + (maybe-swap-string ',name ,n-buffer ,n-size) + (push-table (intern* ,n-buffer ,n-size ,n-package))))))))) + (frob fop-symbol-save 6 4 *package*) + (frob fop-small-symbol-save 7 1 *package*) + (frob fop-lisp-symbol-save 75 4 *lisp-package*) + (frob fop-lisp-small-symbol-save 76 1 *lisp-package*) + (frob fop-keyword-symbol-save 77 4 *keyword-package*) + (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) + + (frob fop-symbol-in-package-save 8 4 + (svref *current-fop-table* (fast-read-u-integer 4))) + (frob fop-small-symbol-in-package-save 9 1 + (svref *current-fop-table* (fast-read-u-integer 4))) + (frob fop-symbol-in-byte-package-save 10 4 + (svref *current-fop-table* (fast-read-u-integer 1))) + (frob fop-small-symbol-in-byte-package-save 11 1 + (svref *current-fop-table* (fast-read-u-integer 1)))) + +(define-fop (fop-package 14) + (let ((name (pop-stack))) + ;;(format t "xfop-package: ~{~X~^ ~}~%" (map 'list #'char-code name)) + (or (find-package name) + (error (intl:gettext "The package ~S does not exist.") name)))) + +(clone-fop (fop-string 37) + (fop-small-string 38) + (let* ((arg (clone-arg)) + (res (make-string arg))) + (read-n-bytes *fasl-file* res 0 + (* old-vm:char-bytes arg)) + (maybe-swap-string 'fop-string res) + res)) + +#+unicode +(defun cold-load-symbol (size package) + (let ((string (make-string size))) + (read-n-bytes *fasl-file* string 0 (* 2 size)) + ;;(format t "xpre swap cold-load-symbol: ~S to package ~S~%" string package) + (maybe-swap-string 'cold-load-symbol string) + ;;(format t "xpost swap cold-load-symbol: ~S to package ~S~%" string package) + (cold-intern (intern string package) package))) +) + diff --git a/src/tools/cross-scripts/cross-x86-ppc-darwin.lisp b/src/tools/cross-scripts/cross-x86-ppc-darwin.lisp index 0541163..0d492de 100644 --- a/src/tools/cross-scripts/cross-x86-ppc-darwin.lisp +++ b/src/tools/cross-scripts/cross-x86-ppc-darwin.lisp @@ -1,3 +1,6 @@ +;;; Cross-compile script to build a ppc core using x86 as the +;;; compiling system. This needs work! + (in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the @@ -9,32 +12,35 @@ ;; Features to add here '(:ppc :conservative-float-type - :hash-new :random-mt19937 - :darwin :bsd - :cmu :cmu20 :cmu20a - :gencgc + :hash-new + :random-mt19937 ; MT-19937 rng + :darwin ; Darwin OS (Mac OS X) + :bsd ; We're a BSD-type OS + :cmu ; Announce this is CMUCL + :cmu20 :cmu20a ; (Mostly) current version identifier + :gencgc ; Generational GC is supported on ppc. :relative-package-names - :modular-arith - :double-double + :modular-arith ; Modular arithmetic + :double-double ; Double-double float support :linkage-table ) ;; Features to remove from current *features* here '( ;; Other architectures we aren't using. Particularly important ;; to get rid of sse2 and x87 so we don't accidentally try to - ;; compile the x87/sse2 float support on sparc, which won't work. - :x86 :x86-bootstrap :sse2 :x87 :i486 + ;; compile the x87/sse2 float support on ppc, which won't work. + :x86 :x86-bootstrap :sse2 :x87 :i486 :pentium :alpha :osf1 :mips ;; Really old stuff that should have been removed long ago. :propagate-fun-type :propagate-float-type :constrain-float-type ;; Other OSes were not using :openbsd :freebsd :glibc2 :linux :mach-o :darwin :bsd - :pentium + :long-float - :new-random - :small - :mp + :new-random ; The rng before mt-19937 + :small ; Don't build small(er) cores on ppc. + :mp ; No multi-processing on ppc. ;; ppc currently doesn't support these. :executable :heap-overflow-check @@ -43,13 +49,6 @@ ;;; Changes needed to bootstrap cross-compiling from x86 to ppc -;; ppc doesn't have these features yet. Remove them. It is a bug in -;; cross-compiling that these features leak through to the target. -(setf *features* (remove :executable *features*)) -(setf *features* (remove :heap-overflow-check *features*)) -(setf *features* (remove :stack-checking *features*)) -(setf *features* (remove :complex-fp-vops *features*)) - ;; Set up the linkage space stuff appropriately for ppc. #+nil (setf (c::backend-foreign-linkage-space-start c::*target-backend*) @@ -57,86 +56,15 @@ (c::backend-foreign-linkage-entry-size c::*target-backend*) 32) -(in-package "LISP") -;; We need the the fops because the cross-compiled fasl file is in -;; big-endian order for sparc. When we read in a string, we need to -;; convert the big-endian string to little-endian for x86 so we can -;; process the symbols and such as expected. - -#+unicode -(progn -(defconstant ppc::char-bytes 2) -(defun maybe-swap-string (f name &optional (len (length name))) - (declare (ignorable f)) - (unless (eq (c:backend-byte-order c:*backend*) - (c:backend-byte-order c:*native-backend*)) - (dotimes (k len) - (let ((code (char-code (aref name k)))) - (setf (aref name k) - (code-char (logior (ash (ldb (byte 8 0) code) 8) - (ldb (byte 8 8) code)))))) - ;;(format t "~S: new name = ~S~%" f (subseq name 0 len)) - name)) - -(macrolet ((frob (name code name-size package) - (let ((n-package (gensym "PACKAGE-")) - (n-size (gensym "SIZE-")) - (n-buffer (gensym "BUFFER-")) - (k (gensym "IDX-"))) - `(define-fop (,name ,code) - (prepare-for-fast-read-byte *fasl-file* - (let ((,n-package ,package) - (,n-size (fast-read-u-integer ,name-size))) - (when (> ,n-size *load-symbol-buffer-size*) - (setq *load-symbol-buffer* - (make-string (setq *load-symbol-buffer-size* - (* ,n-size vm::char-bytes))))) - (done-with-fast-read-byte) - (let ((,n-buffer *load-symbol-buffer*)) - (read-n-bytes *fasl-file* ,n-buffer 0 - (* old-vm:char-bytes ,n-size)) - (maybe-swap-string ',name ,n-buffer ,n-size) - (push-table (intern* ,n-buffer ,n-size ,n-package))))))))) - (frob fop-symbol-save 6 4 *package*) - (frob fop-small-symbol-save 7 1 *package*) - (frob fop-lisp-symbol-save 75 4 *lisp-package*) - (frob fop-lisp-small-symbol-save 76 1 *lisp-package*) - (frob fop-keyword-symbol-save 77 4 *keyword-package*) - (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) - - (frob fop-symbol-in-package-save 8 4 - (svref *current-fop-table* (fast-read-u-integer 4))) - (frob fop-small-symbol-in-package-save 9 1 - (svref *current-fop-table* (fast-read-u-integer 4))) - (frob fop-symbol-in-byte-package-save 10 4 - (svref *current-fop-table* (fast-read-u-integer 1))) - (frob fop-small-symbol-in-byte-package-save 11 1 - (svref *current-fop-table* (fast-read-u-integer 1)))) - -(define-fop (fop-package 14) - (let ((name (pop-stack))) - ;;(format t "xfop-package: ~{~X~^ ~}~%" (map 'list #'char-code name)) - (or (find-package name) - (error (intl:gettext "The package ~S does not exist.") name)))) - -(clone-fop (fop-string 37) - (fop-small-string 38) - (let* ((arg (clone-arg)) - (res (make-string arg))) - (read-n-bytes *fasl-file* res 0 - (* old-vm:char-bytes arg)) - (maybe-swap-string 'fop-string res) - res)) +(in-package "PPC") +(defconstant char-bytes #+unicode 2 #-unicode 1) +(export 'char-bytes) +(in-package "CL-USER") +;; Get new fops so we can process fasls with big-endian unicode +;; strings on our little-endian compiling system. #+unicode -(defun cold-load-symbol (size package) - (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 (* 2 size)) - ;;(format t "xpre swap cold-load-symbol: ~S to package ~S~%" string package) - (maybe-swap-string 'cold-load-symbol string) - ;;(format t "xpost swap cold-load-symbol: ~S to package ~S~%" string package) - (cold-intern (intern string package) package))) -) +(load "target:tools/cross-scripts/cross-unicode-big-endian.lisp") ;;; End changes needed to bootstrap cross-compiling from x86 to ppc diff --git a/src/tools/cross-scripts/cross-x86-sparc.lisp b/src/tools/cross-scripts/cross-x86-sparc.lisp index 21202f5..0e6dfbd 100644 --- a/src/tools/cross-scripts/cross-x86-sparc.lisp +++ b/src/tools/cross-scripts/cross-x86-sparc.lisp @@ -60,85 +60,10 @@ (c::backend-foreign-linkage-entry-size c::*target-backend*) 16) -(in-package "LISP") -;; We need the the fops because the cross-compiled fasl file is in -;; big-endian order for sparc. When we read in a string, we need to -;; convert the big-endian string to little-endian for x86 so we can -;; process the symbols and such as expected. +;; Get new fops so we can process fasls with big-endian unicode +;; strings on our little-endian compiling system. #+unicode -(progn -(defun maybe-swap-string (f name &optional (len (length name))) - (declare (ignorable f)) - (unless (eq (c:backend-byte-order c:*backend*) - (c:backend-byte-order c:*native-backend*)) - (dotimes (k len) - (let ((code (char-code (aref name k)))) - (setf (aref name k) - (code-char (logior (ash (ldb (byte 8 0) code) 8) - (ldb (byte 8 8) code)))))) - ;;(format t "~S: new name = ~S~%" f (subseq name 0 len)) - name)) - -(macrolet ((frob (name code name-size package) - (let ((n-package (gensym "PACKAGE-")) - (n-size (gensym "SIZE-")) - (n-buffer (gensym "BUFFER-")) - (k (gensym "IDX-"))) - `(define-fop (,name ,code) - (prepare-for-fast-read-byte *fasl-file* - (let ((,n-package ,package) - (,n-size (fast-read-u-integer ,name-size))) - (when (> ,n-size *load-symbol-buffer-size*) - (setq *load-symbol-buffer* - (make-string (setq *load-symbol-buffer-size* - (* ,n-size vm:char-bytes))))) - (done-with-fast-read-byte) - (let ((,n-buffer *load-symbol-buffer*)) - (read-n-bytes *fasl-file* ,n-buffer 0 - (* old-vm:char-bytes ,n-size)) - (maybe-swap-string ',name ,n-buffer ,n-size) - (push-table (intern* ,n-buffer ,n-size ,n-package))))))))) - (frob fop-symbol-save 6 4 *package*) - (frob fop-small-symbol-save 7 1 *package*) - (frob fop-lisp-symbol-save 75 4 *lisp-package*) - (frob fop-lisp-small-symbol-save 76 1 *lisp-package*) - (frob fop-keyword-symbol-save 77 4 *keyword-package*) - (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) - - (frob fop-symbol-in-package-save 8 4 - (svref *current-fop-table* (fast-read-u-integer 4))) - (frob fop-small-symbol-in-package-save 9 1 - (svref *current-fop-table* (fast-read-u-integer 4))) - (frob fop-symbol-in-byte-package-save 10 4 - (svref *current-fop-table* (fast-read-u-integer 1))) - (frob fop-small-symbol-in-byte-package-save 11 1 - (svref *current-fop-table* (fast-read-u-integer 1)))) - -(define-fop (fop-package 14) - (let ((name (pop-stack))) - ;;(format t "xfop-package: ~{~X~^ ~}~%" (map 'list #'char-code name)) - (or (find-package name) - (error (intl:gettext "The package ~S does not exist.") name)))) - -(clone-fop (fop-string 37) - (fop-small-string 38) - (let* ((arg (clone-arg)) - (res (make-string arg))) - (read-n-bytes *fasl-file* res 0 - (* old-vm:char-bytes arg)) - (maybe-swap-string 'fop-string res) - res)) - -#+unicode -(defun cold-load-symbol (size package) - (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 (* 2 size)) - ;;(format t "xpre swap cold-load-symbol: ~S to package ~S~%" string package) - (maybe-swap-string 'cold-load-symbol string) - ;;(format t "xpost swap cold-load-symbol: ~S to package ~S~%" string package) - (cold-intern (intern string package) package))) -) - +(load "target:tools/cross-scripts/cross-unicode-big-endian.lisp") ;;; End changes needed to bootstrap cross-compiling from x86 to sparc ----------------------------------------------------------------------- Summary of changes: .../cross-scripts/cross-unicode-big-endian.lisp | 93 +++++++++++++++ src/tools/cross-scripts/cross-x86-ppc-darwin.lisp | 122 ++++---------------- src/tools/cross-scripts/cross-x86-sparc.lisp | 81 +------------- 3 files changed, 121 insertions(+), 175 deletions(-) create mode 100644 src/tools/cross-scripts/cross-unicode-big-endian.lisp hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-26-g944c67f
by Raymond Toy 01 Feb '12

01 Feb '12

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-25-g18e1fca
by Raymond Toy 01 Feb '12

01 Feb '12

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-24-ga3e7af3
by Raymond Toy 01 Feb '12

01 Feb '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via a3e7af38dfc712cecbe940af00f16f2b13846e07 (commit) via 586be50caeb0db191c1a02645a3dacb6efe92a0e (commit) from 53cb30ad0335c33c70c24779aa964b775404680e (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit a3e7af38dfc712cecbe940af00f16f2b13846e07 Merge: 53cb30a 586be50 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Jan 31 21:26:16 2012 -0800 Merge branch 'master' of ssh://diapentepomum/~rtoym/src/cmucl/git/cmucl commit 586be50caeb0db191c1a02645a3dacb6efe92a0e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Jan 31 22:23:01 2012 -0700 Use ppc as the default directory for ppc/darwin. diff --git a/bin/build.sh b/bin/build.sh index 537354b..85d70e7 100755 --- a/bin/build.sh +++ b/bin/build.sh @@ -176,8 +176,11 @@ done # If -b not given, try to derive one instead of just using "build". if [ -z "$BASE" ]; then case `uname -s` in - Darwin) # We only support darwin-x86 now. No ppc available anymore. - BASE=darwin ;; + Darwin) + case `uname -p` in + powerpc) BASE=ppc ;; + i386) BASE=darwin ;; + esac ;; SunOS) case `uname -m` in sun4u) BASE=sparc ;; ----------------------------------------------------------------------- Summary of changes: bin/build.sh | 7 +++++-- 1 files changed, 5 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-22-g53cb30a
by Raymond Toy 01 Feb '12

01 Feb '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 53cb30ad0335c33c70c24779aa964b775404680e (commit) via 768d6a348cbad25cfe57d664a3784e639b3878e7 (commit) from 3073cc1fcd6e00759421a1a9b9373c140155efa6 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 53cb30ad0335c33c70c24779aa964b775404680e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Jan 31 21:22:41 2012 -0800 Minor fix from Paul: avoid capitalizing mid-name in the completions list. diff --git a/src/code/unidata.lisp b/src/code/unidata.lisp index 91b5bda..e0442d8 100644 --- a/src/code/unidata.lisp +++ b/src/code/unidata.lisp @@ -1286,7 +1286,7 @@ (let* ((base (mip result)) (node (search-dictionary base dict))) (values (str base) - (sort (mapcar (lambda (x) (str (subseq x (length base)))) + (sort (mapcar (lambda (x) (subseq (str x) (length base))) (delete base result :test #'string=)) #'string<) (and node (completep node))))))) commit 768d6a348cbad25cfe57d664a3784e639b3878e7 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Jan 31 19:34:14 2012 -0800 Fix ticket:52. Thanks to Paul Foley for rewriting {{{UNICODE-COMPLETE-NAME}}} to make it work. diff --git a/src/code/unidata.lisp b/src/code/unidata.lisp index 4f94684..91b5bda 100644 --- a/src/code/unidata.lisp +++ b/src/code/unidata.lisp @@ -1231,98 +1231,65 @@ 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. " - (unless dict - ;; Load the names dictionary, if needed. - (unless (unidata-name+ *unicode-data*) - (load-names)) + (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) - (progn - (format t "n,p,complete = ~S ~S ~S~%" n p completep) - (when n (format t "match = ~S~%" (subseq prefix 0 p)))) - (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 dict)) - (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) dict))) - #+(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 dict)) - (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) dict)) - (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, but we still want to keep the - ;; original completions. - (let* ((p (append (mapcar #'car x) - (mapcan #'(lambda (ex) - (let ((next (node-next (cdr ex) dict))) - (if next - (mapcar #'(lambda (n) - (concatenate 'string (car ex) (car n))) - (node-next (cdr ex) dict)) - (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)))))))))) + (let* ((prefix (nsubstitute #\Space #\_ (string-upcase prefix))) + (result nil)) + (labels ((keybase (node) + (ash (aref (dictionary-nextv dict) node) -18)) + (keylen (base) + (aref (dictionary-keyl dict) base)) + (keystr (base offset) + (aref (dictionary-cdbk dict) + (aref (dictionary-keyv dict) (+ base offset)))) + (next (node keypos) + (+ (logand (aref (dictionary-nextv dict) node) #x3FFFF) + keypos)) + (completep (node) + (> (aref (dictionary-codev dict) node) -1)) + (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))))) + (rec (node posn) + (let ((keyv (keybase node))) + (dotimes (i (keylen keyv)) + (let* ((str (keystr keyv i)) (len (length str))) + (when (match str prefix posn) + (cond ((<= (+ len posn) (length prefix)) + (rec (next node i) (+ posn len))) + (t + (push (fillout (concatenate 'string (subseq prefix 0 posn) + str) + (next node i)) + result)))))))) + (fillout (string node) + (let ((keyv (keybase node))) + (if (and (= (keylen keyv) 1) (not (completep node))) + (fillout (concatenate 'string string (keystr keyv 0)) + (next node 0)) + string))) + (mip (strings) + (let* ((first (first strings)) + (posn (length first))) + (dolist (string (rest strings)) + (let ((n (mismatch first string :end1 posn))) + (when n (setq posn n)))) + (subseq first 0 posn))) + (str (x) (nsubstitute #\_ #\Space (string-capitalize x)))) + (rec 0 0) + (unless (cdr result) + (setq prefix (car result)) + (rec 0 0)) + (let* ((base (mip result)) + (node (search-dictionary base dict))) + (values (str base) + (sort (mapcar (lambda (x) (str (subseq x (length base)))) + (delete base result :test #'string=)) + #'string<) + (and node (completep node))))))) ;; Like unicode-complete-name, but we also try to handle the names ;; that can be computed algorithmically like the Hangul syllables and ----------------------------------------------------------------------- Summary of changes: src/code/unidata.lisp | 147 +++++++++++++++++++------------------------------ 1 files changed, 57 insertions(+), 90 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-20-g3073cc1
by Raymond Toy 31 Jan '12

31 Jan '12

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-19-gd6fc240
by Raymond Toy 29 Jan '12

29 Jan '12

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs