From 2b1925b64fac2d5bd5b46826a2f2678b52c1683c Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Wed, 5 Nov 2014 19:52:57 -0800 Subject: [PATCH] Add iterators and loop paths for codepoints and glyphs * src/code/string.lisp: * Add WITH-STRING-CODEPOINT-ITERATOR to allow iterating over the codepoints in a string. * Add WITH-STRING-GLYPO-ITERATOR to allow iterating over the glpyhs in a string. * src/code/exports.lisp: * Export WITH-STRING-CODEPOINT-ITERATOR and WITH-STRING-GLYPH-ITERATOR. * src/code/loop.lisp: * Support (loop for cp being the codepoint of string ...) which extracts the consecutive codepoints from the string. Allow codepoints, code-point, and code-points as aliases of codepoint. * Support (loop for g-string being the glyph of string ...) which extracts each glyph (as a string) from the string. Allow glpyhs as an alias. * tests/extended-loop.lisp: * New file of tests for the new loop paths. * src/i18n/locale/cmucl.pot: * Update. --- src/code/exports.lisp | 4 +- src/code/loop.lisp | 88 ++++++++++++++++++++++++++++++++++++++- src/code/string.lisp | 49 ++++++++++++++++++++++ src/i18n/locale/cmucl.pot | 23 ++++++++++ tests/extended-loop.lisp | 30 +++++++++++++ 5 files changed, 191 insertions(+), 3 deletions(-) create mode 100644 tests/extended-loop.lisp diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 455894cc7..e75e5d77b 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -919,7 +919,9 @@ "+UNICODE-CATEGORY-UPPER+" "+UNICODE-CATEGORY-TITLE+" "LOAD-ALL-UNICODE-DATA" - "SURROGATES")) + "SURROGATES" + "WITH-STRING-CODEPOINT-ITERATOR" + "WITH-STRING-GLYPH-ITERATOR")) (defpackage "EVAL" (:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*" diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 0ca34c23d..29b9c23f0 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -45,6 +45,9 @@ ;;;> United States of America ;;;> +1-617-221-1000 +;;;> See page 391 of http://bitsavers.trailing-edge.com/pdf/symbolics/software/genera_8/Symbolics_Common_Lisp_Language_Concepts.pdf +;;;> for more information on how to extend loop. + ;; $aclHeader: loop.cl,v 1.5 91/12/04 01:13:48 cox acl4_1 $ #+cmu @@ -2153,6 +2156,77 @@ collected result will be returned as the value of the LOOP." ,variable) (,next-fn))) ()))) + + +;; Supports +;; +;; (loop for cp being the codepoint of string ...) +;; +;; where cp is the codepoint of charactor (or surrogate pair) in the +;; string. +(defun loop-string-codepoint-iteration-path (variable data-type prep-phrases) + (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) + (loop-error _N"Too many prepositions!")) + ((null prep-phrases) (loop-error _N"Missing OF or IN in ~S iteration path."))) + (let ((string-var (loop-gentemp 'loop-codepoint-string-)) + (next-fn (loop-gentemp 'loop-codepoint-next-)) + (post-steps nil)) + (let* ((val-var nil) + (temp-val-var (loop-gentemp 'loop-codepoint-val-temp-)) + (temp-predicate-var (loop-gentemp 'loop-codepoint-predicate-var-)) + (variable (or variable (loop-gentemp))) + (bindings `((,variable nil ,data-type) + (,string-var ,(cadar prep-phrases))))) + (push `(lisp::with-string-codepoint-iterator (,next-fn ,string-var)) *loop-wrappers*) + (setq val-var variable) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not + (multiple-value-bind (,temp-predicate-var ,temp-val-var) + (,next-fn) + (when ,temp-predicate-var + (setq ,val-var ,temp-val-var)) + ,temp-predicate-var + )) ;post-test + ,post-steps)))) + +;; Supports +;; (loop for g-string being the glyph of string ...) +;; +;; where g-string is a string consisting of a character and all +;; trailing combining characters. +(defun loop-string-glyph-string-iteration-path (variable data-type prep-phrases) + (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) + (loop-error _N"Too many prepositions!")) + ((null prep-phrases) (loop-error _N"Missing OF or IN in ~S iteration path."))) + (let ((string-var (loop-gentemp 'loop-glyph-string-)) + (next-fn (loop-gentemp 'loop-glyph-next-)) + (post-steps nil)) + (let* ((val-var nil) + (temp-index-var (loop-gentemp 'loop-glyph-index-temp-)) + (temp-len-var (loop-gentemp 'loop-glyph-len-temp-)) + (temp-predicate-var (loop-gentemp 'loop-glyph-predicate-var-)) + (variable (or variable (loop-gentemp))) + (bindings `((,variable nil ,data-type) + (,string-var ,(cadar prep-phrases))))) + (push `(lisp::with-string-glyph-iterator (,next-fn ,string-var)) *loop-wrappers*) + (setq val-var variable) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not + (multiple-value-bind (,temp-predicate-var ,temp-index-var ,temp-len-var) + (,next-fn) + (when ,temp-predicate-var + (setq ,val-var (subseq ,string-var ,temp-index-var ,temp-len-var))) + ,temp-predicate-var + )) ;post-test + ,post-steps)))) + + ;;;; ANSI Loop @@ -2235,12 +2309,22 @@ collected result will be returned as the value of the LOOP." :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:symbol-types (:internal :external))) + (when extended-p + (add-loop-path '(code-point code-points codepoint codepoints) + 'loop-string-codepoint-iteration-path + w + :preposition-groups '((:of :in)) + :inclusive-permitted nil) + (add-loop-path '(glyph glyphs) + 'loop-string-glyph-string-iteration-path + w + :preposition-groups '((:of :in)) + :inclusive-permitted nil)) w)) (defparameter *loop-ansi-universe* - (make-ansi-loop-universe nil)) - + (make-ansi-loop-universe t)) (defun loop-standard-expansion (keywords-and-forms environment universe) (if (and keywords-and-forms (symbolp (car keywords-and-forms))) diff --git a/src/code/string.lisp b/src/code/string.lisp index 8005cda87..bfaffb45e 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -87,6 +87,30 @@ (values (truly-the codepoint code) nil)))) (t (values (truly-the codepoint code) nil))))) +(defmacro with-string-codepoint-iterator ((next string) &body body) + _N"WITH-STRING-CODEPOINT-ITERATOR ((next string) &body body) + provides a method of looping through a string from the beginning to + the end of the string prodcucing successive codepoints from the + string. NEXT is bound to a generator macro that, within the scope + of the invocation, returns one or two values. The first value tells + whether any objects remain in the string. When the first value is + non-NIL, the second value is the codepoint of the next object." + (let ((n-next (gensym "WITH-STRING-CODEPOINT-ITERATOR-"))) + `(let ((,n-next + (let* ((s ,string) + (len (length s)) + (index 0)) + (labels + ((,next () + (when (< index len) + (multiple-value-bind (cp surrogatep) + (codepoint s index) + (incf index (if surrogatep 2 1)) + (values t cp))))) + #',next)))) + (macrolet ((,next () '(funcall ,n-next))) + ,@body)))) + (defun surrogates (codepoint) "Return the high and low surrogate characters for Codepoint. If Codepoint is in the BMP, the first return value is the corresponding @@ -1013,6 +1037,31 @@ (values (subseq string n index) (and (> n 0) n)) (values (subseq string index n) (and (< n (length string)) n))))) +(defmacro with-string-glyph-iterator ((next string) &body body) + _N"WITH-STRING-GLYPH-ITERATOR ((next string) &body body) + provides a method of looping through a string from the beginning to + the end of the string prodcucing successive glyphs from the string. + NEXT is bound to a generator macro that, within the scope of the + invocation, returns one or three values. The first value tells + whether any objects remain in the string. When the first value is + non-NIL, the second value is the index into the string of the glyph + and the third value is index of the next glyph." + (let ((n-next (gensym "WITH-STRING-GLYPH-ITERATOR-"))) + `(let ((,n-next + (let* ((s ,string) + (len (length s)) + (index 0)) + (labels + ((,next () + (when (< index len) + (let ((glyph-end (%glyph-f s index))) + (multiple-value-prog1 + (values t index glyph-end) + (setf index glyph-end)))))) + #',next)))) + (macrolet ((,next () '(funcall ,n-next))) + ,@body)))) + #+unicode (defun string-reverse* (sequence) (declare (optimize (speed 3) (space 0) (safety 0)) diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index a88563494..608de1722 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -3701,6 +3701,17 @@ msgid "" " surrogate value, respectively." msgstr "" +#: src/code/string.lisp +msgid "" +"WITH-STRING-CODEPOINT-ITERATOR ((next string) &body body)\n" +" provides a method of looping through a string from the beginning to\n" +" the end of the string prodcucing successive codepoints from the\n" +" string. NEXT is bound to a generator macro that, within the scope\n" +" of the invocation, returns one or two values. The first value tells\n" +" whether any objects remain in the string. When the first value is\n" +" non-NIL, the second value is the codepoint of the next object." +msgstr "" + #: src/code/string.lisp msgid "" "Return the high and low surrogate characters for Codepoint. If\n" @@ -3959,6 +3970,18 @@ msgid "" " except that the string must be a simple-string" msgstr "" +#: src/code/string.lisp +msgid "" +"WITH-STRING-GLYPH-ITERATOR ((next string) &body body)\n" +" provides a method of looping through a string from the beginning to\n" +" the end of the string prodcucing successive glyphs from the string.\n" +" NEXT is bound to a generator macro that, within the scope of the\n" +" invocation, returns one or three values. The first value tells\n" +" whether any objects remain in the string. When the first value is\n" +" non-NIL, the second value is the index into the string of the glyph\n" +" and the third value is index of the next glyph." +msgstr "" + #: src/code/string.lisp msgid "" "Convert String to Unicode Normalization Form D (NFD) using the\n" diff --git a/tests/extended-loop.lisp b/tests/extended-loop.lisp new file mode 100644 index 000000000..c184540ac --- /dev/null +++ b/tests/extended-loop.lisp @@ -0,0 +1,30 @@ +(defpackage :extended-loop-tests + (:use :cl :lisp-unit)) + +(in-package "EXTENDED-LOOP-TESTS") + +(define-test loop-codepoint + (:tag :extended-loop) + (let ((codepoints (mapcar #'(lambda (c) + (if (characterp c) + (char-code c) + c)) + '(#\a #\b #\greek_capital_letter_gamma + ;; This is a random code point that + ;; requires a surrogate pair in our + ;; UTF-16 string represntation. + 65536 + #\c)))) + (assert-equal codepoints + (loop for c being the codepoints of (lisp::codepoints-string codepoints) + collect c)))) + +(define-test loop-glyph-string + (:tag :extended-loop) + (let* ((s (string #\Latin_Small_Letter_A_With_Diaeresis_and_macron)) + (d (lisp::string-to-nfkd s))) + (assert-equal (list s) + (loop for g being the glyphs of s collect g)) + (assert-equal (list d) + (loop for g being the glyphs of d collect g)))) + -- GitLab