Mercurial > hg > xemacs-beta
changeset 5475:248176c74e6b
Merge with trunk.
| author | Mats Lidell <matsl@xemacs.org> |
|---|---|
| date | Sat, 23 Apr 2011 23:47:13 +0200 |
| parents | 4dee0387b9de (current diff) 82e220b08ace (diff) |
| children | f2881cb841b4 |
| files | lisp/ChangeLog lisp/bytecomp.el lisp/cl-extra.el lisp/cl-macs.el lisp/cl.el lisp/descr-text.el lisp/dumped-lisp.el lisp/font.el lisp/mule/mule-win32-init.el lisp/mule/thai-util.el lisp/mule/thai-xtis.el lisp/mule/thai.el lisp/obsolete.el lisp/unicode.el man/ChangeLog src/ChangeLog src/alloc.c src/console-tty-impl.h src/device-tty.c src/device.c src/dired.c src/editfns.c src/faces.c src/fns.c src/lisp.h src/redisplay-tty.c |
| diffstat | 27 files changed, 1080 insertions(+), 1054 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/ChangeLog Sat Apr 23 23:47:13 2011 +0200 @@ -1,3 +1,110 @@ +2011-04-23 Aidan Kehoe <kehoea@parhasard.net> + + * font.el: + * font.el (font-warn): Removed. + * font.el (font-hex-string-to-number): Removed. + * font.el (internal-facep): + * font.el (font-lookup-rgb-components): + * font.el (font-parse-rgb-components): + Use #'string-to-number with the BASE argument instead of + #'font-hex-string-to-number, #'display-warning instead of + #'font-warn. + This entire file smells bitrotted, with lots of functions of very + little relevance to XEmacs, but addressing that is more work than + I can do today. + +2011-04-17 Aidan Kehoe <kehoea@parhasard.net> + + * cl-extra.el: + * cl-extra.el ('char<): New. + * cl-extra.el ('char>=): New. + * cl-extra.el ('char>): New. + * cl-extra.el ('char<=): New. + * cl-extra.el (alpha-char-p): New. + * cl-extra.el (graphic-char-p): New. + * cl-extra.el (standard-char-p): New. + * cl-extra.el (char-name): New. + * cl-extra.el (name-char): New. + * cl-extra.el (upper-case-p): New. + * cl-extra.el (lower-case-p): New. + * cl-extra.el (both-case-p): New. + * cl-extra.el (char-upcase): New. + * cl-extra.el (char-downcase): New. + * cl-extra.el (integer-length): New. + Add various functions dealing (mainly) with characters, making + some Common Lisp code easier to port. + * descr-text.el (describe-char-unicode-data): + Add an autoload for this function, used by #'char-name. + +2011-04-12 Aidan Kehoe <kehoea@parhasard.net> + + * mule/mule-win32-init.el (windows-874): + No longer create this coding system, now it's provided by thai.el; + thanks for the report of the associated Win32 build problem, Mats! + +2011-04-08 Aidan Kehoe <kehoea@parhasard.net> + + * unicode.el (load-unicode-tables): + No longer include thai-xtis in the default Unicode precedence list. + * mule/thai.el: + * mule/thai.el (tis-620): + * mule/thai.el (windows-874): + * mule/thai.el ("Thai"): + Move the Thai language environment and the TIS-620 coding system + to this file; add support for Microsoft's code page 874. + * mule/thai-util.el: + * mule/thai-xtis.el: + Remove these two files; XTIS was always non-standard and was never + widely implemented, and we've never supported the character + composition necessary for thai-util.el. + * dumped-lisp.el (preloaded-file-list): + Drop thai-xtis, dump thai.el instead. + +2011-04-02 Aidan Kehoe <kehoea@parhasard.net> + + * cl.el (cadr, caddr, cadddr): + Document some equivalences for these functions. + +2011-04-02 Aidan Kehoe <kehoea@parhasard.net> + + * bytecomp.el (byte-compile-output-preface): New. + * bytecomp.el (byte-compile-output-file-form): + * bytecomp.el (byte-compile-output-docform): + * bytecomp.el (byte-compile-file-form): + * bytecomp.el (byte-compile-file-form-defmumble): + * bytecomp.el (symbol-value): + * bytecomp.el (byte-compile-symbol-value): New. + * cl-macs.el (load-time-value): + No longer implement load-time-value by very hackishly redefining + #'byte-compile-file-form-defmumble, instead make the appropriate + changes in #'byte-compile-file-form-defmumble and + #'byte-compile-file-form instead. We also add a specific byte-compile + method for #'symbol-value, using the add-properties-to-a-gensym + approach that worked for #'block and #'return-from. + +2011-03-29 Aidan Kehoe <kehoea@parhasard.net> + + * cl-extra.el (cl-finite-do, cl-float-limits): + Don't make these available as functions in the dumped image, since + they're only called at dump time. + * obsolete.el (cl-float-limits): + Make this an alias to #'identity (since it's called at dump time), + mark it as obsolete in 21.5. + +2011-03-29 Aidan Kehoe <kehoea@parhasard.net> + + * cl.el: + * cl.el (least-positive-float): + * cl.el (least-positive-normalized-float): + * cl.el (least-negative-normalized-float): + * cl.el (float-epsilon): + * cl.el (float-negative-epsilon): + Document some previously-undocumented float constants here. + * cl.el (oddp): + * cl.el (evenp): + Change numeric comparison to use #'eql instead of #'eq in + passing. + 2011-03-24 Jerry James <james@xemacs.org> * cl-macs.el (loop): "arbitary" -> "arbitrary".
--- a/lisp/bytecomp.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/bytecomp.el Sat Apr 23 23:47:13 2011 +0200 @@ -453,6 +453,9 @@ "Alist of variables bound in the context of the current form, that is, the current lexical environment. This list lives partly on the specbind stack. The cdr of each cell is an integer bitmask.") +(defvar byte-compile-output-preface nil + "Form to output before current by `byte-compile-output-file-form' +This is used for implementing `load-time-value'.") (defvar byte-compile-force-escape-quoted nil "If t, `byte-compile-maybe-reset-coding' always chooses `escape-quoted' @@ -1975,8 +1978,12 @@ (not byte-compile-emacs19-compatibility)) '(t) nil)) print-gensym-alist) + (when byte-compile-output-preface + (princ "\n(progn " byte-compile-outbuffer) + (prin1 byte-compile-output-preface byte-compile-outbuffer)) (princ "\n" byte-compile-outbuffer) (prin1 form byte-compile-outbuffer) + (when byte-compile-output-preface (princ ")" byte-compile-outbuffer)) nil))) (defun byte-compile-output-docform (preface name info form specindex quoted) @@ -2014,12 +2021,6 @@ (> (length (nth (nth 1 info) form)) 0) (char= (aref (nth (nth 1 info) form) 0) ?*)) (setq position (- position))))) - - (if preface - (progn - (insert preface) - (prin1 name byte-compile-outbuffer))) - (insert (car info)) (let ((print-escape-newlines t) (print-readably t) ; print #[] for bytecode, 'x for (quote x) ;; Use a cons cell to say that we want @@ -2030,6 +2031,15 @@ '(t) nil)) print-gensym-alist (index 0)) + (when byte-compile-output-preface + (princ "\n(progn " byte-compile-outbuffer) + (prin1 byte-compile-output-preface byte-compile-outbuffer)) + (byte-compile-flush-pending) + (if preface + (progn + (insert preface) + (prin1 name byte-compile-outbuffer))) + (insert (car info)) (prin1 (car form) byte-compile-outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) @@ -2056,7 +2066,9 @@ (goto-char (point-max))))) (t (prin1 (car form) byte-compile-outbuffer))))) - (insert (nth 2 info)))))) + (insert (nth 2 info)) + (when byte-compile-output-preface + (princ ")" byte-compile-outbuffer)))))) nil) (defvar for-effect) ; ## Kludge! This should be an arg, not a special. @@ -2092,6 +2104,7 @@ (defun byte-compile-file-form (form) (let ((byte-compile-current-form nil) ; close over this for warnings. + (byte-compile-output-preface nil) handler) (cond ((not (consp form)) @@ -2327,11 +2340,11 @@ (code (byte-compile-byte-code-maker new-one)) (docform-info (cond ((atom code) ; compiled-function-p - (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) + (if macrop '(" '(macro . #[" 4 "]))") '(" #[" 4 "])"))) ((eq (car code) 'quote) (setq code new-one) - (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) - ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))))) + (if macrop '(" '(macro " 2 "))") '(" '(" 2 "))"))) + ((if macrop '(" (cons 'macro (" 5 ")))") '(" (" 5 "))")))))) (if this-one (setcdr this-one new-one) (set this-kind @@ -2358,18 +2371,16 @@ ;; printed to the file. (if (consp code) code - (nconc (list - (compiled-function-arglist code) - (compiled-function-instructions code) - (compiled-function-constants code) - (compiled-function-stack-depth code) - (compiled-function-doc-string code)) + (list* (compiled-function-arglist code) + (compiled-function-instructions code) + (compiled-function-constants code) + (compiled-function-stack-depth code) + (compiled-function-doc-string code) (if (commandp code) (list (nth 1 (compiled-function-interactive code)))))) (and (atom code) byte-compile-dynamic 1) nil)) - (princ ")" byte-compile-outbuffer) nil))) ;; Print Lisp object EXP in the output file, inside a comment, @@ -3141,7 +3152,7 @@ (byte-defop-compiler car 1) (byte-defop-compiler cdr 1) (byte-defop-compiler length 1) -(byte-defop-compiler symbol-value 1) +(byte-defop-compiler symbol-value) (byte-defop-compiler symbol-function 1) (byte-defop-compiler (1+ byte-add1) 1) (byte-defop-compiler (1- byte-sub1) 1) @@ -4312,6 +4323,29 @@ (byte-compile-body (cdr (cdr form))) (byte-compile-out 'byte-temp-output-buffer-show 0)) +(defun byte-compile-symbol-value (form) + (symbol-macrolet ((not-present '#:not-present)) + (let ((cl-load-time-value-form not-present) + (byte-compile-bound-variables byte-compile-bound-variables) gensym) + (and (consp (cadr form)) + (eq 'quote (caadr form)) + (setq gensym (cadadr form)) + (symbolp gensym) + (setq cl-load-time-value-form + (get gensym 'cl-load-time-value-form not-present))) + (unless (eq cl-load-time-value-form not-present) + (setq byte-compile-bound-variables + (acons gensym byte-compile-global-bit + byte-compile-bound-variables) + byte-compile-output-preface + (byte-compile-top-level + (if byte-compile-output-preface + `(progn (setq ,gensym ,cl-load-time-value-form) + ,byte-compile-output-preface) + `(setq ,gensym ,cl-load-time-value-form)) + t 'file))) + (byte-compile-one-arg form)))) + (defun byte-compile-multiple-value-call (form) (if (< (length form) 2) (progn
--- a/lisp/cl-extra.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/cl-extra.el Sat Apr 23 23:47:13 2011 +0200 @@ -363,52 +363,6 @@ (and (vectorp object) (= (length object) 4) (eq (aref object 0) 'cl-random-state-tag))) - -;; Implementation limits. - -(defun cl-finite-do (func a b) - (condition-case nil - (let ((res (funcall func a b))) ; check for IEEE infinity - (and (numberp res) (/= res (/ res 2)) res)) - (arith-error nil))) - -(defun cl-float-limits () - (or most-positive-float (not (numberp '2e1)) - (let ((x '2e0) y z) - ;; Find maximum exponent (first two loops are optimizations) - (while (cl-finite-do '* x x) (setq x (* x x))) - (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) - (while (cl-finite-do '+ x x) (setq x (+ x x))) - (setq z x y (/ x 2)) - ;; Now fill in 1's in the mantissa. - (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) - (setq x (+ x y) y (/ y 2))) - (setq most-positive-float x - most-negative-float (- x)) - ;; Divide down until mantissa starts rounding. - (setq x (/ x z) y (/ 16 z) x (* x y)) - (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) - (arith-error nil)) - (setq x (/ x 2) y (/ y 2))) - (setq least-positive-normalized-float y - least-negative-normalized-float (- y)) - ;; Divide down until value underflows to zero. - (setq x (/ 1 z) y x) - (while (condition-case nil (> (/ x 2) 0) (arith-error nil)) - (setq x (/ x 2))) - (setq least-positive-float x - least-negative-float (- x)) - (setq x '1e0) - (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-epsilon (* x 2)) - (setq x '1e0) - (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-negative-epsilon (* x 2)))) - nil) - -;; XEmacs; call cl-float-limits at dump time. -(cl-float-limits) - ;;; Sequence functions. ;; XEmacs; #'subseq is in C. @@ -691,6 +645,181 @@ ;; files to do the same, multiple times. (eval-when-compile (or (cl-compiling-file) (load "cl-macs"))) +;; Implementation limits. + +;; XEmacs; call cl-float-limits at dump time. +(labels + ((cl-finite-do (func a b) + (condition-case nil + (let ((res (funcall func a b))) ; check for IEEE infinity + (and (numberp res) (/= res (/ res 2)) res)) + (arith-error nil))) + (cl-float-limits () + (unless most-positive-float + (let ((x 2e0) y z) + ;; Find maximum exponent (first two loops are optimizations) + (while (cl-finite-do '* x x) (setq x (* x x))) + (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) + (while (cl-finite-do '+ x x) (setq x (+ x x))) + (setq z x y (/ x 2)) + ;; Now fill in 1's in the mantissa. + (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) + (setq x (+ x y) y (/ y 2))) + (setq most-positive-float x + most-negative-float (- x)) + ;; Divide down until mantissa starts rounding. + (setq x (/ x z) y (/ 16 z) x (* x y)) + (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) + (arith-error nil)) + (setq x (/ x 2) y (/ y 2))) + (setq least-positive-normalized-float y + least-negative-normalized-float (- y)) + ;; Divide down until value underflows to zero. + (setq x (/ 1 z) y x) + (while (condition-case nil (> (/ x 2) 0) (arith-error nil)) + (setq x (/ x 2))) + (setq least-positive-float x + least-negative-float (- x)) + (setq x 1e0) + (while (/= (+ 1e0 x) 1e0) (setq x (/ x 2))) + (setq float-epsilon (* x 2)) + (setq x 1e0) + (while (/= (- 1e0 x) 1e0) (setq x (/ x 2))) + (setq float-negative-epsilon (* x 2)))))) + (cl-float-limits)) + +;; No type-checking here, we should add it. +(defalias 'char< '<) +(defalias 'char>= '>=) +(defalias 'char> '>) +(defalias 'char<= '<=) + +;;; Character functions. +(defun* digit-char-p (character &optional (radix 10)) + "Return non-nil if CHARACTER represents a digit in base RADIX. + +RADIX defaults to ten. The actual non-nil value returned is the integer +value of the character in base RADIX." + (check-type character character) + (check-type radix integer) + (if (<= radix 10) + (and (<= ?0 character (+ ?0 radix -1)) (- character ?0)) + (or (and (<= ?0 character ?9) (- character ?0)) + (and (<= ?a character (+ ?a (setq radix (- radix 11)))) + (+ character (- 10 ?a))) + (and (<= ?A character (+ ?A radix)) + (+ character (- 10 ?A)))))) + +(defun* digit-char (weight &optional (radix 10)) + "Return a character representing the integer WEIGHT in base RADIX. + +RADIX defaults to ten. If no such character exists, return nil." + (check-type weight integer) + (check-type radix integer) + (and (natnump weight) (< weight radix) + (if (< weight 10) + (int-char (+ ?0 weight)) + (int-char (+ ?A (- weight 10)))))) + +(defun alpha-char-p (character) + "Return t if CHARACTER is alphabetic, in some alphabet. + +Han characters are regarded as alphabetic." + (check-type character character) + (and (eql ?w (char-syntax character (standard-syntax-table))) + (not (<= ?0 character ?9)))) + +(defun graphic-char-p (character) + "Return t if CHARACTER is not a control character. + +Control characters are those in the range ?\\x00 to ?\\x15 and ?\\x7f to +?\\x9f, inclusive." + (check-type character character) + (not (or (<= ?\x00 character ?\x1f) (<= ?\x7f character ?\x9f)))) + +(defun standard-char-p (character) + "Return t if CHARACTER is one of Common Lisp's standard characters. + +These are the non-control ASCII characters, plus the newline character." + (check-type character character) + (or (<= ?\x20 character ?\x7e) (eql character ?\n))) + +(symbol-macrolet + ((names '((?\x08 . "Backspace") (?\x09 . "Tab") (?\x0a . "Newline") + (?\x0C . "Page") (?\x0d . "Return") (?\x20 . "Space") + (?\x7f . "Rubout")))) + + (defun char-name (character) + "Return a string naming CHARACTER. + +For the limited number of characters where the character name has been +specified by Common Lisp, this always returns the appropriate string +name. Otherwise, `char-name' requires that the Unicode database be +available; see `describe-char-unicode-data'." + (check-type character character) + (or (cdr (assq character names)) + (let ((unicode-data + (assoc "Name" (describe-char-unicode-data character)))) + (and unicode-data + (if (string-match "^<[^>]+>$" (cadr unicode-data)) + (format "U%04X" (char-to-unicode character)) + (replace-in-string (cadr unicode-data) " " "_" t)))))) + + (defun name-char (name) + "Return a character with name NAME, a string." + (or (car (rassoc* name names :test #'equalp)) + (if (string-match "^[uU][0-9A-Fa-f]+$" name) + (unicode-to-char (string-to-number (subseq name 1) 16)) + (with-current-buffer (get-buffer-create " *Unicode Data*") + (require 'descr-text) + (when (zerop (buffer-size)) + ;; Don't use -literally in case of DOS line endings. + (insert-file-contents describe-char-unicodedata-file)) + (goto-char (point-min)) + (setq case-fold-search nil) + (and (re-search-forward (format #r"^\([0-9A-F]\{4,6\}\);%s;" + (upcase (replace-in-string + name "_" " " t))) nil t) + (unicode-to-char (string-to-number (match-string 1) 16)))))))) + +(defun upper-case-p (character) + "Return t if CHARACTER is majuscule in the standard case table." + (and (stringp character) (check-type character character)) + (with-case-table (standard-case-table) + (not (eq character (downcase character))))) + +(defun lower-case-p (character) + "Return t if CHARACTER is minuscule in the standard case table." + (and (stringp character) (check-type character character)) + (with-case-table (standard-case-table) + (not (eq character (upcase character))))) + +(defun both-case-p (character) + "Return t if CHARACTER has case information in the standard case table." + (and (stringp character) (check-type character character)) + (with-case-table (standard-case-table) + (or (not (eq character (upcase character))) + (not (eq character (downcase character)))))) + +(defun char-upcase (character) + "If CHARACTER is lowercase, return its corresponding uppercase character. +Otherwise, return CHARACTER." + (and (stringp character) (check-type character character)) + (with-case-table (standard-case-table) (upcase character))) + +(defun char-downcase (character) + "If CHARACTER is uppercase, return its corresponding lowercase character. +Otherwise, return CHARACTER." + (and (stringp character) (check-type character character)) + (with-case-table (standard-case-table) (downcase character))) + +(defun integer-length (integer) + "Return the number of bits need to represent INTEGER in two's complement." + (ecase (signum integer) + (0 0) + (-1 (1- (length (format "%b" (- integer))))) + (1 (length (format "%b" integer))))) + (run-hooks 'cl-extra-load-hook) ;; XEmacs addition
--- a/lisp/cl-macs.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/cl-macs.el Sat Apr 23 23:47:13 2011 +0200 @@ -619,25 +619,15 @@ (defmacro load-time-value (form &optional read-only) "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." - (if (cl-compiling-file) - (let* ((temp (gentemp "--cl-load-time--")) - (set (list 'set (list 'quote temp) form))) - (if (and (fboundp 'byte-compile-file-form-defmumble) - (boundp 'this-kind) (boundp 'that-one)) - (fset 'byte-compile-file-form - (list 'lambda '(form) - (list 'fset '(quote byte-compile-file-form) - (list 'quote - (symbol-function 'byte-compile-file-form))) - (list 'byte-compile-file-form (list 'quote set)) - '(byte-compile-file-form form))) - ;; XEmacs change - (print set (symbol-value ;;'outbuffer - 'byte-compile-output-buffer - ))) - (list 'symbol-value (list 'quote temp))) - (list 'quote (eval form)))) - + (let ((gensym (gensym))) + ;; The body of this macro really should be (cons 'progn form), with the + ;; hairier stuff in a shadowed version in + ;; byte-compile-initial-macro-environment. That doesn't work because + ;; cl-macs.el doesn't respect byte-compile-macro-environment, which is + ;; something we should change. + (put gensym 'cl-load-time-value-form form) + (set gensym (eval form)) + `(symbol-value ',gensym))) ;;; Conditional control structures.
--- a/lisp/cl.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/cl.el Sat Apr 23 23:47:13 2011 +0200 @@ -310,11 +310,11 @@ (defun oddp (integer) "Return t if INTEGER is odd." - (eq (logand integer 1) 1)) + (eql (logand integer 1) 1)) (defun evenp (integer) "Return t if INTEGER is even." - (eq (logand integer 1) 0)) + (eql (logand integer 1) 0)) ;; XEmacs addition (defalias 'cl-abs 'abs) @@ -327,13 +327,35 @@ (defconst most-negative-float nil "The float closest in value to negative infinity.") (defconst least-positive-float nil - "The positive float closest in value to 0.") + "The positive float closest in value to zero.") (defconst least-negative-float nil - "The negative float closest in value to 0.") -(defconst least-positive-normalized-float nil) -(defconst least-negative-normalized-float nil) -(defconst float-epsilon nil) -(defconst float-negative-epsilon nil) + "The negative float closest in value to zero.") +(defconst least-positive-normalized-float nil + "The normalized positive float closest in value to zero. + +A float is normalized if the most significant bit of its mantissa is 1. +Use of denormalized (equivalently, subnormal) floats in calculations will +lead to gradual underflow, though they can be more accurate in representing +individual small values. Normal and subnormal floats are as described in +IEEE 754.") + +(defconst least-negative-normalized-float nil + "The normalized negative float closest in value to zero. + +See `least-positive-normalized-float' for details of normal and denormalized +numbers.") + +(defconst float-epsilon nil + "The smallest float guaranteed not `eql' to 1.0 when added to 1.0. + +That is, (eql 1.0 (+ 1.0 X)) will always give nil if (<= float-epsilon X) , +but it may give t for smaller values.") + +(defconst float-negative-epsilon nil + "The smallest float guaranteed not `eql' to 1.0 when subtracted from 1.0. + +That is, (eql 1.0 (- 1.0 X)) will always give nil if (<= +float-negative-epsilon X) , but it may give t for smaller values.") ;;; Sequence functions. @@ -401,7 +423,7 @@ (car (car x))) (defun cadr (x) - "Return the `car' of the `cdr' of X." + "Return the `car' of the `cdr' of X. Equivalent to `(second X)'." (car (cdr x))) (defun cdar (x) @@ -425,7 +447,8 @@ (car (cdr (car x)))) (defun caddr (x) - "Return the `car' of the `cdr' of the `cdr' of X." + "Return the `car' of the `cdr' of the `cdr' of X. +Equivalent to `(third X)'." (car (cdr (cdr x)))) (defun cdaar (x) @@ -473,7 +496,8 @@ (car (cdr (cdr (car x))))) (defun cadddr (x) - "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." + "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X. +Equivalent to `(fourth X)'." (car (cdr (cdr (cdr x))))) (defun cdaaar (x)
--- a/lisp/descr-text.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/descr-text.el Sat Apr 23 23:47:13 2011 +0200 @@ -673,6 +673,7 @@ database-file-name))) ;; End XEmacs additions. +;;;###autoload (defun describe-char-unicode-data (char) "Return a list of Unicode data for unicode CHAR. Each element is a list of a property description and the property value.
--- a/lisp/dumped-lisp.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/dumped-lisp.el Sat Apr 23 23:47:13 2011 +0200 @@ -220,10 +220,7 @@ "mule/lao" ; sucks. "mule/latin" "mule/misc-lang" - ;; "thai" #### merge thai and thai-xtis!!! - ;; #### Even better; take out thai-xtis! It's not even a - ;; standard, and no-one uses it. - "mule/thai-xtis" + "mule/thai" "mule/tibetan" "mule/vietnamese" ))
--- a/lisp/font.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/font.el Sat Apr 23 23:47:13 2011 +0200 @@ -48,9 +48,6 @@ get-fontset-info mswindows-define-rgb-color cancel-function-timers mswindows-font-regexp mswindows-canonicalize-font-name mswindows-parse-font-style mswindows-construct-font-style - ;; #### perhaps we should rewrite font-warn to avoid the warning - ;; Eh, now I look at the code, we definitely should. - font-warn fc-pattern-get-family fc-pattern-get-size fc-pattern-get-weight fc-font-weight-translate-from-constant make-fc-pattern fc-pattern-add-family fc-pattern-add-size)) @@ -1070,24 +1067,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Various color related things ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(cond - ((fboundp 'display-warning) - (fset 'font-warn 'display-warning)) - ((fboundp 'w3-warn) - (fset 'font-warn 'w3-warn)) - ((fboundp 'url-warn) - (fset 'font-warn 'url-warn)) - ((fboundp 'warn) - (defun font-warn (class message &optional level) - (warn "(%s/%s) %s" class (or level 'warning) message))) - (t - (defun font-warn (class message &optional level) - (save-excursion - (set-buffer (get-buffer-create "*W3-WARNINGS*")) - (goto-char (point-max)) - (save-excursion - (insert (format "(%s/%s) %s\n" class (or level 'warning) message))) - (display-buffer (current-buffer)))))) (defun font-lookup-rgb-components (color) "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values. @@ -1142,32 +1121,12 @@ (setq r (* (read (current-buffer)) 256) g (* (read (current-buffer)) 256) b (* (read (current-buffer)) 256))) - (font-warn 'color (format "No such color: %s" color)) + (display-warning 'color (format "No such color: %s" color)) (setq r 0 g 0 b 0)) (list r g b) )))))) -(defun font-hex-string-to-number (string) - "Convert STRING to an integer by parsing it as a hexadecimal number." - (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10) - (?1 . 1) (?b . 11) (?B . 11) - (?2 . 2) (?c . 12) (?C . 12) - (?3 . 3) (?d . 13) (?D . 13) - (?4 . 4) (?e . 14) (?E . 14) - (?5 . 5) (?f . 15) (?F . 15) - (?6 . 6) - (?7 . 7) - (?8 . 8) - (?9 . 9))) - (n 0) - (i 0) - (lim (length string))) - (while (< i lim) - (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0)) - i (1+ i))) - n )) - (defun font-parse-rgb-components (color) "Parse RGB color specification and return a list of integers (R G B). #FEFEFE and rgb:fe/fe/fe style specifications are parsed." @@ -1176,33 +1135,33 @@ (cond ((string-match "^#[0-9a-f]+$" color) (cond ((eql (length color) 4) - (setq r (font-hex-string-to-number (substring color 1 2)) - g (font-hex-string-to-number (substring color 2 3)) - b (font-hex-string-to-number (substring color 3 4)) + (setq r (string-to-number (substring color 1 2) 16) + g (string-to-number (substring color 2 3) 16) + b (string-to-number (substring color 3 4) 16) r (* r 4096) g (* g 4096) b (* b 4096))) ((eql (length color) 7) - (setq r (font-hex-string-to-number (substring color 1 3)) - g (font-hex-string-to-number (substring color 3 5)) - b (font-hex-string-to-number (substring color 5 7)) + (setq r (string-to-number (substring color 1 3) 16) + g (string-to-number (substring color 3 5) 16) + b (string-to-number (substring color 5 7) 16) r (* r 256) g (* g 256) b (* b 256))) ((eql (length color) 10) - (setq r (font-hex-string-to-number (substring color 1 4)) - g (font-hex-string-to-number (substring color 4 7)) - b (font-hex-string-to-number (substring color 7 10)) + (setq r (string-to-number (substring color 1 4) 16) + g (string-to-number (substring color 4 7) 16) + b (string-to-number (substring color 7 10) 16) r (* r 16) g (* g 16) b (* b 16))) ((eql (length color) 13) - (setq r (font-hex-string-to-number (substring color 1 5)) - g (font-hex-string-to-number (substring color 5 9)) - b (font-hex-string-to-number (substring color 9 13)))) + (setq r (string-to-number (substring color 1 5) 16) + g (string-to-number (substring color 5 9) 16) + b (string-to-number (substring color 9 13) 16))) (t - (font-warn 'color (format "Invalid RGB color specification: %s" - color)) + (display-warning 'color + (format "Invalid RGB color specification: %s" color)) (setq r 0 g 0 b 0)))) @@ -1213,17 +1172,17 @@ (> (- (match-end 3) (match-beginning 3)) 4)) (error "Invalid RGB color specification: %s" color) (setq str (match-string 1 color) - r (* (font-hex-string-to-number str) + r (* (string-to-number str 16) (expt 16 (- 4 (length str)))) str (match-string 2 color) - g (* (font-hex-string-to-number str) + g (* (string-to-number str 16) (expt 16 (- 4 (length str)))) str (match-string 3 color) - b (* (font-hex-string-to-number str) + b (* (string-to-number str 16) (expt 16 (- 4 (length str))))))) (t - (font-warn 'html (format "Invalid RGB color specification: %s" - color)) + (display-warning 'color (format "Invalid RGB color specification: %s" + color)) (setq r 0 g 0 b 0)))
--- a/lisp/mule/mule-win32-init.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/mule/mule-win32-init.el Sat Apr 23 23:47:13 2011 +0200 @@ -139,7 +139,7 @@ ("OEM" 865 no-conversion "MS-DOS Nordic") ; ("OEM" 866 no-conversion "MS-DOS Russian") ("OEM" 869 no-conversion "IBM Modern Greek") - ("Ansi/OEM" 874 no-conversion "Thai") + ; ("Ansi/OEM" 874 no-conversion "Thai") ("EBCDIC" 875 no-conversion "EBCDIC") ("Ansi/OEM" 932 shift_jis "Japanese") ("Ansi/OEM" 936 iso_8_2 "Chinese (PRC, Singapore)")
--- a/lisp/mule/thai-util.el Tue Mar 29 00:02:47 2011 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,209 +0,0 @@ -;;; thai-util.el --- utilities for Thai -*- coding: iso-2022-7bit; -*- - -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: mule, multilingual, thai - -;; This file is part of XEmacs. - -;; XEmacs is free software: you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by the -;; Free Software Foundation, either version 3 of the License, or (at your -;; option) any later version. - -;; XEmacs is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -;; for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Synched up with: Emacs 21.1 (language/thai-util.el). - -;;; Commentary: - -;;; Code: - -;; Setting information of Thai characters. - -(defconst thai-category-table (make-category-table)) -(define-category ?c "Thai consonant" thai-category-table) -(define-category ?v "Thai upper/lower vowel" thai-category-table) -(define-category ?t "Thai tone" thai-category-table) - -;; The general composing rules are as follows: -;; -;; T -;; V T V T -;; CV -> C, CT -> C, CVT -> C, Cv -> C, CvT -> C -;; v v -;; -;; where C: consonant, V: vowel upper, v: vowel lower, T: tone mark. - -(defvar thai-composition-pattern "\\cc\\(\\ct\\|\\cv\\ct?\\)" - "Regular expression matching a Thai composite sequence.") - -(let ((l '((?,T!(B consonant "LETTER KO KAI") ; 0xA1 - (?,T"(B consonant "LETTER KHO KHAI") ; 0xA2 - (?,T#(B consonant "LETTER KHO KHUAT") ; 0xA3 - (?,T$(B consonant "LETTER KHO KHWAI") ; 0xA4 - (?,T%(B consonant "LETTER KHO KHON") ; 0xA5 - (?,T&(B consonant "LETTER KHO RAKHANG") ; 0xA6 - (?,T'(B consonant "LETTER NGO NGU") ; 0xA7 - (?,T((B consonant "LETTER CHO CHAN") ; 0xA8 - (?,T)(B consonant "LETTER CHO CHING") ; 0xA9 - (?,T*(B consonant "LETTER CHO CHANG") ; 0xAA - (?,T+(B consonant "LETTER SO SO") ; 0xAB - (?,T,(B consonant "LETTER CHO CHOE") ; 0xAC - (?,T-(B consonant "LETTER YO YING") ; 0xAD - (?,T.(B consonant "LETTER DO CHADA") ; 0xAE - (?,T/(B consonant "LETTER TO PATAK") ; 0xAF - (?,T0(B consonant "LETTER THO THAN") ; 0xB0 - (?,T1(B consonant "LETTER THO NANGMONTHO") ; 0xB1 - (?,T2(B consonant "LETTER THO PHUTHAO") ; 0xB2 - (?,T3(B consonant "LETTER NO NEN") ; 0xB3 - (?,T4(B consonant "LETTER DO DEK") ; 0xB4 - (?,T5(B consonant "LETTER TO TAO") ; 0xB5 - (?,T6(B consonant "LETTER THO THUNG") ; 0xB6 - (?,T7(B consonant "LETTER THO THAHAN") ; 0xB7 - (?,T8(B consonant "LETTER THO THONG") ; 0xB8 - (?,T9(B consonant "LETTER NO NU") ; 0xB9 - (?,T:(B consonant "LETTER BO BAIMAI") ; 0xBA - (?,T;(B consonant "LETTER PO PLA") ; 0xBB - (?,T<(B consonant "LETTER PHO PHUNG") ; 0xBC - (?,T=(B consonant "LETTER FO FA") ; 0xBD - (?,T>(B consonant "LETTER PHO PHAN") ; 0xBE - (?,T?(B consonant "LETTER FO FAN") ; 0xBF - (?,T@(B consonant "LETTER PHO SAMPHAO") ; 0xC0 - (?,TA(B consonant "LETTER MO MA") ; 0xC1 - (?,TB(B consonant "LETTER YO YAK") ; 0xC2 - (?,TC(B consonant "LETTER RO RUA") ; 0xC3 - (?,TD(B vowel-base "LETTER RU (Pali vowel letter)") ; 0xC4 - (?,TE(B consonant "LETTER LO LING") ; 0xC5 - (?,TF(B vowel-base "LETTER LU (Pali vowel letter)") ; 0xC6 - (?,TG(B consonant "LETTER WO WAEN") ; 0xC7 - (?,TH(B consonant "LETTER SO SALA") ; 0xC8 - (?,TI(B consonant "LETTER SO RUSI") ; 0xC9 - (?,TJ(B consonant "LETTER SO SUA") ; 0xCA - (?,TK(B consonant "LETTER HO HIP") ; 0xCB - (?,TL(B consonant "LETTER LO CHULA") ; 0xCC - (?,TM(B consonant "LETTER O ANG") ; 0xCD - (?,TN(B consonant "LETTER HO NOK HUK") ; 0xCE - (?,TO(B special "PAI YAN NOI (abbreviation)") ; 0xCF - (?,TP(B vowel-base "VOWEL SIGN SARA A") ; 0xD0 - (?,TQ(B vowel-upper "VOWEL SIGN MAI HAN-AKAT N/S-T") ; 0xD1 - (?,TR(B vowel-base "VOWEL SIGN SARA AA") ; 0xD2 - (?,TS(B vowel-base "VOWEL SIGN SARA AM") ; 0xD3 - (?,TT(B vowel-upper "VOWEL SIGN SARA I N/S-T") ; 0xD4 - (?,TU(B vowel-upper "VOWEL SIGN SARA II N/S-T") ; 0xD5 - (?,TV(B vowel-upper "VOWEL SIGN SARA UE N/S-T") ; 0xD6 - (?,TW(B vowel-upper "VOWEL SIGN SARA UEE N/S-T") ; 0xD7 - (?,TX(B vowel-lower "VOWEL SIGN SARA U N/S-B") ; 0xD8 - (?,TY(B vowel-lower "VOWEL SIGN SARA UU N/S-B") ; 0xD9 - (?,TZ(B vowel-lower "VOWEL SIGN PHINTHU N/S-B (Pali virama)") ; 0xDA - (?,T[(B invalid nil) ; 0xDA - (?,T\(B invalid nil) ; 0xDC - (?,T](B invalid nil) ; 0xDC - (?,T^(B invalid nil) ; 0xDC - (?,T_(B special "BAHT SIGN (currency symbol)") ; 0xDF - (?,T`(B vowel-base "VOWEL SIGN SARA E") ; 0xE0 - (?,Ta(B vowel-base "VOWEL SIGN SARA AE") ; 0xE1 - (?,Tb(B vowel-base "VOWEL SIGN SARA O") ; 0xE2 - (?,Tc(B vowel-base "VOWEL SIGN SARA MAI MUAN") ; 0xE3 - (?,Td(B vowel-base "VOWEL SIGN SARA MAI MALAI") ; 0xE4 - (?,Te(B vowel-base "LAK KHANG YAO") ; 0xE5 - (?,Tf(B special "MAI YAMOK (repetition)") ; 0xE6 - (?,Tg(B vowel-upper "VOWEL SIGN MAI TAI KHU N/S-T") ; 0xE7 - (?,Th(B tone "TONE MAI EK N/S-T") ; 0xE8 - (?,Ti(B tone "TONE MAI THO N/S-T") ; 0xE9 - (?,Tj(B tone "TONE MAI TRI N/S-T") ; 0xEA - (?,Tk(B tone "TONE MAI CHATTAWA N/S-T") ; 0xEB - (?,Tl(B tone "THANTHAKHAT N/S-T (cancellation mark)") ; 0xEC - (?,Tm(B tone "NIKKHAHIT N/S-T (final nasal)") ; 0xED - (?,Tn(B vowel-upper "YAMAKKAN N/S-T") ; 0xEE - (?,To(B special "FONRMAN") ; 0xEF - (?,Tp(B special "DIGIT ZERO") ; 0xF0 - (?,Tq(B special "DIGIT ONE") ; 0xF1 - (?,Tr(B special "DIGIT TWO") ; 0xF2 - (?,Ts(B special "DIGIT THREE") ; 0xF3 - (?,Tt(B special "DIGIT FOUR") ; 0xF4 - (?,Tu(B special "DIGIT FIVE") ; 0xF5 - (?,Tv(B special "DIGIT SIX") ; 0xF6 - (?,Tw(B special "DIGIT SEVEN") ; 0xF7 - (?,Tx(B special "DIGIT EIGHT") ; 0xF8 - (?,Ty(B special "DIGIT NINE") ; 0xF9 - (?,Tz(B special "ANGKHANKHU (ellipsis)") ; 0xFA - (?,T{(B special "KHOMUT (beginning of religious texts)") ; 0xFB - (?,T|(B invalid nil) ; 0xFC - (?,T}(B invalid nil) ; 0xFD - (?,T~(B invalid nil) ; 0xFE - )) - elm) - (while l - (setq elm (car l) l (cdr l)) - (let ((char (car elm)) - (ptype (nth 1 elm))) - (put-char-code-property char 'phonetic-type ptype) - (cond ((eq ptype 'consonant) - (modify-category-entry char ?c thai-category-table)) - ((memq ptype '(vowel-upper vowel-lower)) - (modify-category-entry char ?v thai-category-table)) - ((eq ptype 'tone) - (modify-category-entry char ?t thai-category-table))) - (put-char-code-property char 'name (nth 2 elm))))) - -;;;###autoload -(defun thai-compose-region (beg end) - "Compose Thai characters in the region. -When called from a program, expects two arguments, -positions (integers or markers) specifying the region." - (interactive "r") - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (with-category-table thai-category-table - (while (re-search-forward thai-composition-pattern nil t) - (compose-region (match-beginning 0) (match-end 0)))))) - -;;;###autoload -(defun thai-compose-string (string) - "Compose Thai characters in STRING and return the resulting string." - (with-category-table thai-category-table - (let ((idx 0)) - (while (setq idx (string-match thai-composition-pattern string idx)) - (compose-string string idx (match-end 0)) - (setq idx (match-end 0))))) - string) - -;;;###autoload -(defun thai-compose-buffer () - "Compose Thai characters in the current buffer." - (interactive) - (thai-compose-region (point-min) (point-max))) - -;;;###autoload -(defun thai-post-read-conversion (len) - (thai-compose-region (point) (+ (point) len)) - len) - -;;;###autoload -(defun thai-composition-function (from to pattern &optional string) - "Compose Thai text in the region FROM and TO. -The text matches the regular expression PATTERN. -Optional 4th argument STRING, if non-nil, is a string containing text -to compose. - -The return value is number of composed characters." - (if (< (1+ from) to) - (prog1 (- to from) - (if string - (compose-string string from to) - (compose-region from to)) - (- to from)))) - -;; -(provide 'thai-util) - -;;; thai-util.el ends here
--- a/lisp/mule/thai-xtis.el Tue Mar 29 00:02:47 2011 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,368 +0,0 @@ -;;; thai-xtis.el --- Support for Thai (XTIS) -*- coding: iso-2022-7bit; -*- - -;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Author: TAKAHASHI Naoto <ntakahas@etl.go.jp> -;; MORIOKA Tomohiko <tomo@etl.go.jp> -;; Created: 1998-03-27 for Emacs-20.3 by TAKAHASHI Naoto -;; 1999-03-29 imported and modified for XEmacs by MORIOKA Tomohiko - -;; Keywords: mule, multilingual, Thai, XTIS - -;; This file is part of XEmacs. - -;; XEmacs is free software: you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by the -;; Free Software Foundation, either version 3 of the License, or (at your -;; option) any later version. - -;; XEmacs is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -;; for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; For Thai, the pre-composed character set proposed by -;; Virach Sornlertlamvanich <virach@links.nectec.or.th> is supported. - -;;; Code: - -(make-charset 'thai-xtis "Precomposed Thai (XTIS by Virach)." - '(registries ["xtis-0"] - dimension 2 - columns 1 - chars 94 - final ?? - graphic 0)) - -(define-category ?x "Precomposed Thai character.") -(modify-category-entry 'thai-xtis ?x) - -(when (featurep 'xemacs) - (let ((deflist '(;; chars syntax - ("$(?!0(B-$(?NxP0R0S0`0(B-$(?e0(B" "w") - ("$(?p0(B-$(?y0(B" "w") - ("$(?O0f0_0o0z0{0(B" "_") - )) - elm chars len syntax to ch i) - (while deflist - (setq elm (car deflist)) - (setq chars (car elm) - len (length chars) - syntax (nth 1 elm) - i 0) - (while (< i len) - (if (= (aref chars i) ?-) - (setq i (1+ i) - to (nth 1 (split-char (aref chars i)))) - (setq ch (nth 1 (split-char (aref chars i))) - to ch)) - (while (<= ch to) - (modify-syntax-entry (vector 'thai-xtis ch) syntax) - (setq ch (1+ ch))) - (setq i (1+ i))) - (setq deflist (cdr deflist)))) - - (put-charset-property 'thai-xtis 'preferred-coding-system 'tis-620) - ) - -;; This is the ccl-decode-thai-xtis automaton. -;; -;; "WRITE x y" == (insert (make-char 'thai-xtis x y)) -;; "write x" == (insert x) -;; rx' == (tis620-to-thai-xtis-second-byte-bitpattern rx) -;; r3 == "no vower nor tone" -;; r4 == (charset-id 'thai-xtis) -;; -;; | input (= r0) -;; state |-------------------------------------------- -;; | consonant | vowel | tone -;; ---------+-------------+-------------+---------------- -;; r1 == 0 | r1 = r0 | WRITE r0,r3 | WRITE r0,r3 -;; r2 == 0 | | | -;; ---------+-------------+-------------+---------------- -;; r1 == C | WRITE r1,r3 | r2 = r0' | WRITE r1,r3|r0' -;; r2 == 0 | r1 = r0 | | r1 = 0 -;; ---------+-------------+-------------+---------------- -;; r1 == C | WRITE r1,r2 | WRITE r1,r2 | WRITE r1,r2|r0' -;; r2 == V | r1 = r0 | WRITE r0,r3 | r1 = r2 = 0 -;; | r2 = 0 | r1 = r2 = 0 | -;; -;; -;; | input (= r0) -;; state |----------------------------------------- -;; | symbol | ASCII | EOF -;; ---------+-------------+-------------+------------- -;; r1 == 0 | WRITE r0,r3 | write r0 | -;; r2 == 0 | | | -;; ---------+-------------+-------------+------------- -;; r1 == C | WRITE r1,r3 | WRITE r1,r3 | WRITE r1,r3 -;; r2 == 0 | WRITE r0,r3 | write r0 | -;; | r1 = 0 | r1 = 0 | -;; ---------+-------------+-------------+------------- -;; r1 == C | WRITE r1,r2 | WRITE r1,r2 | WRITE r1,r2 -;; r2 == V | WRITE r0,r3 | write r0 | -;; | r1 = r2 = 0 | r1 = r2 = 0 | - - -(eval-and-compile - -;; input : r5 = 1st byte, r6 = 2nd byte -;; Their values will be destroyed. -(define-ccl-program ccl-thai-xtis-write - '(0 - ((r5 = ((r5 & #x7F) << 7)) - (r6 = ((r6 & #x7F) | r5)) - (write-multibyte-character r4 r6)))) - -(define-ccl-program ccl-thai-xtis-consonant - '(0 - (if (r1 == 0) - (r1 = r0) - (if (r2 == 0) - ((r5 = r1) (r6 = r3) (call ccl-thai-xtis-write) - (r1 = r0)) - ((r5 = r1) (r6 = r2) (call ccl-thai-xtis-write) - (r1 = r0) - (r2 = 0)))))) - -(define-ccl-program ccl-thai-xtis-vowel - '(0 - ((if (r1 == 0) - ((r5 = r0) (r6 = r3) (call ccl-thai-xtis-write)) - ((if (r2 == 0) - (r2 = ((r0 - 204) << 3)) - ((r5 = r1) (r6 = r2) (call ccl-thai-xtis-write) - (r5 = r0) (r6 = r3) (call ccl-thai-xtis-write) - (r1 = 0) - (r2 = 0)))))))) - -(define-ccl-program ccl-thai-xtis-vowel-d1 - '(0 - ((if (r1 == 0) - ((r5 = r0) (r6 = r3) (call ccl-thai-xtis-write)) - ((if (r2 == 0) - (r2 = #x38) - ((r5 = r1) (r6 = r2) (call ccl-thai-xtis-write) - (r5 = r0) (r6 = r3) (call ccl-thai-xtis-write) - (r1 = 0) - (r2 = 0)))))))) - -(define-ccl-program ccl-thai-xtis-vowel-ee - '(0 - ((if (r1 == 0) - ((r5 = r0) (r6 = r3) (call ccl-thai-xtis-write)) - ((if (r2 == 0) - (r2 = #x78) - ((r5 = r1) (r6 = r2) (call ccl-thai-xtis-write) - (r5 = r0) (r6 = r3) (call ccl-thai-xtis-write) - (r1 = 0) - (r2 = 0)))))))) - -(define-ccl-program ccl-thai-xtis-tone - '(0 - (if (r1 == 0) - ((r5 = r0) (r6 = r3) (call ccl-thai-xtis-write)) - (if (r2 == 0) - ((r5 = r1) (r6 = ((r0 - #xE6) | r3)) (call ccl-thai-xtis-write) - (r1 = 0)) - ((r5 = r1) (r6 = ((r0 - #xE6) | r2)) (call ccl-thai-xtis-write) - (r1 = 0) - (r2 = 0)))))) - -(define-ccl-program ccl-thai-xtis-symbol - '(0 - (if (r1 == 0) - ((r5 = r0) (r6 = r3) (call ccl-thai-xtis-write)) - (if (r2 == 0) - ((r5 = r1) (r6 = r3) (call ccl-thai-xtis-write) - (r5 = r0) (r6 = r3) (call ccl-thai-xtis-write) - (r1 = 0)) - ((r5 = r1) (r6 = r2) (call ccl-thai-xtis-write) - (r5 = r0) (r6 = r3) (call ccl-thai-xtis-write) - (r1 = 0) - (r2 = 0)))))) - -(define-ccl-program ccl-thai-xtis-ascii - '(0 - (if (r1 == 0) - (write r0) - (if (r2 == 0) - ((r5 = r1) (r6 = r3) (call ccl-thai-xtis-write) - (write r0) - (r1 = 0)) - ((r5 = r1) (r6 = r2) (call ccl-thai-xtis-write) - (write r0) - (r1 = 0) - (r2 = 0)))))) - -(define-ccl-program ccl-thai-xtis-eof - '(0 - (if (r1 != 0) - (if (r2 == 0) - ((r5 = r1) (r6 = r3) (call ccl-thai-xtis-write)) - ((r5 = r1) (r6 = r2) (call ccl-thai-xtis-write)))))) - -(define-ccl-program ccl-decode-thai-xtis - `(4 - ((read r0) - (r1 = 0) - (r2 = 0) - (r3 = #x30) - (r4 = ,(charset-id 'thai-xtis)) - (loop - (if (r0 < 161) - (call ccl-thai-xtis-ascii) - (branch (r0 - 161) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-consonant) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-vowel-d1) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-vowel) - (call ccl-thai-xtis-vowel) - (call ccl-thai-xtis-vowel) - (call ccl-thai-xtis-vowel) - (call ccl-thai-xtis-vowel) - (call ccl-thai-xtis-vowel) - (call ccl-thai-xtis-vowel) - nil - nil - nil - nil - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-tone) - (call ccl-thai-xtis-tone) - (call ccl-thai-xtis-tone) - (call ccl-thai-xtis-tone) - (call ccl-thai-xtis-tone) - (call ccl-thai-xtis-tone) - (call ccl-thai-xtis-tone) - (call ccl-thai-xtis-vowel-ee) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - (call ccl-thai-xtis-symbol) - nil - nil - nil)) - (read r0) - (repeat))) - - (call ccl-thai-xtis-eof))) - -) - -(defconst leading-code-private-21 #x9F) - -(define-ccl-program ccl-encode-thai-xtis - `(1 - ((read r0) - (loop - (if (r0 == ,leading-code-private-21) - ((read r1) - (if (r1 == ,(charset-id 'thai-xtis)) - ((read r0) - (write r0) - (read r0) - (r1 = (r0 & 7)) - (r0 = ((r0 - #xB0) >> 3)) - (if (r0 != 0) - (write r0 [0 209 212 213 214 215 216 217 218 238])) - (if (r1 != 0) - (write r1 [0 231 232 233 234 235 236 237])) - (read r0) - (repeat)) - ((write r0 r1) - (read r0) - (repeat)))) - (write-read-repeat r0)))))) - -(make-coding-system - 'tis-620 'ccl - "TIS620 (Thai)" - `(mnemonic "TIS620" - decode ccl-decode-thai-xtis - encode ccl-encode-thai-xtis - safe-charsets (ascii thai-xtis) - documentation "external=tis620, internal=thai-xtis")) -(coding-system-put 'tis-620 'category 'iso-8-1) - -(set-language-info-alist - "Thai-XTIS" - '((charset thai-xtis) - (coding-system tis-620 iso-2022-7bit) - (tutorial . "TUTORIAL.th") - (tutorial-coding-system . tis-620) - (coding-priority tis-620 iso-2022-7bit) - (sample-text . "$(?!:(B") - (documentation . t))) - -;; thai-xtis.el ends here.
--- a/lisp/mule/thai.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/mule/thai.el Sat Apr 23 23:47:13 2011 +0200 @@ -1,4 +1,4 @@ -;;; thai.el --- support for Thai -*- coding: iso-2022-7bit; -*- +;;; thai.el --- support for Thai -*- coding: utf-8; -*- ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. ;; Licensed to the Free Software Foundation. @@ -24,68 +24,246 @@ ;;; Commentary: -;; For Thai, the character set TIS620 is supported. - -;; #### I don't know how this differs from the existing thai-xtis.el so -;; I'm leaving it commented out. - -;;; Code: - -; (make-charset 'thai-tis620 -; "Right-Hand Part of TIS620.2533 (Thai): ISO-IR-166" -; '(dimension -; 1 -; registry "TIS620" -; chars 96 -; columns 1 -; direction l2r -; final ?T -; graphic 1 -; short-name "RHP of TIS620" -; long-name "RHP of Thai (TIS620): ISO-IR-166" -; )) - -; ; (make-coding-system -; ; 'thai-tis620 2 ?T -; ; "8-bit encoding for ASCII (MSB=0) and Thai TIS620 (MSB=1)" -; ; '(ascii thai-tis620 nil nil -; ; nil ascii-eol) -; ; '((safe-charsets ascii thai-tis620) -; ; (post-read-conversion . thai-post-read-conversion))) +(make-coding-system + 'tis-620 'fixed-width + "TIS620 (Thai)" + '(mnemonic "TIS620" + unicode-map + ((#x80 ?\u0080) ;; <control> + (#x81 ?\u0081) ;; <control> + (#x82 ?\u0082) ;; <control> + (#x83 ?\u0083) ;; <control> + (#x84 ?\u0084) ;; <control> + (#x85 ?\u0085) ;; <control> + (#x86 ?\u0086) ;; <control> + (#x87 ?\u0087) ;; <control> + (#x88 ?\u0088) ;; <control> + (#x89 ?\u0089) ;; <control> + (#x8A ?\u008A) ;; <control> + (#x8B ?\u008B) ;; <control> + (#x8C ?\u008C) ;; <control> + (#x8D ?\u008D) ;; <control> + (#x8E ?\u008E) ;; <control> + (#x8F ?\u008F) ;; <control> + (#x90 ?\u0090) ;; <control> + (#x91 ?\u0091) ;; <control> + (#x92 ?\u0092) ;; <control> + (#x93 ?\u0093) ;; <control> + (#x94 ?\u0094) ;; <control> + (#x95 ?\u0095) ;; <control> + (#x96 ?\u0096) ;; <control> + (#x97 ?\u0097) ;; <control> + (#x98 ?\u0098) ;; <control> + (#x99 ?\u0099) ;; <control> + (#x9A ?\u009A) ;; <control> + (#x9B ?\u009B) ;; <control> + (#x9C ?\u009C) ;; <control> + (#x9D ?\u009D) ;; <control> + (#x9E ?\u009E) ;; <control> + (#x9F ?\u009F) ;; <control> + (#xA0 ?\u00A0) ;; NO-BREAK SPACE + (#xA1 ?\u0E01) ;; THAI CHARACTER KO KAI + (#xA2 ?\u0E02) ;; THAI CHARACTER KHO KHAI + (#xA3 ?\u0E03) ;; THAI CHARACTER KHO KHUAT + (#xA4 ?\u0E04) ;; THAI CHARACTER KHO KHWAI + (#xA5 ?\u0E05) ;; THAI CHARACTER KHO KHON + (#xA6 ?\u0E06) ;; THAI CHARACTER KHO RAKHANG + (#xA7 ?\u0E07) ;; THAI CHARACTER NGO NGU + (#xA8 ?\u0E08) ;; THAI CHARACTER CHO CHAN + (#xA9 ?\u0E09) ;; THAI CHARACTER CHO CHING + (#xAA ?\u0E0A) ;; THAI CHARACTER CHO CHANG + (#xAB ?\u0E0B) ;; THAI CHARACTER SO SO + (#xAC ?\u0E0C) ;; THAI CHARACTER CHO CHOE + (#xAD ?\u0E0D) ;; THAI CHARACTER YO YING + (#xAE ?\u0E0E) ;; THAI CHARACTER DO CHADA + (#xAF ?\u0E0F) ;; THAI CHARACTER TO PATAK + (#xB0 ?\u0E10) ;; THAI CHARACTER THO THAN + (#xB1 ?\u0E11) ;; THAI CHARACTER THO NANGMONTHO + (#xB2 ?\u0E12) ;; THAI CHARACTER THO PHUTHAO + (#xB3 ?\u0E13) ;; THAI CHARACTER NO NEN + (#xB4 ?\u0E14) ;; THAI CHARACTER DO DEK + (#xB5 ?\u0E15) ;; THAI CHARACTER TO TAO + (#xB6 ?\u0E16) ;; THAI CHARACTER THO THUNG + (#xB7 ?\u0E17) ;; THAI CHARACTER THO THAHAN + (#xB8 ?\u0E18) ;; THAI CHARACTER THO THONG + (#xB9 ?\u0E19) ;; THAI CHARACTER NO NU + (#xBA ?\u0E1A) ;; THAI CHARACTER BO BAIMAI + (#xBB ?\u0E1B) ;; THAI CHARACTER PO PLA + (#xBC ?\u0E1C) ;; THAI CHARACTER PHO PHUNG + (#xBD ?\u0E1D) ;; THAI CHARACTER FO FA + (#xBE ?\u0E1E) ;; THAI CHARACTER PHO PHAN + (#xBF ?\u0E1F) ;; THAI CHARACTER FO FAN + (#xC0 ?\u0E20) ;; THAI CHARACTER PHO SAMPHAO + (#xC1 ?\u0E21) ;; THAI CHARACTER MO MA + (#xC2 ?\u0E22) ;; THAI CHARACTER YO YAK + (#xC3 ?\u0E23) ;; THAI CHARACTER RO RUA + (#xC4 ?\u0E24) ;; THAI CHARACTER RU + (#xC5 ?\u0E25) ;; THAI CHARACTER LO LING + (#xC6 ?\u0E26) ;; THAI CHARACTER LU + (#xC7 ?\u0E27) ;; THAI CHARACTER WO WAEN + (#xC8 ?\u0E28) ;; THAI CHARACTER SO SALA + (#xC9 ?\u0E29) ;; THAI CHARACTER SO RUSI + (#xCA ?\u0E2A) ;; THAI CHARACTER SO SUA + (#xCB ?\u0E2B) ;; THAI CHARACTER HO HIP + (#xCC ?\u0E2C) ;; THAI CHARACTER LO CHULA + (#xCD ?\u0E2D) ;; THAI CHARACTER O ANG + (#xCE ?\u0E2E) ;; THAI CHARACTER HO NOKHUK + (#xCF ?\u0E2F) ;; THAI CHARACTER PAIYANNOI + (#xD0 ?\u0E30) ;; THAI CHARACTER SARA A + (#xD1 ?\u0E31) ;; THAI CHARACTER MAI HAN-AKAT + (#xD2 ?\u0E32) ;; THAI CHARACTER SARA AA + (#xD3 ?\u0E33) ;; THAI CHARACTER SARA AM + (#xD4 ?\u0E34) ;; THAI CHARACTER SARA I + (#xD5 ?\u0E35) ;; THAI CHARACTER SARA II + (#xD6 ?\u0E36) ;; THAI CHARACTER SARA UE + (#xD7 ?\u0E37) ;; THAI CHARACTER SARA UEE + (#xD8 ?\u0E38) ;; THAI CHARACTER SARA U + (#xD9 ?\u0E39) ;; THAI CHARACTER SARA UU + (#xDA ?\u0E3A) ;; THAI CHARACTER PHINTHU + (#xDF ?\u0E3F) ;; THAI CURRENCY SYMBOL BAHT + (#xE0 ?\u0E40) ;; THAI CHARACTER SARA E + (#xE1 ?\u0E41) ;; THAI CHARACTER SARA AE + (#xE2 ?\u0E42) ;; THAI CHARACTER SARA O + (#xE3 ?\u0E43) ;; THAI CHARACTER SARA AI MAIMUAN + (#xE4 ?\u0E44) ;; THAI CHARACTER SARA AI MAIMALAI + (#xE5 ?\u0E45) ;; THAI CHARACTER LAKKHANGYAO + (#xE6 ?\u0E46) ;; THAI CHARACTER MAIYAMOK + (#xE7 ?\u0E47) ;; THAI CHARACTER MAITAIKHU + (#xE8 ?\u0E48) ;; THAI CHARACTER MAI EK + (#xE9 ?\u0E49) ;; THAI CHARACTER MAI THO + (#xEA ?\u0E4A) ;; THAI CHARACTER MAI TRI + (#xEB ?\u0E4B) ;; THAI CHARACTER MAI CHATTAWA + (#xEC ?\u0E4C) ;; THAI CHARACTER THANTHAKHAT + (#xED ?\u0E4D) ;; THAI CHARACTER NIKHAHIT + (#xEE ?\u0E4E) ;; THAI CHARACTER YAMAKKAN + (#xEF ?\u0E4F) ;; THAI CHARACTER FONGMAN + (#xF0 ?\u0E50) ;; THAI DIGIT ZERO + (#xF1 ?\u0E51) ;; THAI DIGIT ONE + (#xF2 ?\u0E52) ;; THAI DIGIT TWO + (#xF3 ?\u0E53) ;; THAI DIGIT THREE + (#xF4 ?\u0E54) ;; THAI DIGIT FOUR + (#xF5 ?\u0E55) ;; THAI DIGIT FIVE + (#xF6 ?\u0E56) ;; THAI DIGIT SIX + (#xF7 ?\u0E57) ;; THAI DIGIT SEVEN + (#xF8 ?\u0E58) ;; THAI DIGIT EIGHT + (#xF9 ?\u0E59) ;; THAI DIGIT NINE + (#xFA ?\u0E5A) ;; THAI CHARACTER ANGKHANKHU + (#xFB ?\u0E5B));; THAI CHARACTER KHOMUT + documentation "Non-composed Thai" + aliases (iso-8859-11))) -; (make-coding-system -; 'thai-tis620 'iso2022 "Thai/TIS620" -; '(charset-g0 ascii -; charset-g1 thai-tis620 -; mnemonic "Thai" -; safe-charsets (ascii thai-tis620) -; post-read-conversion thai-post-read-conversion -; documentation "8-bit encoding for ASCII (MSB=0) and Thai TIS620 (MSB=1)")) - -; (define-coding-system-alias 'th-tis620 'thai-tis620) -; (define-coding-system-alias 'tis620 'thai-tis620) -; (define-coding-system-alias 'tis-620 'thai-tis620) +(make-coding-system + 'windows-874 'fixed-width "Microsoft's CP874" + '(mnemonic "CP874" + unicode-map + ((#x80 ?\u20AC) ;; EURO SIGN + (#x85 ?\u2026) ;; HORIZONTAL ELLIPSIS + (#x91 ?\u2018) ;; LEFT SINGLE QUOTATION MARK + (#x92 ?\u2019) ;; RIGHT SINGLE QUOTATION MARK + (#x93 ?\u201C) ;; LEFT DOUBLE QUOTATION MARK + (#x94 ?\u201D) ;; RIGHT DOUBLE QUOTATION MARK + (#x95 ?\u2022) ;; BULLET + (#x96 ?\u2013) ;; EN DASH + (#x97 ?\u2014) ;; EM DASH + (#xA0 ?\u00A0) ;; NO-BREAK SPACE + (#xA1 ?\u0E01) ;; THAI CHARACTER KO KAI + (#xA2 ?\u0E02) ;; THAI CHARACTER KHO KHAI + (#xA3 ?\u0E03) ;; THAI CHARACTER KHO KHUAT + (#xA4 ?\u0E04) ;; THAI CHARACTER KHO KHWAI + (#xA5 ?\u0E05) ;; THAI CHARACTER KHO KHON + (#xA6 ?\u0E06) ;; THAI CHARACTER KHO RAKHANG + (#xA7 ?\u0E07) ;; THAI CHARACTER NGO NGU + (#xA8 ?\u0E08) ;; THAI CHARACTER CHO CHAN + (#xA9 ?\u0E09) ;; THAI CHARACTER CHO CHING + (#xAA ?\u0E0A) ;; THAI CHARACTER CHO CHANG + (#xAB ?\u0E0B) ;; THAI CHARACTER SO SO + (#xAC ?\u0E0C) ;; THAI CHARACTER CHO CHOE + (#xAD ?\u0E0D) ;; THAI CHARACTER YO YING + (#xAE ?\u0E0E) ;; THAI CHARACTER DO CHADA + (#xAF ?\u0E0F) ;; THAI CHARACTER TO PATAK + (#xB0 ?\u0E10) ;; THAI CHARACTER THO THAN + (#xB1 ?\u0E11) ;; THAI CHARACTER THO NANGMONTHO + (#xB2 ?\u0E12) ;; THAI CHARACTER THO PHUTHAO + (#xB3 ?\u0E13) ;; THAI CHARACTER NO NEN + (#xB4 ?\u0E14) ;; THAI CHARACTER DO DEK + (#xB5 ?\u0E15) ;; THAI CHARACTER TO TAO + (#xB6 ?\u0E16) ;; THAI CHARACTER THO THUNG + (#xB7 ?\u0E17) ;; THAI CHARACTER THO THAHAN + (#xB8 ?\u0E18) ;; THAI CHARACTER THO THONG + (#xB9 ?\u0E19) ;; THAI CHARACTER NO NU + (#xBA ?\u0E1A) ;; THAI CHARACTER BO BAIMAI + (#xBB ?\u0E1B) ;; THAI CHARACTER PO PLA + (#xBC ?\u0E1C) ;; THAI CHARACTER PHO PHUNG + (#xBD ?\u0E1D) ;; THAI CHARACTER FO FA + (#xBE ?\u0E1E) ;; THAI CHARACTER PHO PHAN + (#xBF ?\u0E1F) ;; THAI CHARACTER FO FAN + (#xC0 ?\u0E20) ;; THAI CHARACTER PHO SAMPHAO + (#xC1 ?\u0E21) ;; THAI CHARACTER MO MA + (#xC2 ?\u0E22) ;; THAI CHARACTER YO YAK + (#xC3 ?\u0E23) ;; THAI CHARACTER RO RUA + (#xC4 ?\u0E24) ;; THAI CHARACTER RU + (#xC5 ?\u0E25) ;; THAI CHARACTER LO LING + (#xC6 ?\u0E26) ;; THAI CHARACTER LU + (#xC7 ?\u0E27) ;; THAI CHARACTER WO WAEN + (#xC8 ?\u0E28) ;; THAI CHARACTER SO SALA + (#xC9 ?\u0E29) ;; THAI CHARACTER SO RUSI + (#xCA ?\u0E2A) ;; THAI CHARACTER SO SUA + (#xCB ?\u0E2B) ;; THAI CHARACTER HO HIP + (#xCC ?\u0E2C) ;; THAI CHARACTER LO CHULA + (#xCD ?\u0E2D) ;; THAI CHARACTER O ANG + (#xCE ?\u0E2E) ;; THAI CHARACTER HO NOKHUK + (#xCF ?\u0E2F) ;; THAI CHARACTER PAIYANNOI + (#xD0 ?\u0E30) ;; THAI CHARACTER SARA A + (#xD1 ?\u0E31) ;; THAI CHARACTER MAI HAN-AKAT + (#xD2 ?\u0E32) ;; THAI CHARACTER SARA AA + (#xD3 ?\u0E33) ;; THAI CHARACTER SARA AM + (#xD4 ?\u0E34) ;; THAI CHARACTER SARA I + (#xD5 ?\u0E35) ;; THAI CHARACTER SARA II + (#xD6 ?\u0E36) ;; THAI CHARACTER SARA UE + (#xD7 ?\u0E37) ;; THAI CHARACTER SARA UEE + (#xD8 ?\u0E38) ;; THAI CHARACTER SARA U + (#xD9 ?\u0E39) ;; THAI CHARACTER SARA UU + (#xDA ?\u0E3A) ;; THAI CHARACTER PHINTHU + (#xDF ?\u0E3F) ;; THAI CURRENCY SYMBOL BAHT + (#xE0 ?\u0E40) ;; THAI CHARACTER SARA E + (#xE1 ?\u0E41) ;; THAI CHARACTER SARA AE + (#xE2 ?\u0E42) ;; THAI CHARACTER SARA O + (#xE3 ?\u0E43) ;; THAI CHARACTER SARA AI MAIMUAN + (#xE4 ?\u0E44) ;; THAI CHARACTER SARA AI MAIMALAI + (#xE5 ?\u0E45) ;; THAI CHARACTER LAKKHANGYAO + (#xE6 ?\u0E46) ;; THAI CHARACTER MAIYAMOK + (#xE7 ?\u0E47) ;; THAI CHARACTER MAITAIKHU + (#xE8 ?\u0E48) ;; THAI CHARACTER MAI EK + (#xE9 ?\u0E49) ;; THAI CHARACTER MAI THO + (#xEA ?\u0E4A) ;; THAI CHARACTER MAI TRI + (#xEB ?\u0E4B) ;; THAI CHARACTER MAI CHATTAWA + (#xEC ?\u0E4C) ;; THAI CHARACTER THANTHAKHAT + (#xED ?\u0E4D) ;; THAI CHARACTER NIKHAHIT + (#xEE ?\u0E4E) ;; THAI CHARACTER YAMAKKAN + (#xEF ?\u0E4F) ;; THAI CHARACTER FONGMAN + (#xF0 ?\u0E50) ;; THAI DIGIT ZERO + (#xF1 ?\u0E51) ;; THAI DIGIT ONE + (#xF2 ?\u0E52) ;; THAI DIGIT TWO + (#xF3 ?\u0E53) ;; THAI DIGIT THREE + (#xF4 ?\u0E54) ;; THAI DIGIT FOUR + (#xF5 ?\u0E55) ;; THAI DIGIT FIVE + (#xF6 ?\u0E56) ;; THAI DIGIT SIX + (#xF7 ?\u0E57) ;; THAI DIGIT SEVEN + (#xF8 ?\u0E58) ;; THAI DIGIT EIGHT + (#xF9 ?\u0E59) ;; THAI DIGIT NINE + (#xFA ?\u0E5A) ;; THAI CHARACTER ANGKHANKHU + (#xFB ?\u0E5B));; THAI CHARACTER KHOMUT + documentation "Microsoft's encoding for Thai." + aliases (cp874))) -; (set-language-info-alist -; "Thai" '((tutorial . "TUTORIAL.th") -; (charset thai-tis620) -; (coding-system thai-tis620) -; (coding-priority thai-tis620) -; (nonascii-translation . thai-tis620) -; (input-method . "thai-kesmanee") -; (unibyte-display . thai-tis620) -; (features thai-util) -; (sample-text -; . (thai-compose-string -; (copy-sequence "Thai (,T@RIRd7B(B) ,TJ0GQ1J04U1$0CQ1:(B, ,TJ0GQ1J04U10$h1P(B"))) -; (documentation . t))) - - -;; Register a function to compose Thai characters. -; (put-char-table 'thai-tis620 -; '(("\\c0\\c4\\|\\c0\\(\\c2\\|\\c3\\)\\c4?" . -; thai-composition-function)) -; composition-function-table) +(set-language-info-alist + "Thai" + '((coding-system tis-620 utf-8) + (tutorial . "TUTORIAL.th") + (tutorial-coding-system . tis-620) + (coding-priority tis-620 utf-8 iso-2022-7bit) + (sample-text . "สวัสดีครับ, สวัสดีค่ะ") + (documentation . t))) (provide 'thai)
--- a/lisp/obsolete.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/obsolete.el Sat Apr 23 23:47:13 2011 +0200 @@ -242,6 +242,12 @@ (define-compatible-function-alias 'cl-mapc 'mapc) +;; Various non-XEmacs code can call this, because it used not be +;; called automatically at dump time. +(define-function 'cl-float-limits 'ignore) +(make-obsolete 'cl-float-limits "this is called at dump time in 21.5 and \ +later, no need to call it in user code.") + ;; XEmacs; old compiler macros meant that this was called directly ;; from compiled code, and we need to provide a version of it for a ;; couple of years at least because of that. Aidan Kehoe, Mon Oct 4
--- a/lisp/unicode.el Tue Mar 29 00:02:47 2011 +0200 +++ b/lisp/unicode.el Sat Apr 23 23:47:13 2011 +0200 @@ -159,7 +159,7 @@ indian-is13194 korean-ksc5601 chinese-cns11643-1 chinese-cns11643-2 chinese-isoir165 composite ethiopic indian-1-column indian-2-column jit-ucs-charset-0 - katakana-jisx0201 lao thai-tis620 thai-xtis tibetan tibetan-1-column + katakana-jisx0201 lao thai-tis620 tibetan tibetan-1-column latin-jisx0201 chinese-cns11643-3 chinese-cns11643-4 chinese-cns11643-5 chinese-cns11643-6 chinese-cns11643-7)))))
--- a/man/ChangeLog Tue Mar 29 00:02:47 2011 +0200 +++ b/man/ChangeLog Sat Apr 23 23:47:13 2011 +0200 @@ -1,3 +1,12 @@ +2011-04-02 Stephen J. Turnbull <stephen@xemacs.org> + + * xemacs-faq.texi (Q2.5.7): + New node on troubleshooting duplicate auto-autoloads. + (Top): + (Installation): + (Q2.5.6): + Update menus and node links for Q2.5.7. + 2011-03-24 Jerry James <james@xemacs.org> * internals/internals.texi (Creating a Window-System Type):
--- a/man/xemacs-faq.texi Tue Mar 29 00:02:47 2011 +0200 +++ b/man/xemacs-faq.texi Sat Apr 23 23:47:13 2011 +0200 @@ -327,6 +327,7 @@ * Q2.5.4:: Startup warnings about deducing proper fonts? * Q2.5.5:: Warnings from incorrect key modifiers. * Q2.5.6:: XEmacs 21.1 on Windows used to spawn an ugly console window on every startup. Has that been fixed? +* Q2.5.7:: XEmacs issues messages about ``auto-autoloads already loaded.'' 3 Editing Functions @@ -3149,6 +3150,7 @@ * Q2.5.4:: Startup warnings about deducing proper fonts? * Q2.5.5:: Warnings from incorrect key modifiers. * Q2.5.6:: XEmacs 21.1 on Windows used to spawn an ugly console window on every startup. Has that been fixed? +* Q2.5.7:: XEmacs issues messages about ``auto-autoloads already loaded.'' @end menu @unnumberedsec 2.0: Installation (General) @@ -4567,7 +4569,7 @@ EOF @end example -@node Q2.5.6, , Q2.5.5, Installation +@node Q2.5.6, Q2.5.7, Q2.5.5, Installation @unnumberedsubsec Q2.5.6: XEmacs 21.1 on Windows used to spawn an ugly console window on every startup. Has that been fixed? Yes. @@ -4617,6 +4619,54 @@ works around the "no useful stdio" problem by creating its own console window as necessary to display messages in.) +@node Q2.5.7, , Q2.5.6, Installation +@unnumberedsubsec Q2.5.7: XEmacs issues messages about ``auto-autoloads already loaded.'' + +On Sat, 05 Mar 2011 11:54:47 -0500, in Message-ID: +<4D726AD7.7020303@@gmail.com> on xemacs-beta, Raymond Toy reported: + +@quotation +[N]ow every time I start xemacs, I get 100+ error messages stating that +the auto-autoload for every package has already been loaded. +@end quotation + +This occurs if you have duplicate packages installed on your load-path. +To detect exactly which paths are duplicated, use @kbd{M-x +list-load-path-shadows}. If you have a small number of duplicated +libraries, it is probably one or more packages available both in the +XEmacs distribution and in third-party distributions. If you prefer the +third-party version, use @kbd{M-x list-packages} to get the package +management UI, and uninstall the particular packages. Removal of third +party packages must be done manually, if you wish to keep the version +distributed by XEmacs. + +When you have many duplicate packages, a common cause is that XEmacs +finds @emph{package root directories} that are duplicates of each other. +This can occur in some automounter configurations, or when the roots +share some subtrees via symlinks. In this case, you will get a warning +for @emph{all} of the packages you have installed. Although this is +basically a site configuration problem, please report these cases. +XEmacs is already aware of many automounter artifacts, and automatically +adjusts for them. Code is being added to try to detect symlinks. We +may not be able to handle every case, but we'd like to know about them, +and where possible incorporate workarounds. + +Package root directories are specified at configuration time via the +@code{--prefix}, @code{--exec-prefix}, and the @samp{--with-*-packages} +options; at runtime relative to the XEmacs binary (@file{../share} and +@file{..} (for run-in-place)); and at runtime via the +@samp{EMACS*PACKAGES} environment variables. Unless you have special +needs, it is best to install XEmacs and the packages (configuring with +@code{--with-prefix=$prefix} for XEmacs and by untarring the SUMOs in +@file{@code{$prefix}/share/xemacs/}. + +Note that older versions of XEmacs (21.1, 21.4, and early releases of +21.5) by default expect the packages to be installed under +@file{@code{$prefix}/lib} rather than @file{@code{$prefix}/share}. See +the documentation for @file{configure} for how to point XEmacs at +@file{@code{$prefix}/share/xemacs/} if that is preferred, or older +XEmacsen need to share packages with recent versions. + @node Editing, Display, Installation, Top @unnumbered 3 Editing Functions
--- a/src/ChangeLog Tue Mar 29 00:02:47 2011 +0200 +++ b/src/ChangeLog Sat Apr 23 23:47:13 2011 +0200 @@ -1,3 +1,63 @@ +2011-04-17 Jeff Sparkes <jsparkes@gmail.com> + + * device-tty.c (tty_device_system_metrics): Fix compile issues for + C89 compilers. Use log() instead of log2(). + +2011-04-04 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (count_with_tail): + This can be legitimately called from #'delete* with a specified + COUNT keyword value, accept this in the assertion. + * fns.c (FdeleteX): + * fns.c (FremoveX): + If COUNT is specified and FROM-END is non-nil, set COUNT to nil in + the argument vector, so count_with_tail doesn't see it when + calculating the total number of times an item occurs. Fixes + problems with the interaction of :count and :from-end. + +2011-04-04 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (FremoveX): + * fns.c (sublis): + Correct some nesting of GCPRO and UNGCPRO here, revealed by the + the C++ build compiling core Lisp. Thank you Mats' buildbot! + +2011-04-04 Aidan Kehoe <kehoea@parhasard.net> + + * lisp.h (GC_EXTERNAL_LIST_LOOP_3, GC_EXTERNAL_LIST_LOOP_4): New. + * fns.c (count_with_tail, list_position_cons_before, FassocX): + * fns.c (FrassocX, position, FdeleteX, FremoveX): + * fns.c (list_delete_duplicates_from_end): + * fns.c (Fdelete_duplicates, Fremove_duplicates, Freduce): + * fns.c (Fnsubstitute, Fsubstitute, sublis, nsublis, Fnsublis): + * fns.c (venn, nvenn, Funion, Fset_exclusive_or, Fnset_exclusive_or): + Use GC_EXTERNAL_LIST_LOOP_* in the sequence functions in fns.c + where appropriate, there were some corner cases where my old + approach was unsafe (mainly if the circularity checking's tortoise + lost GCPRO protection. + Add GC_EXTERNAL_LIST_LOOP_{3,4}, analogous to + GC_EXTERNAL_LIST_LOOP_2. + +2011-03-28 Jeff Sparkes <jsparkes@gmail.com> + + * console-tty-impl.h (struct tty_console): Add field for number of + displayable colors. + * device-tty.c (tty_device_system_metrics): Return metrics for + num-color-cells and num-bit-planes. Tracker issue 757. + * device.c: There are two required args for device-system-metric. + * redisplay-tty.c (init_tty_for_redisplay): Retrieve number of + colors from terminal description. Default to 2 if none found. + +2011-03-24 Jerry James <james@xemacs.org> + + * alloc.c (listu): Assemble the list in the right order so we don't + have to reverse it. + (listn): Ditto. + * dired.c (Ffile_attributes): Use listn instead of building an array + to pass to Flist. GC protect the mode string. + * editfns.c (Fdecode_time): Use listn instead of Flist. + * faces.c (vars_of_faces): Use listu instead of Flist. + 2011-03-24 Jerry James <james@xemacs.org> * README.kkcc: "occured" -> "occurred".
--- a/src/alloc.c Tue Mar 29 00:02:47 2011 +0200 +++ b/src/alloc.c Sat Apr 23 23:47:13 2011 +0200 @@ -1463,18 +1463,23 @@ listu (Lisp_Object first, ...) { Lisp_Object obj = Qnil; - Lisp_Object val; - va_list va; - - va_start (va, first); - val = first; - while (!UNBOUNDP (val)) + + if (!UNBOUNDP (first)) { - obj = Fcons (val, obj); + va_list va; + Lisp_Object last, val; + + last = obj = Fcons (first, Qnil); + va_start (va, first); val = va_arg (va, Lisp_Object); + while (!UNBOUNDP (val)) + { + last = XCDR (last) = Fcons (val, Qnil); + val = va_arg (va, Lisp_Object); + } + va_end (va); } - va_end (va); - return Fnreverse (obj); + return obj; } /* Return a list of arbitrary length, with length specified and remaining @@ -1483,15 +1488,21 @@ Lisp_Object listn (int num_args, ...) { - int i; Lisp_Object obj = Qnil; - va_list va; - - va_start (va, num_args); - for (i = 0; i < num_args; i++) - obj = Fcons (va_arg (va, Lisp_Object), obj); - va_end (va); - return Fnreverse (obj); + + if (num_args > 0) + { + va_list va; + Lisp_Object last; + int i; + + va_start (va, num_args); + last = obj = Fcons (va_arg (va, Lisp_Object), Qnil); + for (i = 1; i < num_args; i++) + last = XCDR (last) = Fcons (va_arg (va, Lisp_Object), Qnil); + va_end (va); + } + return obj; } /* Return a list of arbitrary length, with length specified and an array
--- a/src/console-tty-impl.h Tue Mar 29 00:02:47 2011 +0200 +++ b/src/console-tty-impl.h Sat Apr 23 23:47:13 2011 +0200 @@ -61,6 +61,8 @@ int height; int width; + int colors; + /* The count of frame number. */ int frame_count;
--- a/src/device-tty.c Tue Mar 29 00:02:47 2011 +0200 +++ b/src/device-tty.c Sat Apr 23 23:47:13 2011 +0200 @@ -194,6 +194,14 @@ case DM_size_device: return Fcons (make_int (CONSOLE_TTY_DATA (con)->width), make_int (CONSOLE_TTY_DATA (con)->height)); + case DM_num_bit_planes: + { + EMACS_INT l2 = (EMACS_INT) (log (CONSOLE_TTY_DATA (con)->colors) + / log (2)); + return make_int (l2); + } + case DM_num_color_cells: + return make_int (CONSOLE_TTY_DATA (con)->colors); default: /* No such device metric property for TTY devices */ return Qunbound; }
--- a/src/device.c Tue Mar 29 00:02:47 2011 +0200 +++ b/src/device.c Sat Apr 23 23:47:13 2011 +0200 @@ -1055,8 +1055,8 @@ return DEVICE_PRINTER_P (decode_device (device)) ? Qt : Qnil; } -DEFUN ("device-system-metric", Fdevice_system_metric, 1, 3, 0, /* -Get a metric for DEVICE as provided by the system. +DEFUN ("device-system-metric", Fdevice_system_metric, 2, 3, 0, /* +Get DEVICE METRIC as provided by the system. METRIC must be a symbol specifying requested metric. Note that the metrics returned are these provided by the system internally, not read from resources,
--- a/src/dired.c Tue Mar 29 00:02:47 2011 +0200 +++ b/src/dired.c Sat Apr 23 23:47:13 2011 +0200 @@ -843,14 +843,13 @@ (filename)) { /* This function can GC. GC checked 1997.06.04. */ - Lisp_Object values[12]; Lisp_Object directory = Qnil; struct stat s; char modes[10]; - Lisp_Object handler; - struct gcpro gcpro1, gcpro2; + Lisp_Object handler, mode, modestring = Qnil, size, gid; + struct gcpro gcpro1, gcpro2, gcpro3; - GCPRO2 (filename, directory); + GCPRO3 (filename, directory, modestring); filename = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, @@ -891,49 +890,54 @@ switch (s.st_mode & S_IFMT) { default: - values[0] = Qnil; + mode = Qnil; break; case S_IFDIR: - values[0] = Qt; + mode = Qt; break; #ifdef S_IFLNK case S_IFLNK: - values[0] = Ffile_symlink_p (filename); + mode = Ffile_symlink_p (filename); break; #endif } - values[1] = make_int (s.st_nlink); - values[2] = make_int (s.st_uid); - values[3] = make_int (s.st_gid); - values[4] = make_time (s.st_atime); - values[5] = make_time (s.st_mtime); - values[6] = make_time (s.st_ctime); #ifndef HAVE_BIGNUM - values[7] = make_integer (NUMBER_FITS_IN_AN_EMACS_INT (s.st_size) ? - (EMACS_INT)s.st_size : -1); + size = make_integer (NUMBER_FITS_IN_AN_EMACS_INT (s.st_size) ? + (EMACS_INT)s.st_size : -1); #else - values[7] = make_integer (s.st_size); -#endif + size = make_integer (s.st_size); +#endif filemodestring (&s, modes); - values[8] = make_string ((Ibyte *) modes, 10); + modestring = make_string ((Ibyte *) modes, 10); + #if defined (BSD4_2) || defined (BSD4_3) /* file gid will be dir gid */ { struct stat sdir; if (!NILP (directory) && qxe_stat (XSTRING_DATA (directory), &sdir) == 0) - values[9] = (sdir.st_gid != s.st_gid) ? Qt : Qnil; + gid = (sdir.st_gid != s.st_gid) ? Qt : Qnil; else /* if we can't tell, assume worst */ - values[9] = Qt; + gid = Qt; } #else /* file gid will be egid */ - values[9] = (s.st_gid != getegid ()) ? Qt : Qnil; + gid = (s.st_gid != getegid ()) ? Qt : Qnil; #endif /* BSD4_2 or BSD4_3 */ - values[10] = make_int (s.st_ino); - values[11] = make_int (s.st_dev); - UNGCPRO; - return Flist (countof (values), values); + + RETURN_UNGCPRO (listn (12, + mode, + make_int (s.st_nlink), + make_int (s.st_uid), + make_int (s.st_gid), + make_time (s.st_atime), + make_time (s.st_mtime), + make_time (s.st_ctime), + size, + modestring, + gid, + make_int (s.st_ino), + make_int (s.st_dev))); }
--- a/src/editfns.c Tue Mar 29 00:02:47 2011 +0200 +++ b/src/editfns.c Sat Apr 23 23:47:13 2011 +0200 @@ -1100,29 +1100,28 @@ time_t time_spec; struct tm save_tm; struct tm *decoded_time; - Lisp_Object list_args[9]; if (! lisp_to_time (specified_time, &time_spec)) invalid_argument ("Invalid time specification", Qunbound); decoded_time = localtime (&time_spec); - list_args[0] = make_int (decoded_time->tm_sec); - list_args[1] = make_int (decoded_time->tm_min); - list_args[2] = make_int (decoded_time->tm_hour); - list_args[3] = make_int (decoded_time->tm_mday); - list_args[4] = make_int (decoded_time->tm_mon + 1); - list_args[5] = make_int (decoded_time->tm_year + 1900); - list_args[6] = make_int (decoded_time->tm_wday); - list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil; /* Make a copy, in case gmtime modifies the struct. */ save_tm = *decoded_time; decoded_time = gmtime (&time_spec); - if (decoded_time == 0) - list_args[8] = Qnil; - else - list_args[8] = make_int (difftm (&save_tm, decoded_time)); - return Flist (9, list_args); + + return listn(9, + make_int (save_tm.tm_sec), + make_int (save_tm.tm_min), + make_int (save_tm.tm_hour), + make_int (save_tm.tm_mday), + make_int (save_tm.tm_mon + 1), + make_int (save_tm.tm_year + 1900), + make_int (save_tm.tm_wday), + save_tm.tm_isdst ? Qt : Qnil, + (decoded_time == NULL) + ? Qnil + : make_int (difftm (&save_tm, decoded_time))); } static void set_time_zone_rule (Extbyte *tzstring);
--- a/src/faces.c Tue Mar 29 00:02:47 2011 +0200 +++ b/src/faces.c Sat Apr 23 23:47:13 2011 +0200 @@ -2225,26 +2225,11 @@ debug_x_faces = 0; #endif - { - Lisp_Object syms[20]; - int n = 0; - - syms[n++] = Qforeground; - syms[n++] = Qbackground; - syms[n++] = Qfont; - syms[n++] = Qdisplay_table; - syms[n++] = Qbackground_pixmap; - syms[n++] = Qbackground_placement; - syms[n++] = Qunderline; - syms[n++] = Qstrikethru; - syms[n++] = Qhighlight; - syms[n++] = Qdim; - syms[n++] = Qblinking; - syms[n++] = Qreverse; - - Vbuilt_in_face_specifiers = Flist (n, syms); - staticpro (&Vbuilt_in_face_specifiers); - } + Vbuilt_in_face_specifiers = + listu (Qforeground, Qbackground, Qfont, Qdisplay_table, Qbackground_pixmap, + Qbackground_placement, Qunderline, Qstrikethru, Qhighlight, Qdim, + Qblinking, Qreverse, Qunbound); + staticpro (&Vbuilt_in_face_specifiers); } void
--- a/src/fns.c Tue Mar 29 00:02:47 2011 +0200 +++ b/src/fns.c Sat Apr 23 23:47:13 2011 +0200 @@ -997,7 +997,7 @@ assert (counting >= 0); /* And we're not prepared to handle COUNT from any other caller at the moment. */ - assert (EQ (caller, QremoveX)); + assert (EQ (caller, QremoveX)|| EQ (caller, QdeleteX)); } check_test = get_check_test_function (item, &test, test_not, if_, if_not, @@ -1007,9 +1007,6 @@ if (CONSP (sequence)) { - Lisp_Object elt, tail = Qnil; - struct gcpro gcpro1; - if (EQ (caller, Qcount) && !NILP (from_end) && (!EQ (key, Qnil) || check_test == check_other_nokey || check_test == check_if_nokey)) @@ -1024,8 +1021,6 @@ start, end); } - GCPRO1 (tail); - /* If COUNT is non-nil and FROM-END is t, we can give the tail containing the last match, since that's what #'remove* is interested in (a zero or negative COUNT won't ever reach @@ -1037,7 +1032,7 @@ } { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { if (!(ii < ending)) { @@ -1058,10 +1053,9 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } - UNGCPRO; - if ((ii < starting || (ii < ending && !NILP (end))) && encountered != counting) { @@ -2620,18 +2614,18 @@ Boolint reverse_test_order, Lisp_Object start, Lisp_Object end) { - struct gcpro gcpro1, gcpro2; - Lisp_Object elt = Qnil, tail = list, tail_before = Qnil; - Elemcount len, ii = 0, starting = XINT (start); + struct gcpro gcpro1; + Lisp_Object tail_before = Qnil; + Elemcount ii = 0, starting = XINT (start); Elemcount ending = NILP (end) ? EMACS_INT_MAX : XINT (end); - GCPRO2 (elt, tail); + GCPRO1 (tail_before); if (check_test == check_eq_nokey) { /* TEST is #'eq, no need to call any C functions, and the test order won't be visible. */ - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len) + EXTERNAL_LIST_LOOP_3 (elt, list, tail) { if (starting <= ii && ii < ending && EQ (item, elt) == test_not_unboundp) @@ -2652,15 +2646,17 @@ } else { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, list, tail) { if (starting <= ii && ii < ending && (reverse_test_order ? check_test (test, key, elt, item) : - check_test (test, key, item, elt)) == test_not_unboundp) + check_test (test, key, item, elt)) == test_not_unboundp) { *cons_out = tail_before; - RETURN_UNGCPRO (make_integer (ii)); + XUNGCPRO (elt); + UNGCPRO; + return make_integer (ii); } else { @@ -2672,6 +2668,7 @@ ii++; tail_before = tail; } + END_GC_EXTERNAL_LIST_LOOP (elt); } RETURN_UNGCPRO (Qnil); @@ -2858,22 +2855,16 @@ } else { - Lisp_Object tailed = alist; - struct gcpro gcpro1; - - GCPRO1 (tailed); - { - EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail) - { - tailed = tail; - - if (check_test (test, key, item, elt_car) == test_not_unboundp) + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) + { + if (CONSP (elt) && + check_test (test, key, item, XCAR (elt)) == test_not_unboundp) { - RETURN_UNGCPRO (elt); + XUNGCPRO (elt); + return elt; } - } - } - UNGCPRO; + } + END_GC_EXTERNAL_LIST_LOOP (elt); } return Qnil; @@ -2967,22 +2958,16 @@ } else { - struct gcpro gcpro1; - Lisp_Object tailed = alist; - - GCPRO1 (tailed); - { - EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail) - { - tailed = tail; - - if (check_test (test, key, item, elt_cdr) == test_not_unboundp) - { - RETURN_UNGCPRO (elt); - } - } - } - UNGCPRO; + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) + { + if (CONSP (elt) && + check_test (test, key, item, XCDR (elt)) == test_not_unboundp) + { + XUNGCPRO (elt); + return elt; + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); } return Qnil; @@ -3012,9 +2997,6 @@ if (CONSP (sequence)) { - Lisp_Object elt, tail = Qnil; - struct gcpro gcpro1; - if (!(starting < ending)) { check_sequence_range (sequence, start, end, Flength (sequence)); @@ -3023,10 +3005,8 @@ return Qnil; } - GCPRO1 (tail); - { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + GC_EXTERNAL_LIST_LOOP_2 (elt, sequence) { if (starting <= ii && ii < ending && check_test (test, key, item, elt) == test_not_unboundp) @@ -3036,7 +3016,7 @@ if (NILP (from_end)) { - UNGCPRO; + XUNGCPRO (elt); return result; } } @@ -3047,10 +3027,9 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } - UNGCPRO; - if (ii < starting || (ii < ending && !NILP (end))) { check_sequence_range (sequence, start, end, Flength (sequence)); @@ -3257,12 +3236,11 @@ */ (int nargs, Lisp_Object *args)) { - Lisp_Object item = args[0], sequence = args[1], tail = sequence; + Lisp_Object item = args[0], sequence = args[1]; Elemcount starting = 0, ending = EMACS_INT_MAX, counting = EMACS_INT_MAX; Elemcount len, ii = 0, encountered = 0, presenting = 0; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; - struct gcpro gcpro1; PARSE_KEYWORDS (FdeleteX, nargs, args, 9, (test, if_not, if_, test_not, key, start, end, from_end, @@ -3299,7 +3277,25 @@ { return sequence; } - } + + if (!NILP (from_end)) + { + /* Sigh, this is inelegant. Force count_with_tail () to ignore + the count keyword, so we get the actual number of matching + elements, and can start removing from the beginning for the + from-end case. */ + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args; + ii < nargs; ii += 2) + { + if (EQ (args[ii], Q_count)) + { + args[ii + 1] = Qnil; + break; + } + } + ii = 0; + } + } } check_test = get_check_test_function (item, &test, test_not, if_, if_not, @@ -3307,14 +3303,15 @@ if (CONSP (sequence)) { - Lisp_Object prev_tail_list_elt = Qnil, list_elt = Qnil; + Lisp_Object prev_tail_list_elt = Qnil, ignore = Qnil; Elemcount list_len = 0, deleted = 0; + struct gcpro gcpro1; if (!NILP (count) && !NILP (from_end)) { /* Both COUNT and FROM-END were specified; we need to traverse the list twice. */ - Lisp_Object present = count_with_tail (&list_elt, nargs, args, + Lisp_Object present = count_with_tail (&ignore, nargs, args, QdeleteX); if (ZEROP (present)) @@ -3332,11 +3329,11 @@ presenting = presenting <= counting ? 0 : presenting - counting; } - GCPRO1 (tail); + GCPRO1 (prev_tail_list_elt); ii = -1; { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (list_elt, sequence, tail, list_len) + GC_EXTERNAL_LIST_LOOP_4 (list_elt, sequence, tail, list_len) { ii++; @@ -3367,6 +3364,7 @@ } } } + END_GC_EXTERNAL_LIST_LOOP (list_elt); } UNGCPRO; @@ -3604,10 +3602,9 @@ Lisp_Object item = args[0], sequence = args[1], matched_count = Qnil, tail = Qnil; Elemcount starting = 0, ending = EMACS_INT_MAX, counting = EMACS_INT_MAX; - Elemcount len, ii = 0, encountered = 0, presenting = 0; + Elemcount ii = 0, encountered = 0, presenting = 0; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; - struct gcpro gcpro1; PARSE_KEYWORDS (FremoveX, nargs, args, 9, (test, if_not, if_, test_not, key, start, end, from_end, @@ -3646,6 +3643,24 @@ { return sequence; } + + if (!NILP (from_end)) + { + /* Sigh, this is inelegant. Force count_with_tail () to ignore the + count keyword, so we get the actual number of matching + elements, and can start removing from the beginning for the + from-end case. */ + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FremoveX))->min_args; + ii < nargs; ii += 2) + { + if (EQ (args[ii], Q_count)) + { + args[ii + 1] = Qnil; + break; + } + } + ii = 0; + } } check_test = get_check_test_function (item, &test, test_not, if_, if_not, @@ -3655,8 +3670,8 @@ if (!ZEROP (matched_count)) { - Lisp_Object elt, tailing = Qnil, result = Qnil, result_tail = Qnil; - GCPRO1 (tailing); + Lisp_Object result = Qnil, result_tail = Qnil; + struct gcpro gcpro1, gcpro2; if (!NILP (count) && !NILP (from_end)) { @@ -3670,18 +3685,22 @@ presenting = presenting <= counting ? 0 : presenting - counting; } + GCPRO2 (result, tail); { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tailing, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tailing) { if (EQ (tail, tailing)) { + XUNGCPRO (elt); + UNGCPRO; + if (NILP (result)) { - RETURN_UNGCPRO (XCDR (tail)); + return XCDR (tail); } XSETCDR (result_tail, XCDR (tail)); - RETURN_UNGCPRO (result); + return result; } else if (starting <= ii && ii < ending && (check_test (test, key, item, elt) == test_not_unboundp) @@ -3707,8 +3726,8 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } - UNGCPRO; if (ii < starting || (ii < ending && !NILP (end))) @@ -3827,12 +3846,12 @@ Lisp_Object start, Lisp_Object end, Boolint copy) { - Lisp_Object checking = Qnil, elt, tail, result = list; + Lisp_Object checking = Qnil, result = list; Lisp_Object keyed, positioned, position_cons = Qnil, result_tail; Elemcount len = XINT (Flength (list)), pos, starting = XINT (start); Elemcount ending = (NILP (end) ? len : XINT (end)), greatest_pos_seen = -1; Elemcount ii = 0; - struct gcpro gcpro1, gcpro2; + struct gcpro gcpro1; /* We can't delete (or remove) as we go, because that breaks START and END. We could if END were nil, and that would change an ON(N + 2) @@ -3852,10 +3871,10 @@ memset (&(deleting->bits), 0, sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); - GCPRO2 (tail, keyed); + GCPRO1 (keyed); { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, list, tail) { if (!(starting <= ii && ii <= ending) || bit_vector_bit (deleting, ii)) { @@ -3882,6 +3901,7 @@ } ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } UNGCPRO; @@ -3897,7 +3917,7 @@ ii = 1; { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len) + EXTERNAL_LIST_LOOP_3 (elt, list, tail) { if (ii == greatest_pos_seen) { @@ -3915,7 +3935,7 @@ } else { - EXTERNAL_LIST_LOOP_DELETE_IF (elt0, list, + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, bit_vector_bit (deleting, ii++)); } } @@ -3943,8 +3963,8 @@ */ (int nargs, Lisp_Object *args)) { - Lisp_Object sequence = args[0], tail = sequence, keyed = Qnil, elt = Qnil; - Lisp_Object elt0 = Qnil, positioned = Qnil, ignore = Qnil; + Lisp_Object sequence = args[0], keyed = Qnil; + Lisp_Object positioned = Qnil, ignore = Qnil; Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0, jj = 0; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; @@ -3976,10 +3996,10 @@ Lisp_Object prev_tail = Qnil; Elemcount deleted = 0; - GCPRO2 (tail, keyed); + GCPRO2 (keyed, prev_tail); { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { if (starting <= ii && ii < ending) { @@ -4010,9 +4030,10 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt0, sequence, tail, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { if (!(starting <= ii && ii <= ending)) { @@ -4021,7 +4042,7 @@ continue; } - keyed = KEY (key, elt0); + keyed = KEY (key, elt); positioned = list_position_cons_before (&ignore, keyed, XCDR (tail), check_test, test_not_unboundp, @@ -4050,7 +4071,9 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } + UNGCPRO; if ((ii < starting || (ii < ending && !NILP (end)))) @@ -4070,6 +4093,8 @@ } else if (STRINGP (sequence)) { + Lisp_Object elt = Qnil; + if (EQ (Qidentity, key)) { /* We know all the elements will be characters; set check_test to @@ -4088,7 +4113,6 @@ Ibyte *cursor = XSTRING_DATA (sequence), *startp = cursor; Elemcount deleted = 0; - elt = Qnil; GCPRO1 (elt); while (cursor_offset < byte_len) @@ -4243,6 +4267,7 @@ Elemcount deleted = 0; Lisp_Object *content = XVECTOR_DATA (sequence); struct Lisp_Bit_Vector *deleting; + Lisp_Object elt = Qnil; len = XVECTOR_LENGTH (sequence); check_sequence_range (sequence, start, end, make_integer (len)); @@ -4326,6 +4351,7 @@ and KEY arguments, which may be non-deterministic from our perspective, we need the same algorithm as for vectors. */ struct Lisp_Bit_Vector *deleting; + Lisp_Object elt = Qnil; len = bit_vector_length (bv); @@ -4427,13 +4453,13 @@ */ (int nargs, Lisp_Object *args)) { - Lisp_Object sequence = args[0], tail = sequence, keyed, positioned = Qnil; + Lisp_Object sequence = args[0], keyed, positioned = Qnil; Lisp_Object result = sequence, result_tail = result, cursor = Qnil; - Lisp_Object cons_with_shared_tail = Qnil, elt, elt0; - Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0; + Lisp_Object cons_with_shared_tail = Qnil; + Elemcount starting = 0, ending = EMACS_INT_MAX, ii = 0; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; - struct gcpro gcpro1, gcpro2, gcpro3; + struct gcpro gcpro1, gcpro2; PARSE_KEYWORDS (Fremove_duplicates, nargs, args, 6, (test, key, test_not, start, end, from_end), @@ -4467,10 +4493,10 @@ { Lisp_Object ignore = Qnil; - GCPRO3 (tail, keyed, result); + GCPRO2 (keyed, result); { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { if (starting <= ii && ii <= ending) { @@ -4498,10 +4524,11 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt0, sequence, tail, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { if (!(starting <= ii && ii <= ending)) { @@ -4514,7 +4541,7 @@ removed cons to this one. Otherwise, the tail of the output list is shared with the input list, which is OK. */ - keyed = KEY (key, elt0); + keyed = KEY (key, elt); positioned = list_position_cons_before (&ignore, keyed, XCDR (tail), check_test, test_not_unboundp, @@ -4546,7 +4573,9 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } + UNGCPRO; if ((ii < starting || (ii < ending && !NILP (end)))) @@ -7930,10 +7959,9 @@ { if (NILP (from_end)) { - struct gcpro gcpro1, gcpro2; - Lisp_Object tailed = Qnil; - - GCPRO2 (tailed, accum); + struct gcpro gcpro1; + + GCPRO1 (accum); if (!UNBOUNDP (initial_value)) { @@ -7941,11 +7969,8 @@ } else if (ending - starting) { - EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + GC_EXTERNAL_LIST_LOOP_2 (elt, sequence) { - /* KEY may amputate the list behind us; make sure what - remains to be processed is still reachable. */ - tailed = tail; if (ii == starting) { accum = KEY (key, elt); @@ -7954,18 +7979,15 @@ } ++ii; } + END_GC_EXTERNAL_LIST_LOOP (elt); } ii = 0; if (ending - starting) { - EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + GC_EXTERNAL_LIST_LOOP_2 (elt, sequence) { - /* KEY or FUNCTION may amputate the list behind us; make - sure what remains to be processed is still - reachable. */ - tailed = tail; if (ii >= starting) { if (ii < ending) @@ -7979,6 +8001,7 @@ } ++ii; } + END_GC_EXTERNAL_LIST_LOOP (elt); } UNGCPRO; @@ -8701,13 +8724,12 @@ */ (int nargs, Lisp_Object *args)) { - Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil; + Lisp_Object new_ = args[0], item = args[1], sequence = args[2]; Lisp_Object object_, position0; Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0; Elemcount len, ii = 0, counting = EMACS_INT_MAX, presenting = 0; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; - struct gcpro gcpro1; PARSE_KEYWORDS (Fnsubstitute, nargs, args, 9, (test, if_, if_not, test_not, key, start, end, count, @@ -8749,11 +8771,9 @@ if (CONSP (sequence)) { - Lisp_Object elt; - if (!NILP (count) && !NILP (from_end)) { - Lisp_Object present = count_with_tail (&elt, nargs - 1, args + 1, + Lisp_Object present = count_with_tail (&object_, nargs - 1, args + 1, Qnsubstitute); if (ZEROP (present)) @@ -8765,9 +8785,8 @@ presenting = presenting <= counting ? 0 : presenting - counting; } - GCPRO1 (tail); { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { if (!(ii < ending)) { @@ -8789,8 +8808,8 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } - UNGCPRO; if ((ii < starting || (ii < ending && !NILP (end))) && encountered < counting) @@ -8962,10 +8981,10 @@ (int nargs, Lisp_Object *args)) { Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil; - Lisp_Object elt, tailing = Qnil, result = Qnil, result_tail = Qnil; + Lisp_Object result = Qnil, result_tail = Qnil; Lisp_Object object, position0, matched_count; Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0; - Elemcount len, ii = 0, counting = EMACS_INT_MAX, presenting = 0; + Elemcount ii = 0, counting = EMACS_INT_MAX, presenting = 0; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; struct gcpro gcpro1; @@ -9042,19 +9061,22 @@ presenting = presenting <= counting ? 0 : presenting - counting; } - GCPRO1 (tailing); + GCPRO1 (result); { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tailing, len) + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tailing) { if (EQ (tail, tailing)) { + XUNGCPRO (elt); + UNGCPRO; + if (NILP (result)) { - RETURN_UNGCPRO (XCDR (tail)); + return XCDR (tail); } XSETCDR (result_tail, XCDR (tail)); - RETURN_UNGCPRO (result); + return result; } else if (starting <= ii && ii < ending && (check_test (test, key, item, elt) == test_not_unboundp) @@ -9088,6 +9110,7 @@ ii++; } + END_GC_EXTERNAL_LIST_LOOP (elt); } UNGCPRO; @@ -9136,31 +9159,30 @@ check_test_func_t check_test, Boolint test_not_unboundp, Lisp_Object test, Lisp_Object key, int depth) { - Lisp_Object keyed = KEY (key, tree), tailed = alist, aa, dd; - struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object keyed = KEY (key, tree), aa, dd; + struct gcpro gcpro1; if (depth + lisp_eval_depth > max_lisp_eval_depth) { stack_overflow ("Stack overflow in sublis", tree); } - GCPRO3 (tailed, alist, tree); { - EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail) + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) { - tailed = tail; - - if (check_test (test, key, elt_car, keyed) == test_not_unboundp) + if (CONSP (elt) && + check_test (test, key, XCAR (elt), keyed) == test_not_unboundp) { - /* Don't use elt_cdr, it is helpful to allow TEST or KEY to - modify the alist while it executes. */ - RETURN_UNGCPRO (XCDR (elt)); + XUNGCPRO (elt); + return XCDR (elt); } } + END_GC_EXTERNAL_LIST_LOOP (elt); } + if (!CONSP (tree)) { - RETURN_UNGCPRO (tree); + return tree; } aa = sublis (alist, XCAR (tree), check_test, test_not_unboundp, test, key, @@ -9170,10 +9192,10 @@ if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree))) { - RETURN_UNGCPRO (tree); - } - - RETURN_UNGCPRO (Fcons (aa, dd)); + return tree; + } + + return Fcons (aa, dd); } DEFUN ("sublis", Fsublis, 2, MANY, 0, /* @@ -9223,8 +9245,8 @@ Boolint test_not_unboundp, Lisp_Object test, Lisp_Object key, int depth) { - Lisp_Object tree_saved = tree, tailed = alist, tortoise = tree, keyed = Qnil; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + Lisp_Object tree_saved = tree, tortoise = tree, keyed = Qnil; + struct gcpro gcpro1, gcpro2; int count = 0; if (depth + lisp_eval_depth > max_lisp_eval_depth) @@ -9232,7 +9254,7 @@ stack_overflow ("Stack overflow in nsublis", tree); } - GCPRO4 (tailed, alist, tree_saved, keyed); + GCPRO2 (tree_saved, keyed); while (CONSP (tree)) { @@ -9240,11 +9262,10 @@ keyed = KEY (key, XCAR (tree)); { - EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail) + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) { - tailed = tail; - - if (check_test (test, key, elt_car, keyed) == test_not_unboundp) + if (CONSP (elt) && + check_test (test, key, XCAR (elt), keyed) == test_not_unboundp) { CHECK_LISP_WRITEABLE (tree); /* See comment in sublis() on using elt_cdr. */ @@ -9253,6 +9274,7 @@ break; } } + END_GC_EXTERNAL_LIST_LOOP (elt); } if (!replaced) @@ -9268,19 +9290,18 @@ replaced = 0; { - EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail) + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) { - tailed = tail; - - if (check_test (test, key, elt_car, keyed) == test_not_unboundp) + if (CONSP (elt) && + check_test (test, key, XCAR (elt), keyed) == test_not_unboundp) { CHECK_LISP_WRITEABLE (tree); - /* See comment in sublis() on using elt_cdr. */ XSETCDR (tree, XCDR (elt)); tree = Qnil; break; } } + END_GC_EXTERNAL_LIST_LOOP (elt); } if (!NILP (tree)) @@ -9341,16 +9362,16 @@ { /* nsublis() won't attempt to replace a cons handed to it, do that ourselves. */ - EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail) + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) { - tailed = tail; - - if (check_test (test, key, elt_car, keyed) == test_not_unboundp) + if (CONSP (elt) && + check_test (test, key, XCAR (elt), keyed) == test_not_unboundp) { - /* See comment in sublis() on using elt_cdr. */ - RETURN_UNGCPRO (XCDR (elt)); + XUNGCPRO (elt); + return XCDR (elt); } } + END_GC_EXTERNAL_LIST_LOOP (elt); } UNGCPRO; @@ -10521,13 +10542,12 @@ static Lisp_Object venn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp) { - Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil; + Lisp_Object liszt1 = args[0], liszt2 = args[1]; Lisp_Object result = EQ (caller, Qsubsetp) ? Qt : Qnil, result_tail = Qnil; Lisp_Object keyed = Qnil, ignore = Qnil; - Elemcount len; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; - struct gcpro gcpro1, gcpro2, gcpro3; + struct gcpro gcpro1, gcpro2; PARSE_KEYWORDS_8 (caller, nargs, args, 4, (test, key, test_not, stable), NULL, 2, 0); @@ -10550,10 +10570,10 @@ get_check_match_function (&test, test_not, Qnil, Qnil, key, &test_not_unboundp, &check_test); - GCPRO3 (tail, keyed, result); + GCPRO2 (keyed, result); { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len) + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1) { keyed = KEY (key, elt); if (NILP (list_position_cons_before (&ignore, keyed, liszt2, @@ -10581,6 +10601,7 @@ } } } + END_GC_EXTERNAL_LIST_LOOP (elt); } UNGCPRO; @@ -10596,7 +10617,7 @@ Elemcount count; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; - struct gcpro gcpro1, gcpro2, gcpro3; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; PARSE_KEYWORDS_8 (caller, nargs, args, 3, (test, key, test_not), NULL, 2, 0); @@ -10619,9 +10640,9 @@ get_check_match_function (&test, test_not, Qnil, Qnil, key, &test_not_unboundp, &check_test); - GCPRO3 (tail, keyed, liszt1); - - tortoise_elt = tail = liszt1, count = 0; + tortoise_elt = tail = liszt1, count = 0; + + GCPRO4 (tail, keyed, liszt1, tortoise_elt); while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 : (signal_malformed_list_error (liszt1), 0)) @@ -10793,11 +10814,10 @@ (int nargs, Lisp_Object *args)) { Lisp_Object liszt1 = args[0], liszt2 = args[1], ignore = Qnil; - Lisp_Object elt = Qnil, tail = Qnil, keyed = Qnil, result, result_tail; - Elemcount len; + Lisp_Object keyed = Qnil, result, result_tail; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL, check_match = NULL; - struct gcpro gcpro1, gcpro2, gcpro3; + struct gcpro gcpro1, gcpro2; PARSE_KEYWORDS (Funion, nargs, args, 4, (test, key, test_not, stable), NULL); @@ -10819,13 +10839,13 @@ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, &test_not_unboundp, &check_test); - GCPRO3 (tail, keyed, result); + GCPRO2 (keyed, result); if (NILP (stable)) { result = liszt2; { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len) + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1) { keyed = KEY (key, elt); if (NILP (list_position_cons_before (&ignore, keyed, liszt2, @@ -10843,6 +10863,7 @@ result = Fcons (elt, result); } } + END_GC_EXTERNAL_LIST_LOOP (elt); } } else @@ -10856,7 +10877,7 @@ elements in any fashion; providing the functionality for a stable union is an XEmacs extension. */ { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt2, tail, len) + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt2) { if (NILP (list_position_cons_before (&ignore, elt, liszt1, check_match, test_not_unboundp, @@ -10873,6 +10894,7 @@ } } } + END_GC_EXTERNAL_LIST_LOOP (elt); } result = NILP (result) ? liszt1 : nconc2 (Fcopy_list (liszt1), result); @@ -10900,12 +10922,11 @@ */ (int nargs, Lisp_Object *args)) { - Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil; + Lisp_Object liszt1 = args[0], liszt2 = args[1]; Lisp_Object result = Qnil, result_tail = Qnil, keyed = Qnil, ignore = Qnil; - Elemcount len; Boolint test_not_unboundp = 1; check_test_func_t check_match = NULL, check_test = NULL; - struct gcpro gcpro1, gcpro2, gcpro3; + struct gcpro gcpro1, gcpro2; PARSE_KEYWORDS (Fset_exclusive_or, nargs, args, 4, (test, key, test_not, stable), NULL); @@ -10923,9 +10944,9 @@ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, &test_not_unboundp, &check_test); - GCPRO3 (tail, keyed, result); + GCPRO2 (keyed, result); { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len) + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1) { keyed = KEY (key, elt); if (NILP (list_position_cons_before (&ignore, keyed, liszt2, @@ -10947,10 +10968,11 @@ } } } + END_GC_EXTERNAL_LIST_LOOP (elt); } { - EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt2, tail, len) + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt2) { if (NILP (list_position_cons_before (&ignore, elt, liszt1, check_match, test_not_unboundp, @@ -10971,7 +10993,9 @@ } } } + END_GC_EXTERNAL_LIST_LOOP (elt); } + UNGCPRO; return result; @@ -10996,7 +11020,7 @@ Elemcount count; Boolint test_not_unboundp = 1; check_test_func_t check_match = NULL, check_test = NULL; - struct gcpro gcpro1, gcpro2, gcpro3; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; PARSE_KEYWORDS (Fnset_exclusive_or, nargs, args, 4, (test, key, test_not, stable), NULL); @@ -11014,10 +11038,10 @@ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, &test_not_unboundp, &check_test); - GCPRO3 (tail, keyed, result); - tortoise_elt = tail = liszt1, count = 0; + GCPRO4 (tail, keyed, result, tortoise_elt); + while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 : (signal_malformed_list_error (liszt1), 0)) {
--- a/src/lisp.h Tue Mar 29 00:02:47 2011 +0200 +++ b/src/lisp.h Sat Apr 23 23:47:13 2011 +0200 @@ -2121,6 +2121,16 @@ PRIVATE_EXTERNAL_LIST_LOOP_6 (elt, list, len_##elt, tail, \ tortoise_##elt, CIRCULAR_LIST_SUSPICION_LENGTH) +#define GC_EXTERNAL_LIST_LOOP_3(elt, list, tail) \ +do { \ + XGCDECL3 (elt); \ + Lisp_Object elt, tail, tortoise_##elt; \ + EMACS_INT len_##elt; \ + XGCPRO3 (elt, elt, tail, tortoise_##elt); \ + PRIVATE_EXTERNAL_LIST_LOOP_6 (elt, list, len_##elt, tail, \ + tortoise_##elt, \ + CIRCULAR_LIST_SUSPICION_LENGTH) + #define EXTERNAL_LIST_LOOP_4_NO_DECLARE(elt, list, tail, len) \ Lisp_Object tortoise_##elt; \ PRIVATE_EXTERNAL_LIST_LOOP_6 (elt, list, len, tail, \ @@ -2132,6 +2142,15 @@ PRIVATE_EXTERNAL_LIST_LOOP_6 (elt, list, len, tail, \ tortoise_##elt, CIRCULAR_LIST_SUSPICION_LENGTH) +#define GC_EXTERNAL_LIST_LOOP_4(elt, list, tail, len) \ +do { \ + XGCDECL3 (elt); \ + Lisp_Object elt, tail, tortoise_##elt; \ + XGCPRO3 (elt, elt, tail, tortoise_##elt); \ + PRIVATE_EXTERNAL_LIST_LOOP_6 (elt, list, len, tail, \ + tortoise_##elt, \ + CIRCULAR_LIST_SUSPICION_LENGTH) + #define PRIVATE_UNVERIFIED_LIST_LOOP_7(elt, list, len, hare, \ tortoise, suspicion_length, \ signalp) \
--- a/src/redisplay-tty.c Tue Mar 29 00:02:47 2011 +0200 +++ b/src/redisplay-tty.c Sat Apr 23 23:47:13 2011 +0200 @@ -1114,6 +1114,13 @@ if (CONSOLE_TTY_DATA (c)->width <= 0 || CONSOLE_TTY_DATA (c)->height <= 0) return TTY_SIZE_UNSPECIFIED; + CONSOLE_TTY_DATA (c)->colors = tgetnum("Co"); + if (CONSOLE_TTY_DATA (c)->colors == 0) + CONSOLE_TTY_DATA (c)->colors = tgetnum("colors"); + if (CONSOLE_TTY_DATA (c)->colors == 0) + /* There is always foreground and background. */ + CONSOLE_TTY_DATA (c)->colors = 2; + /* * Initialize cursor motion information. */