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))))
+