comparison lisp/subr.el @ 851:e7ee5f8bde58

[xemacs-hg @ 2002-05-23 11:46:08 by ben] fix for raymond toy's crash, alloca crashes, some recover-session improvements files.el: Recover-session improvements: Only show session files where some files can actually be recovered, and show in chronological order. subr.el, menubar-items.el: As promised to rms, the functionality in truncate-string-with-continuation-dots has been merged into truncate-string-to-width. Change callers in menubar-items.el. select.el: Document some of these funs better. Fix problem where we were doing own-clipboard twice. Makefile.in.in: Add alloca.o. Ensure that alloca.s doesn't compile into alloca.o, but allocax.o (not that it's currently used or anything.) EmacsFrame.c, abbrev.c, alloc.c, alloca.c, callint.c, callproc.c, config.h.in, device-msw.c, device-x.c, dired.c, doc.c, editfns.c, emacs.c, emodules.c, eval.c, event-Xt.c, event-msw.c, event-stream.c, file-coding.c, fileio.c, filelock.c, fns.c, glyphs-gtk.c, glyphs-msw.c, glyphs-x.c, gui-x.c, input-method-xlib.c, intl-win32.c, lisp.h, lread.c, menubar-gtk.c, menubar-msw.c, menubar.c, mule-wnnfns.c, nt.c, objects-msw.c, process-nt.c, realpath.c, redisplay-gtk.c, redisplay-output.c, redisplay-x.c, redisplay.c, search.c, select-msw.c, sysdep.c, syswindows.h, text.c, text.h, ui-byhand.c: Fix Raymond Toy's crash. Repeat to self: 2^21 - 1 is NOT the same as (2 << 21) - 1. Fix crashes due to excessive alloca(). replace alloca() with ALLOCA(), which calls the C alloca() [which uses xmalloc()] when the size is too big. Insert in various places calls to try to flush the C alloca() stored info if there is any. Add MALLOC_OR_ALLOCA(), for places that expect to be alloca()ing large blocks. This xmalloc()s when too large and records an unwind-protect to free -- relying on the caller to unbind_to() elsewhere in the function. Use it in concat(). Use MALLOC instead of ALLOCA in select-msw.c. xemacs.mak: Add alloca.o.
author ben
date Thu, 23 May 2002 11:46:46 +0000
parents a634e3b7acc8
children 79c6ff3eef26
comparison
equal deleted inserted replaced
850:f915ad7befaf 851:e7ee5f8bde58
578 (while (and (< i len) (< idx string-len)) 578 (while (and (< i len) (< idx string-len))
579 (aset string idx (aref str i)) 579 (aset string idx (aref str i))
580 (setq idx (1+ idx) i (1+ i))) 580 (setq idx (1+ idx) i (1+ i)))
581 string)) 581 string))
582 582
583 ;; From FSF 21.1 583 ;; From FSF 21.1; ELLIPSES is XEmacs addition.
584 (defun truncate-string-to-width (str end-column &optional start-column padding) 584
585 (defun truncate-string-to-width (str end-column &optional start-column padding
586 ellipses)
585 "Truncate string STR to end at column END-COLUMN. 587 "Truncate string STR to end at column END-COLUMN.
586 The optional 3rd arg START-COLUMN, if non-nil, specifies 588 The optional 3rd arg START-COLUMN, if non-nil, specifies
587 the starting column; that means to return the characters occupying 589 the starting column; that means to return the characters occupying
588 columns START-COLUMN ... END-COLUMN of STR. 590 columns START-COLUMN ... END-COLUMN of STR.
589 591
592 or if END-COLUMN comes in the middle of a character in STR. 594 or if END-COLUMN comes in the middle of a character in STR.
593 PADDING is also added at the beginning of the result 595 PADDING is also added at the beginning of the result
594 if column START-COLUMN appears in the middle of a character in STR. 596 if column START-COLUMN appears in the middle of a character in STR.
595 597
596 If PADDING is nil, no padding is added in these cases, so 598 If PADDING is nil, no padding is added in these cases, so
597 the resulting string may be narrower than END-COLUMN." 599 the resulting string may be narrower than END-COLUMN.
600
601 BUG: Currently assumes that the padding character is of width one. You
602 will get weird results if not.
603
604 If ELLIPSES is non-nil, add ellipses (specified by ELLIPSES if a string,
605 else `...') if STR extends past END-COLUMN. The ellipses will be added in
606 such a way that the total string occupies no more than END-COLUMN columns
607 -- i.e. if the string goes past END-COLUMN, it will be truncated somewhere
608 short of END-COLUMN so that, with the ellipses added (and padding, if the
609 proper place to truncate the string would be in the middle of a character),
610 the string occupies exactly END-COLUMN columns."
598 (or start-column 611 (or start-column
599 (setq start-column 0)) 612 (setq start-column 0))
600 (let ((len (length str)) 613 (let ((len (length str))
601 (idx 0) 614 (idx 0)
602 (column 0) 615 (column 0)
603 (head-padding "") (tail-padding "") 616 (head-padding "") (tail-padding "")
604 ch last-column last-idx from-idx) 617 ch last-column last-idx from-idx)
618
619 ;; find the index of START-COLUMN; bail out if end of string reached.
605 (condition-case nil 620 (condition-case nil
606 (while (< column start-column) 621 (while (< column start-column)
607 (setq ch (aref str idx) 622 (setq ch (aref str idx)
608 column (+ column (char-width ch)) 623 column (+ column (char-width ch))
609 idx (1+ idx))) 624 idx (1+ idx)))
610 (args-out-of-range (setq idx len))) 625 (args-out-of-range (setq idx len)))
611 (if (< column start-column) 626 (if (< column start-column)
612 (if padding (make-string end-column padding) "") 627 ;; if string ends before START-COLUMN, return either a blank string
628 ;; or a string entirely padded.
629 (if padding (make-string (- end-column start-column) padding) "")
613 (if (and padding (> column start-column)) 630 (if (and padding (> column start-column))
614 (setq head-padding (make-string (- column start-column) padding))) 631 (setq head-padding (make-string (- column start-column) padding)))
615 (setq from-idx idx) 632 (setq from-idx idx)
633 ;; If END-COLUMN is before START-COLUMN, then bail out.
616 (if (< end-column column) 634 (if (< end-column column)
617 (setq idx from-idx) 635 (setq idx from-idx ellipses "")
636
637 ;; handle ELLIPSES
638 (cond ((null ellipses) (setq ellipses ""))
639 ((if (<= (string-width str) end-column)
640 ;; string fits, no ellipses
641 (setq ellipses "")))
642 (t
643 ;; else, insert default value and ...
644 (or (stringp ellipses) (setq ellipses "..."))
645 ;; ... take away the width of the ellipses from the
646 ;; destination. do all computations with new, shorter
647 ;; width. the padding computed will get us exactly up to
648 ;; the shorted width, which is right -- it just gets added
649 ;; to the right of the ellipses.
650 (setq end-column (- end-column (string-width ellipses)))))
651
652 ;; find the index of END-COLUMN; bail out if end of string reached.
618 (condition-case nil 653 (condition-case nil
619 (while (< column end-column) 654 (while (< column end-column)
620 (setq last-column column 655 (setq last-column column
621 last-idx idx 656 last-idx idx
622 ch (aref str idx) 657 ch (aref str idx)
623 column (+ column (char-width ch)) 658 column (+ column (char-width ch))
624 idx (1+ idx))) 659 idx (1+ idx)))
625 (args-out-of-range (setq idx len))) 660 (args-out-of-range (setq idx len)))
661 ;; if we went too far (stopped in middle of character), back up.
626 (if (> column end-column) 662 (if (> column end-column)
627 (setq column last-column idx last-idx)) 663 (setq column last-column idx last-idx))
664 ;; compute remaining padding
628 (if (and padding (< column end-column)) 665 (if (and padding (< column end-column))
629 (setq tail-padding (make-string (- end-column column) padding)))) 666 (setq tail-padding (make-string (- end-column column) padding))))
667 ;; get substring ...
630 (setq str (substring str from-idx idx)) 668 (setq str (substring str from-idx idx))
669 ;; and construct result
631 (if padding 670 (if padding
632 (concat head-padding str tail-padding) 671 (concat head-padding str tail-padding ellipses)
633 str)))) 672 (concat str ellipses)))))
634
635 (defun truncate-string-with-continuation-dots (str end-column &optional
636 dots-str)
637 "Truncate string STR to end at column END-COLUMN, adding dots if needed.
638 The dots (normally `...', but can be controlled by DOTS-STR)' will be added
639 in such a way that the total string occupies no more than END-COLUMN
640 columns -- i.e. if the string goes past END-COLUMN, it will be truncated
641 somewhere short of END-COLUMN so that, with the dots added, the string
642 occupies END-COLUMN columns."
643 (if (<= (string-width str) end-column) str
644 (let* ((dots-str (or dots-str "..."))
645 (dotswidth (string-width dots-str)))
646 (concat (truncate-string-to-width str (- end-column dotswidth))
647 dots-str))))
648 673
649 674
650 ;; alist/plist functions 675 ;; alist/plist functions
651 (defun plist-to-alist (plist) 676 (defun plist-to-alist (plist)
652 "Convert property list PLIST into the equivalent association-list form. 677 "Convert property list PLIST into the equivalent association-list form.