- Timestamp:
- May 15, 2009, 1:12:03 AM (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/1.3/source/cocoa-ide/hemlock/src/table.lisp
r6 r12064 232 232 ;;; With-Folded-String to ``do'' over the words. 233 233 234 (defvar *string-buffer-size* 128)235 (defvar *string-buffer* (make-string *string-buffer-size*))236 (declaim (simple-string *string-buffer*))237 238 234 (defvar *separator-positions* nil) 239 235 … … 248 244 (defmacro with-folded-string ((str-var len-var orig-str separator) 249 245 &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) 260 258 (declare (simple-string str) (base-char separator)) 261 259 (let ((str-len (length str)) 262 260 (sep-pos nil) 263 261 (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*)))268 262 ;; Bash the spaces out of the string remembering where the words are. 269 263 (let ((start-pos (position separator str :test-not #'char=))) … … 277 271 (word-len (- (or end-pos str-len) start-pos)) 278 272 (new-buf-pos (+ buf-pos word-len))) 279 (replace *string-buffer*str273 (replace buf str 280 274 :start1 buf-pos :start2 start-pos :end2 end-pos) 281 275 (push (cons buf-pos new-buf-pos) sep-pos) … … 284 278 (return)) 285 279 (setf start-pos next-start-pos) 286 (setf (schar *string-buffer*buf-pos) separator)280 (setf (schar buf buf-pos) separator) 287 281 (incf buf-pos))))) 288 (nstring-downcase *string-buffer*:end buf-pos)282 (nstring-downcase buf :end buf-pos) 289 283 (setf *separator-positions* (nreverse sep-pos)) 290 284 buf-pos))
Note: See TracChangeset
for help on using the changeset viewer.