Changeset 12064 for release


Ignore:
Timestamp:
May 15, 2009, 1:12:03 AM (10 years ago)
Author:
rme
Message:

Merge r12061 to 1.3 (fix for ticket:472).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/1.3/source/cocoa-ide/hemlock/src/table.lisp

    r6 r12064  
    232232;;; With-Folded-String to ``do'' over the words.
    233233
    234 (defvar *string-buffer-size* 128)
    235 (defvar *string-buffer* (make-string *string-buffer-size*))
    236 (declaim (simple-string *string-buffer*))
    237 
    238234(defvar *separator-positions* nil)
    239235
     
    248244(defmacro with-folded-string ((str-var len-var orig-str separator)
    249245                              &body body)
    250   `(let ((,str-var *string-buffer*))
    251     (declare (simple-string ,str-var))
    252     ;; make the string simple if it isn't already
    253     (unless (simple-string-p ,orig-str)
    254       (setq ,orig-str (coerce ,orig-str 'simple-string)))
    255     ;; munge it into *string-buffer* and do the body
    256     (let ((,len-var (with-folded-munge-string ,orig-str ,separator)))
    257       ,@body)))
    258 
    259 (defun with-folded-munge-string (str separator)
     246  `(let* ((,str-var (make-string (length ,orig-str)))
     247          (*separator-positions* nil))
     248     (declare (simple-string ,str-var)
     249              (dynamic-extent ,str-var))
     250     ;; make the string simple if it isn't already
     251     (unless (simple-string-p ,orig-str)
     252       (setq ,orig-str (coerce ,orig-str 'simple-string)))
     253     ;; munge it into stack-allocated ,str-var and do the body
     254     (let ((,len-var (with-folded-munge-string ,str-var ,orig-str ,separator)))
     255       ,@body)))
     256
     257(defun with-folded-munge-string (buf str separator)
    260258  (declare (simple-string str) (base-char separator))
    261259  (let ((str-len (length str))
    262260        (sep-pos nil)
    263261        (buf-pos 0))
    264     ;; Make sure we have enough room to blt the string into place.
    265     (when (> str-len *string-buffer-size*)
    266       (setq *string-buffer-size* (* str-len 2))
    267       (setq *string-buffer* (make-string *string-buffer-size*)))
    268262    ;; Bash the spaces out of the string remembering where the words are.
    269263    (let ((start-pos (position separator str :test-not #'char=)))
     
    277271                 (word-len (- (or end-pos str-len) start-pos))
    278272                 (new-buf-pos (+ buf-pos word-len)))
    279             (replace *string-buffer* str
     273            (replace buf str
    280274                     :start1 buf-pos :start2 start-pos :end2 end-pos)
    281275            (push (cons buf-pos new-buf-pos) sep-pos)
     
    284278              (return))
    285279            (setf start-pos next-start-pos)
    286             (setf (schar *string-buffer* buf-pos) separator)
     280            (setf (schar buf buf-pos) separator)
    287281            (incf buf-pos)))))
    288     (nstring-downcase *string-buffer* :end buf-pos)
     282    (nstring-downcase buf :end buf-pos)
    289283    (setf *separator-positions* (nreverse sep-pos))
    290284    buf-pos))
Note: See TracChangeset for help on using the changeset viewer.