diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 455894cc7c4625cd8ac8d970aa6ff0879fa38f57..e75e5d77bf065a69a641110fbab1fb4c82541b7a 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 0ca34c23dc86994dc35073444331042e1b9d3d47..29b9c23f0d8881445f146716e4057c8327289504 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 8005cda87102a2120c676ad6580f3cb20802b4d9..bfaffb45e3f44a7608853221d1a7434d9b9c63f5 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 a88563494141155ef7c1fe04d74737a82e896551..608de172246ce76d1047068a46c9d110c4663d05 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 0000000000000000000000000000000000000000..c184540ac014c7c078a23548786da588001f7603 --- /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)))) +