December 2010 - XEmacs-Patches - XEmacs Mailing List Archives

commit: Revamp the Arabic support. Create greek-iso-8bit-with-esc, arabic-iso-8bit-with-esc. 7 years, 1 month

Aidan Kehoe

changeset: 4491:d402d7b18bd88bab41f37a186554f8c1f2f0eaae parent: 4488:6b0000935adc3f79cb189350d6014d4b4aff734e user: Aidan Kehoe <kehoea(a)parhasard.net> date: Tue Aug 05 08:37:17 2008 +0200 files: etc/ChangeLog etc/HELLO lisp/ChangeLog lisp/mule/arabic.el lisp/mule/iso-with-esc.el lisp/mule/mule-category.el lisp/mule/mule-msw-init-late.el lisp/mule/mule-win32-init.el lisp/unicode.el src/ChangeLog src/lisp.h src/mule-charset.c description: Revamp the Arabic support. Create greek-iso-8bit-with-esc, arabic-iso-8bit-with-esc. src/ChangeLog addition: 2008-08-05 Aidan Kehoe <kehoea(a)parhasard.net> * mule-charset.c (complex_vars_of_mule_charset): Remove Vcharset_arabic_iso8859_7. * lisp.h: Remove Vcharset_arabic_iso8859_7. See commentary in lisp/mule/iso-with-esc.el for motivation. lisp/ChangeLog addition: 2008-08-05 Aidan Kehoe <kehoea(a)parhasard.net> * mule/iso-with-esc.el (greek-iso-8bit-with-esc): (arabic-iso-8bit-with-esc): Add these two here. Move the implementation of the 'arabic-iso8859-6 character set here, with commentary on why that is reasonable. * mule/arabic.el (iso-8859-6): Add iso-8859-6, windows-1256 implementations using make-8-bit-coding-system. Remove our non-standard Mule character sets. * unicode.el (load-unicode-tables): Remove Arabic since it's no longer dumped. * mule/mule-msw-init-late.el: Remove Arabic. * mule/mule-category.el (predefined-category-list): Remove Arabic. etc/ChangeLog addition: 2008-08-05 Aidan Kehoe <kehoea(a)parhasard.net> * HELLO: Encode the Arabic using UTF-8 sequences, not ISO-8859-6. diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae etc/ChangeLog --- a/etc/ChangeLog Sat Jul 26 13:50:27 2008 +0300 +++ b/etc/ChangeLog Tue Aug 05 08:37:17 2008 +0200 ＠＠ -1,3 +1,7 ＠＠ 2008-02-21 Stephen J. Turnbull <stephe +2008-08-05 Aidan Kehoe <kehoea(a)parhasard.net> + + * HELLO: Encode the Arabic using UTF-8 sequences, not ISO-8859-6. + 2008-02-21 Stephen J. Turnbull <stephen(a)xemacs.org> * README: Add descriptions of Daniel Polansky's icons. diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae etc/HELLO --- a/etc/HELLO Sat Jul 26 13:50:27 2008 +0300 +++ b/etc/HELLO Tue Aug 05 08:37:17 2008 +0200 ＠＠ -3,7 +3,7 ＠＠ Please correct this incomplete list and --------------------------------------------------------- Amharic ($(3"c!<!N"^(B) $(3!A!,!>(B -Arabic [2](38R(47d(3T!JSa(4W(3W[0](B +Arabic (%Gةّيبرعلا%＠) %Gمكيلع%＠ %Gمالّسلا%＠ Croatian (Hrvatski) Bog (Bok), Dobar dan Czech (,Bh(Besky) Dobr,B}(B den Danish (Dansk) Hej, Goddag diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae lisp/ChangeLog --- a/lisp/ChangeLog Sat Jul 26 13:50:27 2008 +0300 +++ b/lisp/ChangeLog Tue Aug 05 08:37:17 2008 +0200 ＠＠ -1,3 +1,20 ＠＠ 2008-07-26 Aidan Kehoe <kehoea＠parhasa +2008-08-05 Aidan Kehoe <kehoea(a)parhasard.net> + + * mule/iso-with-esc.el (greek-iso-8bit-with-esc): + (arabic-iso-8bit-with-esc): + Add these two here. Move the implementation of the + 'arabic-iso8859-6 character set here, with commentary on why that + is reasonable. + * mule/arabic.el (iso-8859-6): + Add iso-8859-6, windows-1256 implementations using + make-8-bit-coding-system. Remove our non-standard Mule character + sets. + * unicode.el (load-unicode-tables): Remove Arabic since it's no + longer dumped. + * mule/mule-msw-init-late.el: Remove Arabic. + * mule/mule-category.el (predefined-category-list): Remove + Arabic. + 2008-07-26 Aidan Kehoe <kehoea(a)parhasard.net> * x-init.el (x-initialize-compose): diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae lisp/mule/arabic.el --- a/lisp/mule/arabic.el Sat Jul 26 13:50:27 2008 +0300 +++ b/lisp/mule/arabic.el Tue Aug 05 08:37:17 2008 +0200 ＠＠ -28,79 +28,204 ＠＠ ;;; Code: -; (make-charset 'arabic-iso8859-6 -; "Right-Hand Part of Latin/Arabic Alphabet (ISO/IEC 8859-6): ISO-IR-127" -; '(dimension -; 1 -; registry "ISO8859-6" -; chars 96 -; columns 1 -; direction r2l -; final ?G -; graphic 1 -; short-name "RHP of ISO8859/6" -; long-name "RHP of Arabic (ISO 8859-6): ISO-IR-127" -; )) - -;; For Arabic, we need three different types of character sets. -;; Digits are of direction left-to-right and of width 1-column. -;; Others are of direction right-to-left and of width 1-column or -;; 2-column. -(make-charset 'arabic-digit "Arabic digit" - '(dimension 1 - registries ["MuleArabic-0"] - chars 94 - columns 1 - direction l2r - final ?2 - graphic 0 - short-name "Arabic digit" - long-name "Arabic digit" - )) - -(make-charset 'arabic-1-column "Arabic 1-column" - '(dimension - 1 - registries ["MuleArabic-1"] - chars 94 - columns 1 - direction r2l - final ?3 - graphic 0 - short-name "Arabic 1-col" - long-name "Arabic 1-column" - )) - -(make-charset 'arabic-2-column "Arabic 2-column" - '(dimension - 1 - registries ["MuleArabic-2"] - chars 94 - columns 2 - direction r2l - final ?4 - graphic 0 - short-name "Arabic 2-col" - long-name "Arabic 2-column" - )) - -(make-coding-system 'iso-8859-6 'iso2022 - "ISO-8859-6 (Arabic)" - '(charset-g0 ascii - charset-g1 arabic-iso8859-6 - charset-g2 t - charset-g3 t - no-iso6429 t - mnemonic "MIME/Arbc" - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ARABIC -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; (define-language-environment 'arabic -;; "Arabic" -;; (lambda () -;; (require 'arabic))) +;; See iso-with-esc.el for commentary on the ISO standard Arabic character +;; set. + +(make-8-bit-coding-system + 'iso-8859-6 + '((#xA0 ?\u00A0) ;; NO-BREAK SPACE + (#xA4 ?\u00A4) ;; CURRENCY SIGN + (#xAC ?\u060C) ;; ARABIC COMMA + (#xAD ?\u00AD) ;; SOFT HYPHEN + (#xBB ?\u061B) ;; ARABIC SEMICOLON + (#xBF ?\u061F) ;; ARABIC QUESTION MARK + (#xC1 ?\u0621) ;; ARABIC LETTER HAMZA + (#xC2 ?\u0622) ;; ARABIC LETTER ALEF WITH MADDA ABOVE + (#xC3 ?\u0623) ;; ARABIC LETTER ALEF WITH HAMZA ABOVE + (#xC4 ?\u0624) ;; ARABIC LETTER WAW WITH HAMZA ABOVE + (#xC5 ?\u0625) ;; ARABIC LETTER ALEF WITH HAMZA BELOW + (#xC6 ?\u0626) ;; ARABIC LETTER YEH WITH HAMZA ABOVE + (#xC7 ?\u0627) ;; ARABIC LETTER ALEF + (#xC8 ?\u0628) ;; ARABIC LETTER BEH + (#xC9 ?\u0629) ;; ARABIC LETTER TEH MARBUTA + (#xCA ?\u062A) ;; ARABIC LETTER TEH + (#xCB ?\u062B) ;; ARABIC LETTER THEH + (#xCC ?\u062C) ;; ARABIC LETTER JEEM + (#xCD ?\u062D) ;; ARABIC LETTER HAH + (#xCE ?\u062E) ;; ARABIC LETTER KHAH + (#xCF ?\u062F) ;; ARABIC LETTER DAL + (#xD0 ?\u0630) ;; ARABIC LETTER THAL + (#xD1 ?\u0631) ;; ARABIC LETTER REH + (#xD2 ?\u0632) ;; ARABIC LETTER ZAIN + (#xD3 ?\u0633) ;; ARABIC LETTER SEEN + (#xD4 ?\u0634) ;; ARABIC LETTER SHEEN + (#xD5 ?\u0635) ;; ARABIC LETTER SAD + (#xD6 ?\u0636) ;; ARABIC LETTER DAD + (#xD7 ?\u0637) ;; ARABIC LETTER TAH + (#xD8 ?\u0638) ;; ARABIC LETTER ZAH + (#xD9 ?\u0639) ;; ARABIC LETTER AIN + (#xDA ?\u063A) ;; ARABIC LETTER GHAIN + (#xE0 ?\u0640) ;; ARABIC TATWEEL + (#xE1 ?\u0641) ;; ARABIC LETTER FEH + (#xE2 ?\u0642) ;; ARABIC LETTER QAF + (#xE3 ?\u0643) ;; ARABIC LETTER KAF + (#xE4 ?\u0644) ;; ARABIC LETTER LAM + (#xE5 ?\u0645) ;; ARABIC LETTER MEEM + (#xE6 ?\u0646) ;; ARABIC LETTER NOON + (#xE7 ?\u0647) ;; ARABIC LETTER HEH + (#xE8 ?\u0648) ;; ARABIC LETTER WAW + (#xE9 ?\u0649) ;; ARABIC LETTER ALEF MAKSURA + (#xEA ?\u064A) ;; ARABIC LETTER YEH + (#xEB ?\u064B) ;; ARABIC FATHATAN + (#xEC ?\u064C) ;; ARABIC DAMMATAN + (#xED ?\u064D) ;; ARABIC KASRATAN + (#xEE ?\u064E) ;; ARABIC FATHA + (#xEF ?\u064F) ;; ARABIC DAMMA + (#xF0 ?\u0650) ;; ARABIC KASRA + (#xF1 ?\u0651) ;; ARABIC SHADDA + (#xF2 ?\u0652)) ;; ARABIC SUKUN + "ISO 8859-6 (Arabic)" +'(mnemonic "ArISO")) + +(make-8-bit-coding-system + 'windows-1256 + '((#x80 ?\u20AC) ;; EURO SIGN + (#x81 ?\u067E) ;; ARABIC LETTER PEH + (#x82 ?\u201A) ;; SINGLE LOW-9 QUOTATION MARK + (#x83 ?\u0192) ;; LATIN SMALL LETTER F WITH HOOK + (#x84 ?\u201E) ;; DOUBLE LOW-9 QUOTATION MARK + (#x85 ?\u2026) ;; HORIZONTAL ELLIPSIS + (#x86 ?\u2020) ;; DAGGER + (#x87 ?\u2021) ;; DOUBLE DAGGER + (#x88 ?\u02C6) ;; MODIFIER LETTER CIRCUMFLEX ACCENT + (#x89 ?\u2030) ;; PER MILLE SIGN + (#x8A ?\u0679) ;; ARABIC LETTER TTEH + (#x8B ?\u2039) ;; SINGLE LEFT-POINTING ANGLE QUOTATION MARK + (#x8C ?\u0152) ;; LATIN CAPITAL LIGATURE OE + (#x8D ?\u0686) ;; ARABIC LETTER TCHEH + (#x8E ?\u0698) ;; ARABIC LETTER JEH + (#x8F ?\u0688) ;; ARABIC LETTER DDAL + (#x90 ?\u06AF) ;; ARABIC LETTER GAF + (#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 + (#x98 ?\u06A9) ;; ARABIC LETTER KEHEH + (#x99 ?\u2122) ;; TRADE MARK SIGN + (#x9A ?\u0691) ;; ARABIC LETTER RREH + (#x9B ?\u203A) ;; SINGLE RIGHT-POINTING ANGLE QUOTATION MARK + (#x9C ?\u0153) ;; LATIN SMALL LIGATURE OE + (#x9D ?\u200C) ;; ZERO WIDTH NON-JOINER + (#x9E ?\u200D) ;; ZERO WIDTH JOINER + (#x9F ?\u06BA) ;; ARABIC LETTER NOON GHUNNA + (#xA0 ?\u00A0) ;; NO-BREAK SPACE + (#xA1 ?\u060C) ;; ARABIC COMMA + (#xA2 ?\u00A2) ;; CENT SIGN + (#xA3 ?\u00A3) ;; POUND SIGN + (#xA4 ?\u00A4) ;; CURRENCY SIGN + (#xA5 ?\u00A5) ;; YEN SIGN + (#xA6 ?\u00A6) ;; BROKEN BAR + (#xA7 ?\u00A7) ;; SECTION SIGN + (#xA8 ?\u00A8) ;; DIAERESIS + (#xA9 ?\u00A9) ;; COPYRIGHT SIGN + (#xAA ?\u06BE) ;; ARABIC LETTER HEH DOACHASHMEE + (#xAB ?\u00AB) ;; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK + (#xAC ?\u00AC) ;; NOT SIGN + (#xAD ?\u00AD) ;; SOFT HYPHEN + (#xAE ?\u00AE) ;; REGISTERED SIGN + (#xAF ?\u00AF) ;; MACRON + (#xB0 ?\u00B0) ;; DEGREE SIGN + (#xB1 ?\u00B1) ;; PLUS-MINUS SIGN + (#xB2 ?\u00B2) ;; SUPERSCRIPT TWO + (#xB3 ?\u00B3) ;; SUPERSCRIPT THREE + (#xB4 ?\u00B4) ;; ACUTE ACCENT + (#xB5 ?\u00B5) ;; MICRO SIGN + (#xB6 ?\u00B6) ;; PILCROW SIGN + (#xB7 ?\u00B7) ;; MIDDLE DOT + (#xB8 ?\u00B8) ;; CEDILLA + (#xB9 ?\u00B9) ;; SUPERSCRIPT ONE + (#xBA ?\u061B) ;; ARABIC SEMICOLON + (#xBB ?\u00BB) ;; RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK + (#xBC ?\u00BC) ;; VULGAR FRACTION ONE QUARTER + (#xBD ?\u00BD) ;; VULGAR FRACTION ONE HALF + (#xBE ?\u00BE) ;; VULGAR FRACTION THREE QUARTERS + (#xBF ?\u061F) ;; ARABIC QUESTION MARK + (#xC0 ?\u06C1) ;; ARABIC LETTER HEH GOAL + (#xC1 ?\u0621) ;; ARABIC LETTER HAMZA + (#xC2 ?\u0622) ;; ARABIC LETTER ALEF WITH MADDA ABOVE + (#xC3 ?\u0623) ;; ARABIC LETTER ALEF WITH HAMZA ABOVE + (#xC4 ?\u0624) ;; ARABIC LETTER WAW WITH HAMZA ABOVE + (#xC5 ?\u0625) ;; ARABIC LETTER ALEF WITH HAMZA BELOW + (#xC6 ?\u0626) ;; ARABIC LETTER YEH WITH HAMZA ABOVE + (#xC7 ?\u0627) ;; ARABIC LETTER ALEF + (#xC8 ?\u0628) ;; ARABIC LETTER BEH + (#xC9 ?\u0629) ;; ARABIC LETTER TEH MARBUTA + (#xCA ?\u062A) ;; ARABIC LETTER TEH + (#xCB ?\u062B) ;; ARABIC LETTER THEH + (#xCC ?\u062C) ;; ARABIC LETTER JEEM + (#xCD ?\u062D) ;; ARABIC LETTER HAH + (#xCE ?\u062E) ;; ARABIC LETTER KHAH + (#xCF ?\u062F) ;; ARABIC LETTER DAL + (#xD0 ?\u0630) ;; ARABIC LETTER THAL + (#xD1 ?\u0631) ;; ARABIC LETTER REH + (#xD2 ?\u0632) ;; ARABIC LETTER ZAIN + (#xD3 ?\u0633) ;; ARABIC LETTER SEEN + (#xD4 ?\u0634) ;; ARABIC LETTER SHEEN + (#xD5 ?\u0635) ;; ARABIC LETTER SAD + (#xD6 ?\u0636) ;; ARABIC LETTER DAD + (#xD7 ?\u00D7) ;; MULTIPLICATION SIGN + (#xD8 ?\u0637) ;; ARABIC LETTER TAH + (#xD9 ?\u0638) ;; ARABIC LETTER ZAH + (#xDA ?\u0639) ;; ARABIC LETTER AIN + (#xDB ?\u063A) ;; ARABIC LETTER GHAIN + (#xDC ?\u0640) ;; ARABIC TATWEEL + (#xDD ?\u0641) ;; ARABIC LETTER FEH + (#xDE ?\u0642) ;; ARABIC LETTER QAF + (#xDF ?\u0643) ;; ARABIC LETTER KAF + (#xE0 ?\u00E0) ;; LATIN SMALL LETTER A WITH GRAVE + (#xE1 ?\u0644) ;; ARABIC LETTER LAM + (#xE2 ?\u00E2) ;; LATIN SMALL LETTER A WITH CIRCUMFLEX + (#xE3 ?\u0645) ;; ARABIC LETTER MEEM + (#xE4 ?\u0646) ;; ARABIC LETTER NOON + (#xE5 ?\u0647) ;; ARABIC LETTER HEH + (#xE6 ?\u0648) ;; ARABIC LETTER WAW + (#xE7 ?\u00E7) ;; LATIN SMALL LETTER C WITH CEDILLA + (#xE8 ?\u00E8) ;; LATIN SMALL LETTER E WITH GRAVE + (#xE9 ?\u00E9) ;; LATIN SMALL LETTER E WITH ACUTE + (#xEA ?\u00EA) ;; LATIN SMALL LETTER E WITH CIRCUMFLEX + (#xEB ?\u00EB) ;; LATIN SMALL LETTER E WITH DIAERESIS + (#xEC ?\u0649) ;; ARABIC LETTER ALEF MAKSURA + (#xED ?\u064A) ;; ARABIC LETTER YEH + (#xEE ?\u00EE) ;; LATIN SMALL LETTER I WITH CIRCUMFLEX + (#xEF ?\u00EF) ;; LATIN SMALL LETTER I WITH DIAERESIS + (#xF0 ?\u064B) ;; ARABIC FATHATAN + (#xF1 ?\u064C) ;; ARABIC DAMMATAN + (#xF2 ?\u064D) ;; ARABIC KASRATAN + (#xF3 ?\u064E) ;; ARABIC FATHA + (#xF4 ?\u00F4) ;; LATIN SMALL LETTER O WITH CIRCUMFLEX + (#xF5 ?\u064F) ;; ARABIC DAMMA + (#xF6 ?\u0650) ;; ARABIC KASRA + (#xF7 ?\u00F7) ;; DIVISION SIGN + (#xF8 ?\u0651) ;; ARABIC SHADDA + (#xF9 ?\u00F9) ;; LATIN SMALL LETTER U WITH GRAVE + (#xFA ?\u0652) ;; ARABIC SUKUN + (#xFB ?\u00FB) ;; LATIN SMALL LETTER U WITH CIRCUMFLEX + (#xFC ?\u00FC) ;; LATIN SMALL LETTER U WITH DIAERESIS + (#xFD ?\u200E) ;; LEFT-TO-RIGHT MARK + (#xFE ?\u200F) ;; RIGHT-TO-LEFT MARK + (#xFF ?\u06D2));; ARABIC LETTER YEH BARREE + "Windows-1256 (Arabic)" + '(mnemonic "cp1256" + documentation + "This is the much Windows encoding for Arabic, much superior to the ISO +standard one." + aliases (cp1256))) + +;; The Mac Arabic coding systems don't have defined MIME names. + +;; #### Decide what to do about the syntax of the Arabic punctuation. ;;; arabic.el ends here diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae lisp/mule/iso-with-esc.el --- a/lisp/mule/iso-with-esc.el Sat Jul 26 13:50:27 2008 +0300 +++ b/lisp/mule/iso-with-esc.el Tue Aug 05 08:37:17 2008 +0200 ＠＠ -98,3 +98,108 ＠＠ charset-g3 t no-iso6429 t mnemonic "MIME/Hbrw")) + +;;;###autoload +(make-coding-system + 'greek-iso-8bit-with-esc 'iso2022 "MIME ISO-8859-7" + '(charset-g0 ascii + charset-g1 greek-iso8859-7 + charset-g2 t + charset-g3 t + mnemonic "Grk")) + +;; ISO 8859-6 is such a useless character set that it seems a waste of +;; codespace to dump it. Let me count the ways: +;; +;; 1. It doesn't support Persian or Urdu, let alone Sinhalese, despite +;; plenty of unallocated code points. +;; +;; 2. It doesn't encode all the vowel diacritics (the Harakaat) despite that +;; they are necessary, even for the Arabs, for basic things like +;; dictionary entries, children's books, and occasional disambiguation. +;; +;; 3. The Arabs don't use it, they use Windows-1256, which also supports +;; Persian, at least, as well as the French characters necessary in +;; Lebanon and North Africa. + +(make-charset + 'arabic-iso8859-6 + "Right-Hand Part of Latin/Arabic Alphabet (ISO/IEC 8859-6): ISO-IR-127" + '(dimension 1 + registry "ISO8859-6" + chars 96 + columns 1 + direction r2l + final ?G + graphic 1 + short-name "RHP of ISO8859/6" + long-name "RHP of Arabic (ISO 8859-6): ISO-IR-127")) + +(loop + for (iso8859-6 unicode) + in '((#xA0 #x00A0) ;; NO-BREAK SPACE + (#xA4 #x00A4) ;; CURRENCY SIGN + (#xAC #x060C) ;; ARABIC COMMA + (#xAD #x00AD) ;; SOFT HYPHEN + (#xBB #x061B) ;; ARABIC SEMICOLON + (#xBF #x061F) ;; ARABIC QUESTION MARK + (#xC1 #x0621) ;; ARABIC LETTER HAMZA + (#xC2 #x0622) ;; ARABIC LETTER ALEF WITH MADDA ABOVE + (#xC3 #x0623) ;; ARABIC LETTER ALEF WITH HAMZA ABOVE + (#xC4 #x0624) ;; ARABIC LETTER WAW WITH HAMZA ABOVE + (#xC5 #x0625) ;; ARABIC LETTER ALEF WITH HAMZA BELOW + (#xC6 #x0626) ;; ARABIC LETTER YEH WITH HAMZA ABOVE + (#xC7 #x0627) ;; ARABIC LETTER ALEF + (#xC8 #x0628) ;; ARABIC LETTER BEH + (#xC9 #x0629) ;; ARABIC LETTER TEH MARBUTA + (#xCA #x062A) ;; ARABIC LETTER TEH + (#xCB #x062B) ;; ARABIC LETTER THEH + (#xCC #x062C) ;; ARABIC LETTER JEEM + (#xCD #x062D) ;; ARABIC LETTER HAH + (#xCE #x062E) ;; ARABIC LETTER KHAH + (#xCF #x062F) ;; ARABIC LETTER DAL + (#xD0 #x0630) ;; ARABIC LETTER THAL + (#xD1 #x0631) ;; ARABIC LETTER REH + (#xD2 #x0632) ;; ARABIC LETTER ZAIN + (#xD3 #x0633) ;; ARABIC LETTER SEEN + (#xD4 #x0634) ;; ARABIC LETTER SHEEN + (#xD5 #x0635) ;; ARABIC LETTER SAD + (#xD6 #x0636) ;; ARABIC LETTER DAD + (#xD7 #x0637) ;; ARABIC LETTER TAH + (#xD8 #x0638) ;; ARABIC LETTER ZAH + (#xD9 #x0639) ;; ARABIC LETTER AIN + (#xDA #x063A) ;; ARABIC LETTER GHAIN + (#xE0 #x0640) ;; ARABIC TATWEEL + (#xE1 #x0641) ;; ARABIC LETTER FEH + (#xE2 #x0642) ;; ARABIC LETTER QAF + (#xE3 #x0643) ;; ARABIC LETTER KAF + (#xE4 #x0644) ;; ARABIC LETTER LAM + (#xE5 #x0645) ;; ARABIC LETTER MEEM + (#xE6 #x0646) ;; ARABIC LETTER NOON + (#xE7 #x0647) ;; ARABIC LETTER HEH + (#xE8 #x0648) ;; ARABIC LETTER WAW + (#xE9 #x0649) ;; ARABIC LETTER ALEF MAKSURA + (#xEA #x064A) ;; ARABIC LETTER YEH + (#xEB #x064B) ;; ARABIC FATHATAN + (#xEC #x064C) ;; ARABIC DAMMATAN + (#xED #x064D) ;; ARABIC KASRATAN + (#xEE #x064E) ;; ARABIC FATHA + (#xEF #x064F) ;; ARABIC DAMMA + (#xF0 #x0650) ;; ARABIC KASRA + (#xF1 #x0651) ;; ARABIC SHADDA + (#xF2 #x0652));; ARABIC SUKUN + do (set-unicode-conversion (make-char 'arabic-iso8859-6 iso8859-6) + unicode)) + +;;;###autoload +(make-coding-system + 'arabic-iso-8bit-with-esc 'iso2022 ;; GNU's iso-8859-6 is + ;; iso2022-compatible. + "ISO-8859-6 (Arabic)" + '(charset-g0 ascii + charset-g1 arabic-iso8859-6 + charset-g2 t + charset-g3 t + no-iso6429 t + mnemonic "MIME/Arbc")) + diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae lisp/mule/mule-category.el --- a/lisp/mule/mule-category.el Sat Jul 26 13:50:27 2008 +0300 +++ b/lisp/mule/mule-category.el Tue Aug 05 08:37:17 2008 +0200 ＠＠ -244,7 +244,6 ＠＠ The descriptions are inserted in a buffe (latin-iso8859-4 ?l) (latin-iso8859-9 ?l) (cyrillic-iso8859-5 ?y "Cyrillic character set") - (arabic-iso8859-6 ?b "Arabic character set") (greek-iso8859-7 ?g "Greek character set") (hebrew-iso8859-8 ?w "Hebrew character set") (katakana-jisx0201 ?k "Japanese 1-byte Katakana character set") diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae lisp/mule/mule-msw-init-late.el --- a/lisp/mule/mule-msw-init-late.el Sat Jul 26 13:50:27 2008 +0300 +++ b/lisp/mule/mule-msw-init-late.el Tue Aug 05 08:37:17 2008 +0200 ＠＠ -37,7 +37,6 ＠＠ (greek-iso8859-7 . "Greek") (latin-iso8859-9 . "Turkish") (hebrew-iso8859-8 . "Hebrew") - (arabic-iso8859-6 . "Arabic") (latin-iso8859-4 . "Baltic") (vietnamese-viscii-lower . "Viet Nam") (vietnamese-viscii-upper . "Viet Nam") diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae lisp/mule/mule-win32-init.el --- a/lisp/mule/mule-win32-init.el Sat Jul 26 13:50:27 2008 +0300 +++ b/lisp/mule/mule-win32-init.el Tue Aug 05 08:37:17 2008 +0200 ＠＠ -162,7 +162,8 ＠＠ as returned by ; ("ANSI" 1253 no-conversion "Windows 3.1 Greek") ("ANSI" 1254 no-conversion "Windows 3.1 Turkish") ("ANSI" 1255 no-conversion "Hebrew") - ("ANSI" 1256 no-conversion "Arabic") + ;; We implement these ourselves. + ; ("ANSI" 1256 no-conversion "Arabic") ("ANSI" 1257 no-conversion "Baltic") ("ANSI" 1258 no-conversion "VietNam") ;; #### Is this category right? I don't have Lunde to hand, and the diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae lisp/unicode.el --- a/lisp/unicode.el Sat Jul 26 13:50:27 2008 +0300 +++ b/lisp/unicode.el Tue Aug 05 08:37:17 2008 +0200 ＠＠ -73,7 +73,6 ＠＠ Setting this at run-time does nothing.") ("8859-3.TXT" latin-iso8859-3 #xA0 #xFF #x-80) ("8859-4.TXT" latin-iso8859-4 #xA0 #xFF #x-80) ("8859-5.TXT" cyrillic-iso8859-5 #xA0 #xFF #x-80) - ("8859-6.TXT" arabic-iso8859-6 #xA0 #xFF #x-80) ("8859-7.TXT" greek-iso8859-7 #xA0 #xFF #x-80) ("8859-8.TXT" hebrew-iso8859-8 #xA0 #xFF #x-80) ("8859-9.TXT" latin-iso8859-9 #xA0 #xFF #x-80) ＠＠ -154,12 +153,12 ＠＠ Setting this at run-time does nothing.") '(ascii control-1 latin-iso8859-1 latin-iso8859-2 latin-iso8859-15 greek-iso8859-7 hebrew-iso8859-8 ipa cyrillic-iso8859-5 latin-iso8859-16 latin-iso8859-3 latin-iso8859-4 latin-iso8859-9 - vietnamese-viscii-lower vietnamese-viscii-upper arabic-iso8859-6 + vietnamese-viscii-lower vietnamese-viscii-upper jit-ucs-charset-0 japanese-jisx0208 japanese-jisx0208-1978 japanese-jisx0212 japanese-jisx0213-1 japanese-jisx0213-2 chinese-gb2312 chinese-sisheng chinese-big5-1 chinese-big5-2 indian-is13194 korean-ksc5601 chinese-cns11643-1 chinese-cns11643-2 - chinese-isoir165 arabic-1-column arabic-2-column arabic-digit + 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 latin-jisx0201 chinese-cns11643-3 chinese-cns11643-4 diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae src/ChangeLog --- a/src/ChangeLog Sat Jul 26 13:50:27 2008 +0300 +++ b/src/ChangeLog Tue Aug 05 08:37:17 2008 +0200 ＠＠ -1,3 +1,10 ＠＠ 2008-07-20 John Paul Wallington <jpw＠p +2008-08-05 Aidan Kehoe <kehoea(a)parhasard.net> + + * mule-charset.c (complex_vars_of_mule_charset): + Remove Vcharset_arabic_iso8859_7. + * lisp.h: Remove Vcharset_arabic_iso8859_7. + See commentary in lisp/mule/iso-with-esc.el for motivation. + 2008-07-20 John Paul Wallington <jpw(a)pobox.com> * nt.c (Fmswindows_short_file_name, Fmswindows_long_file_name): diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae src/lisp.h --- a/src/lisp.h Sat Jul 26 13:50:27 2008 +0300 +++ b/src/lisp.h Tue Aug 05 08:37:17 2008 +0200 ＠＠ -5229,7 +5229,6 ＠＠ extern Lisp_Object Vcharset_latin_iso885 extern Lisp_Object Vcharset_latin_iso8859_4; extern Lisp_Object Vcharset_thai_tis620; extern Lisp_Object Vcharset_greek_iso8859_7; -extern Lisp_Object Vcharset_arabic_iso8859_6; extern Lisp_Object Vcharset_hebrew_iso8859_8; extern Lisp_Object Vcharset_katakana_jisx0201; extern Lisp_Object Vcharset_latin_jisx0201; diff -r 6b0000935adc3f79cb189350d6014d4b4aff734e -r d402d7b18bd88bab41f37a186554f8c1f2f0eaae src/mule-charset.c --- a/src/mule-charset.c Sat Jul 26 13:50:27 2008 +0300 +++ b/src/mule-charset.c Tue Aug 05 08:37:17 2008 +0200 ＠＠ -47,7 +47,6 ＠＠ Lisp_Object Vcharset_latin_iso8859_4; Lisp_Object Vcharset_latin_iso8859_4; Lisp_Object Vcharset_thai_tis620; Lisp_Object Vcharset_greek_iso8859_7; -Lisp_Object Vcharset_arabic_iso8859_6; Lisp_Object Vcharset_hebrew_iso8859_8; Lisp_Object Vcharset_katakana_jisx0201; Lisp_Object Vcharset_latin_jisx0201; ＠＠ -94,7 +93,6 ＠＠ Lisp_Object Qlatin_iso8859_4, Qthai_tis620, Qgreek_iso8859_7, - Qarabic_iso8859_6, Qhebrew_iso8859_8, Qkatakana_jisx0201, Qlatin_jisx0201, ＠＠ -1112,7 +1110,6 ＠＠ syms_of_mule_charset (void) DEFSYMBOL (Qlatin_iso8859_4); DEFSYMBOL (Qthai_tis620); DEFSYMBOL (Qgreek_iso8859_7); - DEFSYMBOL (Qarabic_iso8859_6); DEFSYMBOL (Qhebrew_iso8859_8); DEFSYMBOL (Qkatakana_jisx0201); DEFSYMBOL (Qlatin_jisx0201); ＠＠ -1236,15 +1233,6 ＠＠ complex_vars_of_mule_charset (void) build_msg_string ("ISO8859-7 (Greek)"), build_msg_string ("ISO8859-7 (Greek)"), vector1(build_string("iso8859-7")), 0, 0); - staticpro (&Vcharset_arabic_iso8859_6); - Vcharset_arabic_iso8859_6 = - make_charset (LEADING_BYTE_ARABIC_ISO8859_6, Qarabic_iso8859_6, 2, - CHARSET_TYPE_96, 1, 1, 'G', - CHARSET_RIGHT_TO_LEFT, - build_string ("ISO8859-6"), - build_msg_string ("ISO8859-6 (Arabic)"), - build_msg_string ("ISO8859-6 (Arabic)"), - vector1(build_string ("iso8859-6")), 0, 0); staticpro (&Vcharset_hebrew_iso8859_8); Vcharset_hebrew_iso8859_8 = make_charset (LEADING_BYTE_HEBREW_ISO8859_8, Qhebrew_iso8859_8, 2, _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
0 comments

[AC general-docs] draft XEmacs Developer's Guide 7 years, 3 months

Stephen J. Turnbull

APPROVE COMMIT general-docs With this patch the XEmacs Developer's Guide is a fairly self-contained and internally consistent guide to best current practices of the XEmacs Project. I hope it will turn into a policy document, but that would require the Review Board to show some interest in policy.... It remains rather incomplete; contributions welcome. Once again many thanks to Bill Wohler whose MH-E Developer's Guide formed the framework for this document, and for his permission to publish it under the GPL. Also to the XEmacs reviewers and developers who have built the procedures and discussed the policies over the years. Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/general-docs/ChangeLog,v retrieving revision 1.16 diff -u -r1.16 ChangeLog --- ChangeLog 2005/05/07 12:23:53 1.16 +++ ChangeLog 2007/05/12 08:32:10 ＠＠ -0,0 +1,51 ＠＠ +2007-05-13 Stephen J. Turnbull <stephen(a)xemacs.org> + + Publish xemacs-devguide. + + * Makefile (EXPLICIT_DOCS): Add xemacs-devguide.texi. + +2007-05-13 Stephen J. Turnbull <stephen(a)xemacs.org> + + * texi/xemacs/xemacs-devguide.texi: + (Philosophy): Rewrite to look like XEmacs current practice. + +2007-02-17 Stephen J. Turnbull <stephen(a)xemacs.org> + + Fix up xemacs-devguide. + + * texi/xemacs/xemacs-devguide.texi: + Remove all the silly Edited: and Written: tags. + Implicit self-approval: This is decided, we just need to fix + the commit trigger. + Guide variables: Update dates and add DEVGUIDE. Use it. + xemacs-design: Update references to note it's inactive. + Copyrights: Update mine, improve formatting slightly. + Fix typos. + + (Nodes borrowed from other projects not adapted to XEmacs): + New appendix. Update menus. + (Philosophy): Revise desiderata. Deprecate GFDL. + (Committer): Clarify usage. + (Committer Welcome Message): Update package tree size estimate. + (Release Engineer): Clarify "ex oficio". + (The Work Flow): Clarify absence of binary packages. + (About Copyright Assignment): Clarify FSF policy on XEmacs. + (ChangeLogs): Clarify syntax of log entries. + (Copying): Moved whole node. + + (The Package Maintainer Role): + (Getting Started as a Package Maintainer): + (Advice to Package Maintainers): + New subnodes of XEmacs Package Maintainer. + + (Support Requests): + (Bugs): + (Feature Requests): + (Patch Queue): + (File Releases): + (News): + (Surveys): + (Free Software Directories): + Move these nodes and subnodes into new Appendix, update pointers. + A few desultory fixups. + Index: Makefile =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/general-docs/Makefile,v retrieving revision 1.13 diff -u -r1.13 Makefile --- Makefile 2005/05/07 12:23:54 1.13 +++ Makefile 2007/05/12 08:32:10 ＠＠ -27,6 +27,7 ＠＠ # We'll need something like this. #EXPLICIT_DOCS = texi/*.texi texi/xemacs/*.texi texi/packages/*.texi -EXPLICIT_DOCS = texi/xemacs/fontconfig.texi +EXPLICIT_DOCS = texi/xemacs/fontconfig.texi \ + texi/xemacs/xemacs-devguide.texi include ../../XEmacs.rules Index: texi/xemacs/xemacs-devguide.texi =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/general-docs/texi/xemacs/xemacs-devguide.texi,v retrieving revision 1.1 diff -u -r1.1 xemacs-devguide.texi --- texi/xemacs/xemacs-devguide.texi 2005/02/01 16:08:35 1.1 +++ texi/xemacs/xemacs-devguide.texi 2007/05/12 08:32:12 ＠＠ -3,16 +3,16 ＠＠＠c Generate HTML with: ＠c (shell-command "texi2html -number -monolithic xemacs-devguide.texi" nil) ＠c -＠c Preamble edited: stephen 2005-01-20 ＠c %**start of header ＠setfilename ../../info/xemacs-devguide.info ＠settitle xemacs-devguide ＠c %**end of header -＠c Version variables. -＠set EDITION 0.5 -＠set UPDATED 2005-01-20 -＠set UPDATE-MONTH January, 2005 +＠c Developer's Guide variables. +＠set DEVGUIDE ＠cite{XEmacs Developer's Guide} +＠set EDITION 0.6 +＠set UPDATED 2007-02-17 +＠set UPDATE-MONTH February, 2007 ＠c Other variables. ＠set XEMACSORG XEmacs.ORG ＠＠ -22,6 +22,7 ＠＠＠set C-E-X the ＠i{comp.emacs.xemacs} Usenet newsgroup ＠set ANNOUNCE-LIST the ＠email{xemacs-announce＠(a)xemacs.org,XEmacs Announcements} mailing list ＠set BETA-LIST the ＠email{xemacs-beta＠(a)xemacs.org,XEmacs Beta} mailing list +＠c xemacs-design is currently not operative; substitute xemacs-beta ＠set DESIGN-LIST the ＠email{xemacs-design＠(a)xemacs.org,XEmacs Design} mailing list ＠set REVIEW-LIST the ＠email{xemacs-review＠(a)xemacs.org,XEmacs Review} mailing list ＠set PATCHES-LIST the ＠email{xemacs-patches＠(a)xemacs.org,XEmacs Patches} mailing list ＠＠ -29,19 +30,20 ＠＠＠set BUILDREPORTS-LIST the ＠email{xemacs-buildreports＠(a)xemacs.org,XEmacs Build Reports} mailing list ＠copying -This is Edition ＠value{EDITION} of the ＠cite{XEmacs Developers Guide}, +This is Edition ＠value{EDITION} of the ＠value{DEVGUIDE}, last updated ＠value{UPDATED}. -Copyright ＠copyright{} 2000, 01, 02, 03, 2004 Bill Wohler -Copyright ＠copyright{} 2005 Free Software Foundation +Copyright ＠copyright{} 2000, 2001, 2002, 2003, 2004 Bill Wohler +Copyright ＠copyright{} 2005, 2007 Free Software Foundation + ＠quotation -The ＠cite{XEmacs Developers Guide} is free documentation; you can +The ＠value{DEVGUIDE} is free documentation; 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 2, or (at your option) any later version. -The ＠cite{XEmacs Developers Guide} is distributed in the hope that it +The ＠value{DEVGUIDE} 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. ＠＠ -57,11 +59,11 ＠＠＠dircategory XEmacs Editor ＠direntry -* XEmacs Developers Guide: (xemacs-devguide). UNOFFICIAL EARLY DRAFT. +* XEmacs Developer's Guide: (xemacs-devguide). DRAFT. ＠end direntry ＠titlepage -＠title The XEmacs Developers Guide +＠title The XEmacs Developer's Guide ＠subtitle Edition ＠value{EDITION} ＠subtitle ＠value{UPDATE-MONTH} ＠author Stephen J. Turnbull ＠＠ -97,18 +99,7 ＠＠ * The Work Roles:: * The Work Flow:: * XEmacs Resources on the Internet:: - -Nodes borrowed from other projects, not adapted to XEmacs: - -* Support Requests:: -* Bugs:: -* Feature Requests:: -* Patch Queue:: -* File Releases:: -* News:: -* Surveys:: -* Free Software Directories:: -* Copying:: +* Nodes borrowed from other projects not adapted to XEmacs:: * Index:: ＠detailmenu ＠＠ -129,6 +120,11 ＠＠ * Commit Access:: * Committer Welcome Message:: +XEmacs Package Maintainer + +* The Package Maintainer Role:: +* Advice to Package Maintainers:: + XEmacs Reviewer * Appointing New Reviewers:: ＠＠ -155,7 +151,7 ＠＠ Submit the Patch -* Proposed Optional Alternate Procedure for Reviewers:: +* Optional Alternate Procedure for Reviewers:: Patch Review ＠＠ -178,6 +174,16 ＠＠ Nodes borrowed from other projects, not adapted to XEmacs +* Support Requests:: +* Bugs:: +* Feature Requests:: +* Patch Queue:: +* File Releases:: +* News:: +* Surveys:: +* Free Software Directories:: +* Copying:: + Bugs * Category:: ＠＠ -211,8 +217,6 ＠＠＠node Acknowledgments, Introduction, Top, Top ＠chapter Acknowledgments -＠c Edited: stephen 2005-01-18 - Special thanks go to Bill Wohler, whose ＠emph{MH-E Developers Guide} formed the framework for this document, and contributed a lot of text as well, for permission to redistribute the derived work under the GNU ＠＠ -227,8 +231,6 ＠＠＠node Introduction, Philosophy, Acknowledgments, Top ＠chapter Introduction -＠c Edited: stephen 2005-01-18 - ＠cindex Introduction ＠cindex ＠value{XEMACSORG} ＠＠ -250,7 +252,7 ＠＠＠cindex xemacs-design And remember, this is your document. If you think something is bogus, -start a movement on ＠value{DESIGN-LIST}. One of the tenets of the +start a movement on ＠value{BETA-LIST}. One of the tenets of the philosophy is rough consensus. If you can get a rough consensus to agree with your point of view, then the document shall be changed accordingly. ＠＠ -265,19 +267,7 ＠＠ Feel free to submit patches to ＠value{PATCHES-LIST}. Please try to review and edit a whole node at a time. They're short; it's not that -great a burden. XEmacs Reviewers: If you review and approve of a node -as is, please add a comment just below the ＠samp{＠＠node} and sectioning -commands in the node like - -＠example -＠＠c Reviewed: ＠var{name} ＠var{date} -＠end example - -Otherwise, edit the node and add a comment - -＠example -＠＠c Edited: ＠var{name} ＠var{date} -＠end example +great a burden. ＠end cartouche ＠＠ -286,14 +276,12 ＠＠＠node Philosophy, The Work Roles, Introduction, Top ＠chapter Philosophy -＠c Edited: stephen 2005-01-18 - ＠cindex Philosophy -＠strong{Currently pretty much everything in this node is hardly -representative of the ＠value{PROJECT}. Sometimes stephen thinks much of -this would be a good statement of values, other times he doesn't. What -do you think? Submit a patch!} +＠strong{This node is hardly +changed from the ＠emph{MH-E Developers Guide}, and is not +representative of the ＠value{PROJECT}. However, everything here has +been espoused by XEmacs developers at one time or another.} This chapter discusses the philosophy and principles of the XEmacs project. The first section covers our coding philosophy, while the ＠＠ -306,51 +294,52 ＠＠ follows: ＠enumerate - ＠item -Keep the code small and fast +Keep the C code fast. ＠item -Refrain from adding lots of code to the codebase that would be better -served with hooks. +Refrain from adding lots of code to the C codebase that would be better +served with Lisp. ＠item -In order to provide maximum compatibility with other MH interfaces and -MH itself, XEmacs should use MH itself as much as possible. XEmacs is, -after all, a interface to MH and therefore should not implement MH. +XEmacs is a cross-platform application. Features should work on all +platforms. ＠item XEmacs should be easy to use out-of-the-box for new users. - ＠end enumerate -That last priority struggles mightily with the other priorities. For -example, the user ＠i{could} write his own hooks for many features. -However, the average user is not going to do so. Indeed, the -customization buffer may be too intimidating and providing radio -buttons and checkboxes in the menu may be the way to go in some cases. - ＠cindex customize +We should get as much mileage out of ＠code{customize} as we can to +reduce the amount of code that users have to write. + +XEmacs at any time has a ＠emph{stable} branch and uses the ＠emph{trunk} +for development. We do not freeze the trunk, except for the short +period of time needed to create a consistent release branch. The +release branch in principle should only be changed for bug fixes. (In +the past this principle has been honored as much in the breach as in the +observance; nevertheless, it's a good starting point.) + +A change in the major version number indicates a pervasive change +affecting all users. For example, the introduction of Mule in version +20, the extensive user of the package system in 21, and Unicode support +in 22. A change in the minor version number reflects addition of +features, and accompanies an initial public release. A change in the +patchlevel reflects bugfix releases of the stable branch, while on the +trunk patchlevels are fairly arbitrary, reflecting regular beta +releases. + +The stable branch has a single gatekeeper, the listed maintainer. +Changes are made only by the maintainer, or at his convenience with +explicit authorization. Any XEmacs reviewer may make or authorize +changes to the trunk. Having commit privileges does ＠emph{not} +authorize changes; commit privileges are for the convenience of the +project and of regular contributors, but do not imply a direct say in +decisions. Conversely, we are always looking for new reviewers; the +review board is self-maintaining, but not closed. -In a less contentious way, making XEmacs easier to use may mean better -integration with other software packages (such as ＠code{tm} or -＠code{goto-addr}). Or pre-written hook functions could be provided. We -should get as much mileage out of ＠code{customize} as we can to reduce -the amount of code that users have to write. - -One other subject related to philosophy is to what constitutes a major -release. Major releases signal to the user that the new version may -not work as it did before and that reading of the release notes is -mandatory. Major releases occur when incompatible changes are made -that are visible to the user. Types of changes include changing the -name of or deleting functions, key bindings, and customization -variables. The converse is true; these sorts of changes should not be -applied to minor releases. - -By itself, merely adding a new feature does not just justify a major -release. On the other hand, a major release is called for if the code -is completely rewritten, even if the user cannot notice any -difference. +Individual packages, like the stable branch, may have a listed +maintainer. In those cases, the listed maintainer is the gatekeeper. ＠heading Guiding Principles ＠＠ -358,9 +347,8 ＠＠＠enumerate 1 ＠item -While we all are scratching an itch on this project, we also have very -few users and a great desire to have more. Our users are sacrosanct; -we will go the extra distance to please our users. +We all are scratching an itch on this project. We respect each others' +goals, which are quite varies. ＠item Using vulgar language towards our users and/or developers is ＠＠ -370,10 +358,8 ＠＠ The team makes decisions by consensus through articulated arguments. If one wants to express an opinion, they do it by presenting evidence to support their claim in a respectful way, and not by insulting -others' points of view. While it takes some time and effort to -articulate the reasons behind one's point of view, we enjoy the -process and often gain a better understanding of the issues by the -end. +others' points of view. Where consensus seems hard to achieve, what we +try first may be decided by a vote in the Review Board. ＠item We are all committed to a high-quality product. We have no artificial ＠＠ -417,9 +403,16 ＠＠＠end ifhtml ＠strong{Please ensure that the copyright notice of every file accurately -reflects your contribution, whether you have assigned your copyright or -not. This will aid future project admins greatly if there ever is a -merger.} +reflects your contribution, whether you have assigned your copyright to +the FSF or not. This will aid future project admins greatly if there +ever is a merger of XEmacs with Emacs.} ``Accurately reflects'' means +that if you have not assigned your contribution, ＠emph{your name} should +appear in a copyright notice, along with an accurate list of the years +in which your contributions were made. If you have assigned your +contribution, you should list the FSF (or other assignee) as copyright +holder, and make sure that the list of years is appropriately updated. +In both cases, an accurate ChangeLog detailing your changes (file and +function) should accompany the patch. You ＠strong{must} reference the GPL correctly in every file. ＠＠ -427,17 +420,24 ＠＠ they have various different licenses. ＠emph{Be careful}: it is typically ＠strong{not} permissible to mix excerpts from different documents with each other, or with XEmacs code, unless they have -＠emph{identical} licenses. +＠emph{identical} licenses. In particular, the XEmacs Texinfo manuals +(the ＠emph{XEmacs User's Guide}, the ＠emph{XEmacs Lisp Reference}, and +the ＠emph{XEmacs Internals Manual}) have a unique license which is not +the GPL or the GFDL, and is incompatible with both. All code and data files must be licensed under the GPL (or a compatible license) so that they can be added to XEmacs, and others may modify them. Documentation files must be licensed under an approved free license or an OSI-approved open source license. Where possible, GPL-compatible -licenses are preferred. +licenses are preferred. If at all possible, avoid the GNU Free +Documentation License, because it ＠emph{is incompatible with the GPL}, +implying that text cannot be copied freely between docstrings and the +Texinfo manual, except by the copyright holder. The ＠uref{http://www.gnu.org/prep/standards.html, GNU -Coding Conventions} is required reading. +Coding Conventions} is required reading. Note that XEmacs has its own +slightly different, version. ＠xref{Top, Coding Standards, ,standards}. Before checking in files, load ＠file{lisp-mnt} into Emacs, and run ＠code{lm-verify} within the lisp file you are editing to ensure that ＠＠ -463,8 +463,6 ＠＠＠node The Work Roles, The Work Flow, Philosophy, Top ＠chapter The Work Roles -＠c Created: stephen 2005-01-20 - On the one hand, ``open source'' means that you are free to take the existing program, make it into whatever you want, and nobody will stop you. On the other hand, ``open source'' means that you are free to ＠＠ -475,7 +473,7 ＠＠ Allowing people to fill roles that suit them, and creating a work flow that lets them share the products of their work without getting in each -other's ways, are the foundations of the project. +others' way, are the foundations of the project. ＠heading People and the Project ＠＠ -533,24 +531,25 ＠＠＠item Reviewer A developer who may authorize developers, including himself, to write to the XEmacs CVS repository. ＠xref{XEmacs Reviewer}. Should participate -in ＠value{BETA-LIST} ＠ref{xemacs-beta}, ＠value{DESIGN-LIST} -＠ref{xemacs-design}, and ＠value{PATCHES-LIST} ＠ref{xemacs-patches}. +in ＠value{BETA-LIST} ＠ref{xemacs-beta}, ＠value{PATCHES-LIST} +＠ref{xemacs-patches}, and ＠value{REVIEW-LIST} +＠ref{xemacs-review}. ＠item XEmacs Review Board The reviewers as a group, responsible for delegating access to ＠value{PROJECT} resources to developers. A self-selecting cabal. The current members are noted on the -＠uref{http://www.xemacs.org/Develop/jobs.html,＠emph{Job List}}. +＠uref{http://www.xemacs.org/Develop/jobs.html,＠emph{Jobs List}}. ＠xref{Jobs List}. ＠item Chairman of the Board -＠item CEO -＠item Maintainer -＠item Benevolent Dictator for Life +＠itemx CEO +＠itemx Maintainer +＠itemx Benevolent Dictator for Life Call it what you like, we don't have one any more, by deliberate choice. ＠item Meta-maintainer -＠item Mr. XEmacs +＠itemx Mr. XEmacs The reviewer responsible for trying to keep track of what isn't getting done, and finding someone to do it. The latter title allows him to tell his mother how important he is. More seriously, the meta-maintainer ＠＠ -559,8 +558,8 ＠＠＠value{BETA-LIST} ＠ref{xemacs-beta}. ＠item Release engineer -＠item Stable release engineer -＠item Package release engineer +＠itemx Stable release engineer +＠itemx Package release engineer Responsible for the quality control and adminstrative details of distributing some coherent package of functionality. The ＠dfn{stable release engineer} manages the core distribution, including the build ＠＠ -573,8 +572,8 ＠＠＠c #### Write nodes for these posts! ＠item Postmaster -＠item Webmaster -＠item CVS Manager +＠itemx Webmaster +＠itemx CVS Manager Administrators of the various Internet-based services important to XEmacs users and developers. ＠c #### Write nodes for these posts! ＠＠ -620,10 +619,10 ＠＠ give the community information about the variety of platforms and features XEmacs is being configured for. Bug reports are submitted to ＠value{BETA-LIST}, preferably via ＠kbd{M-x report-xemacs-bug RET}. +＠value{BETA-LIST} is also the channel to lobby for their favorite new +features. Build reports are submitted to ＠value{BUILDREPORTS-LIST} -via the ＠kbd{M-x build-report RET} utility. Testers may -also wish to subscribe to ＠value{DESIGN-LIST}, to lobby for -their favorite new features. +via the ＠kbd{M-x build-report RET} utility. However, for those who do wish to make contributions to the collection of bytes that we call ``XEmacs'', there are a number of formal roles, ＠＠ -637,10 +636,14 ＠＠＠cindex committer ＠c MH-E says that committers may be _assigned_ bugs + A ＠dfn{committer} is one who is authorized to check in approved changes into the CVS repository, including changes to private branches they may -maintain. Developers who do not have CVS access contribute by -submitting patches to ＠value{PATCHES-LIST}. +maintain. Note that, in contrast to the use of this term on many +projects, being a committer is simply an administrative convenience; +committers must wait for approval to check in changes. +Developers who do not have CVS access contribute by submitting patches +to ＠value{PATCHES-LIST}. Commit access is generally given to those who have submitted several good patches, to ``well-known'' developers on request, and to XEmacs ＠＠ -656,8 +659,6 ＠＠＠node Commit Access, Committer Welcome Message, Committer, Committer ＠subsection Commit Access -＠c Edited: stephen 2005-01-18 - ＠cindex commit access ＠cindex cvs.xemacs.org committer accounts ＠＠ -771,8 +772,8 ＠＠ Which will get just the redtape package. You can get all the packages with the module name "packages". I'd strongly suggest that you get the whole packages tree as usually packages require some functionality from -other packages. But be warned, the packages tree is quite big (80+ MB -as of 11/2002). +other packages. But be warned, the packages tree is quite big (120+ MB +as of 2007/02). Committing patches to CVS: ------------------------- ＠＠ -913,6 +914,271 ＠＠ Of course the package maintainer does have control over the decision to release. +＠menu +* The Package Maintainer Role:: +* Getting Started as a Package Maintainer:: +* Advice to Package Maintainers:: +＠end menu + + + +＠node The Package Maintainer Role, Advice to Package Maintainers, , XEmacs Package Maintainer +＠subsection The Package Maintainer Role + +The ＠dfn{package maintainer} is basically a liaison between two +communities: the XEmacs developers, and the users of the package, who +will typically not be Lisp programmers, and perhaps not programmers at +all. Because the package maintainer represents the interest of a +community which often is not otherwise active in XEmacs development, he +is the ultimate authority on what goes into the package. Probably he +will extremely rarely wish to oppose changes made by members of the +Review Board (who have the authority to review and approve changes to +any part of XEmacs). However, he should feel free to make any changes +he thinks useful for his package; he does not need to ask anyone's +permission, and may approve or veto submissions by other users, and +incorporate them in -modesthe package as he sees fit. + +The responsibility accepted is simply to pay attention to the package. +The package maintainer should stay on top of progress in the upstream +versions of the libraries in the package, and should subscribe to the +XEmacs Beta and XEmacs Patches mailing lists to watch for bug reports +and patches relevant to it. + +We also hope and expect that the package maintainer will take part in +updating and improving the package, but we don't expect him to be a +coding wizard. It's possible to be a package maintainer even with +very little knowledge of the code. One can always ask for advice on +XEmacs Beta, or directly of experts on whatever the problem area is. +The roles of the package maintainer and of the core team are +complementary: the package maintainer stays in contact with his +community and finds out what the needs are; the core team provides +advice, information about how XEmacs works, and often patches and +documentation. + + + +＠node Getting Started as a Package Maintainer, Advice to Package Maintainers, The Package Maintainer Role, XEmacs Package Maintainer +＠subsection Getting Started as a Package Maintainer + +The first step is to check out the package from CVS in +read-write mode. This is done as follows: + +＠example +export CVSROOT=:ext:xemacs＠cvs.xemacs.org:/pack/xemacscvs +export CVS_RSH=/usr/bin/ssh +cvs checkout packages +＠end example + +This will take a while, and about 120MB of space. It's possible to do +without most of the packages (for example, most modes can delete all of +the mule-packages subtree), but the Lisp programming language makes it +very easy to call functions in one package from another, and +interdependencies are frequent. Unless one is really really tight for +space, it's best to start by just checking out the whole thing, and +prune it back later. + +The package developer is welcome to change anything in the subtree that +contains the package. However, there are a couple of administrative +files that are conceptually the "property" of the package system. These +are ＠file{package-info.in} and the ＠file{Makefile}. There is almost +surely no need to change either at this time, except to change the +＠samp{MAINTAINER} variable in the ＠file{Makefile} to contain the +maintainer's name and email address. The package maintainer should +never change the ＠samp{VERSION} variable; that is automatically +maintained by the package release engineer (currently Norbert Koch) who +does the releases of new versions of packages. You should keep the +＠samp{AUTHOR_VERSION} variable in sync with upstream, if that makes +sense. It may be possible and convenient to have ＠code{AUTHOR_VERSION +== VERSION}; ask the package release engineer about it if that seems +attractive. + +So now you can (with the above environment settings) + +＠example +cd packages/xemacs-packages/＠var{package_name} +xemacs Makefile +# change MAINTAINER to your name and address +# make a patch with cvs diff > my.patch and send it to XEmacs Patches +cvs commit -m "Update MAINTAINER name and address." Makefile +＠end example + +which is a good test that everything is working. You can find out +more about CVS and the XEmacs repository at ＠url{http://cvs.xemacs.org}. + +Many maintainers who have a separate repository for the upstream project +do not send patches, but simply announce a synch to upstream. However, +at least at first it is advisable to send patches, so that other +developers can give you advice. + +The next step is to copy the ＠file{packages/Local.rules.template} file +to ＠file{packages/Local.rules}, and edit it to fit your environment. +The main things are to make sure that the ＠samp{XEMACS} variable points +to the appropriate XEmacs binary, and that the ＠samp{STAGING} directory +is set to something useful. Now you can build a test package by simply +typing ＠kbd{make bindist}. + +Then copy the updated upstream files over the existing ones. Try +making a package with make bindist. Use the new code, too, to see if +you find any bugs. If not, you can commit the new files to CVS. + +When you make a commit, you should notify the package release engineer, +currently ＠email{viteno＠(a)xemacs.org,Norbert Koch}, about your +intentions. Norbert is pretty aggressive about making new packages and +putting them up for download. If you don't want that after a given +change, you should tell him so. (This advice may or may not apply to +the next release engineer.) + +For internal communication purposes, we make aliases for the maintainer +and the package ＠samp{＠(a)xemacs.org}. The package maintainer addresses are + +＠example +＠var{firstname.lastname}＠(a)xemacs.org +＠var{cvsuser}＠(a)xemacs.org +＠end example + +You can use these publically as you see fit, or not. The package +addresses are + +＠example +＠var{package}-bugs＠(a)xemacs.org +＠var{package}-discuss＠(a)xemacs.org +＠var{package}-patches＠(a)xemacs.org +＠var{package}-maintainer＠(a)xemacs.org +＠end example + +The last alias is set to the maintainer address. The ＠samp{bugs-} and +＠samp{discuss-} aliases are redirected to XEmacs Beta, and the +＠samp{patches-} address to the XEmacs Patch forum. You can ask that +these be changed at any time, for example if you prefer to get mail +about the XEmacs package in upstream project channels rather than XEmacs +channels. + + + +＠node Advice to Package Maintainers, , Getting Started as a Package Maintainer, XEmacs Package Maintainer +＠subsection Advice to Package Maintainers + +This section contains some as yet unorganized advice to package +maintainers, especially those who are coming from a community which uses +XEmacs but normally develops in a language other than Lisp. +(a)emph{I.e.}, the maintainer of an editor mode. + +＠heading Setting Up to Build Your Package + +Building a package almost always requires the presence of the +＠emph{source code} for other packages. Almost all packages depend on +the ＠file{xemacs-base} package, for example. Therefore the recommended +procedure is to check out the whole package tree, configure +(a)file{Local.rules}, and do a full build with ＠kbd{make} from the top. +(After that you should keep the tree up-to-date with ＠kbd{cvs update +-dP} and occasionally do a ＠kbd{make} to keep things in order.) Having +done this once, you can thereafter normally simply do ＠kbd{make} and +＠kbd{make bindist} in your package's top directory. + +We know this is annoying, but disk space is cheap, and the requirement +for a full build is a one-time thing. After that, you can just do make +bindist in your package's directory. Suggestions for improvement of the +process ＠emph{are} welcome, but they must account for the need to +provide macro definitions and autoloads. + +＠heading Lisp macros and autoloads + +Lisp provides ＠dfn{macros}, which involve ＠dfn{expansion}, which means +evaluating a Lisp expression which constructs a new Lisp expression. +When a macro is invoked by the interpreter, the second expression is +then ＠dfn{applied} to the actual arguments to give the actual result. + +This separation of expansion from application means that expansion can +take place without knowing the actual arguments. The most important +example is at compile time. As a design principle, ＠emph{compiled code +cannot expand macros} (because it's unnecessary and inefficient), so you +must have all definitions of macros used available at compile time. The +somewhat similar ＠dfn{defsubst} is like C ＠samp{inline}; it's advice to +the compiler, but the function can be called in the usual way. So +although it's not strictly necessary, it's desirable for efficiency that +defsubst definitions be available to the compiler. + +Since Lisp is very dynamic, it's possible to for code to call functions +that haven't been defined yet, as long as the call isn't evaluated until +after the function definition is loaded. The ＠dfn{autoload} facility +allows definitions to be loaded the first time they are used. + +＠heading Application to the XEmacs package infrastructure + +When a package is built, of course its Lisp libraries are compiled. To +ensure that necessary definitions are available, the libraries of the +packages named in the ＠samp{REQUIRES} Make variable are required, and +the autoload definitions are loaded from generated libraries called +＠file{auto-autoloads} in each package. + +So you should at least do ＠kbd{make autoloads} from the top of the +package tree. (It should be possible to do a more minimal set of +auto-autoloads, just the ones that your package and packages it depends +on use, but there's no automatic way to compute that set.) + +Since the compile process involves expanding macros, which is executing +package code, it will speed up the build process for your package to do +a full "make" from the top. The speedup may or may not be measurable, +since make itself and simply starting XEmacs to do the compilation are +pretty time-consuming. + +＠heading For the future + +Some attempts have been made to track the dependencies on macros and +autoloads, but the problem turns out to be fairly hard because it's +possible to dynamically compute the names of functions to call, and +things like that. Thus a program to analyze dependencies must +actually understand Lisp semantics. We've found it most reliable to +just build the packages, and set up dependencies when errors +occur. + +＠heading Getting Help with Your Package + +If you want advice on the code itself, just post it to XEmacs Patches, +which is basically designed to put new code that is believed to be ready +to be committed in front of the reviewers. Since you're the maintainer, +you should mention explicitly that you want review. Otherwise people +will assume you know what you're doing, even though you know you +don't. + +If you're more interested in whether it's a good idea or people will use +it, then post to XEmacs Beta, where a lot more people will see it. +Alternatively you may want to post to package-specific channels, either +an upstream project or the channels devoted to the language it +manipulates. To the extent that fixes have been submitted by the +community, this fits into the latter case, and you only need to consult +XEmacs channels if they don't work as expected. + +Finally, if it's a little of both, you can cross-post. This is useful +in cases where you know you want to commit this patch but you want +advice on what needs to be done next. + +＠heading Learning About Emacs Lisp + +In this case posting to XEmacs Beta and/or comp.emacs.xemacs is best, +because there are many competent Lisp hackers who are not core +developers. In many cases, for example, font lock and indentation, this +is probably not so much "learning Lisp" as "learning how Emacsen do font +lock and indentation". Still, these are skills that are quite common +outside of the core developer group. + +Many of the editor features are (unfortunately) relatively +fork-specific. Emacs and XEmacs do them somewhat differently, +especially font-lock. Nevertheless, you may also get some help on +channels like comp.emacs and gnu.emacs.help. (Not +＠samp{emacs-devel＠(a)gnu.org}, please; XEmacs-specific stuff is off-topic +there, and even individual gurus won't be able to help much, since +XEmacs code has diverged substantially. + +For Emacs Lisp itself, there's some tutorial material in +＠ref{Top,the XEmacs Lisp Reference manual, , lispref}, and GNU +distributes an Emacs Lisp tutorial. However, the GNU tutorial is really +more of a generic Lisp tutorial, with a few examples drawn from the +Emacs domain. The Lisp Reference is pretty well organized; if you have +trouble finding references to what you need to do, or don't understand +what it says, feel free to report it as a bug. It's not always possible +to improve it, but it's always worth trying! + ＠node XEmacs Reviewer, Meta-Maintainer, XEmacs Package Maintainer, The Work Roles ＠＠ -962,7 +1228,6 ＠＠＠node Appointing New Reviewers, Welcoming New Reviewers, XEmacs Reviewer, XEmacs Reviewer ＠subsection Appointing New Reviewers -＠c Created: stephen 2005-01-19 ＠strong{This node needs improvement!!} ＠cindex ＠value{BOARD} ＠＠ -1176,7 +1441,10 ＠＠ including such things as ensuring that generated files are committed to CVS, tagging CVS, updating release documentation, creating and uploading tarballs, and making announcements. Release engineers are ＠emph{ex -oficio} members of the XEmacs Review Board. +oficio} members of the XEmacs Review Board. That is, if you are willing +to accept the responsibility of release engineering, and the Board is +willing to accept you, you will be appointed as Reviewer if you aren't +already. ＠c #### MAKE A SEPARATE NODE CORRESPONDING TO jobs.html, AND FIGURE OUT ＠c HOW TO AUTOMAGICALLY UPDATE AND PUBLISH IT AS jobs.html. ＠＠ -1203,7 +1471,6 ＠＠＠node The Work Flow, XEmacs Resources on the Internet, The Work Roles, Top ＠chapter The Work Flow -＠c Created: stephen 2005-01-20 This section is a description of current best practices, rather than an attempt to define a standard. ＠＠ -1215,8 +1482,10 ＠＠＠table ＠emph ＠item Get the sources. -XEmacs is distributed with source, but CVS simplifies management of your -improvements. +＠value{PROJECT} tarballs are always distributed as source (except in +the case of the Windows installer), but CVS simplifies management of +your improvements. (Third-party vendors such as *nix distributions and +Cygwin may distribute binary packages, but XEmacs no longer does.) ＠item Write low-profile code. Don't distract your users or colleagues from their work. Just make it ＠＠ -1230,11 +1499,14 ＠＠＠item Create the patch. Dot the i's, cross the t's. Make sure that it's easy to add to the code -base. +base. The best way is by using ＠code{cvs diff -uN} against the tip of +the branch or trunk you intend to have the patch applied to. The +exception is ChangeLog patches, which may be generated using ＠code{cvs +diff -U 0 ChangeLog}, or submitted as plain test. ＠item Submit the patch. -Compose the message so it's easy to find, easy to identify, easy to -review, and easy to apply. +Compose the message, especially the Subject: header, so it's easy to +find, easy to identify, easy to review, and easy to apply. ＠item Review the patch. The primary function of the ＠value{BOARD} is to help you improve your ＠＠ -1281,17 +1553,19 ＠＠ the FSF (or other free software trust), which is required by its covenants of incorporation to actively defend free software it holds. You may also wish to respect the wishes of Richard Stallman, the first -author and still major contributor to the development of Emacs. +author and current maintainer of Emacs. Finally, you may wish to support the FSF's advocacy of free software by assigning your copyright to the FSF. At the present time, the ＠value{PROJECT} neither advocates nor discourages this action; it's up to you. -Also, be aware that at the time of writing, January 2005, -Richard Stallman had recently denied that such assignments would +Also, be aware that in January 2005 +Richard Stallman explicitly denied that such assignments would facilitate adoption of XEmacs code by GNU Emacs; if you want your code to be used in GNU Emacs, you will have to resubmit it directly to the -GNU Emacs project. +GNU Emacs project. (The assignment is acceptable for use in Emacs, but +Emacs developers are not allowed to port others' code from XEmacs to GNU +Emacs, even if it's assigned; the original developer must do that.) Get more information about procedures from the ＠email{emacs-devel＠(a)gnu.org,GNU Emacs developers' mailing list} or from ＠＠ -1305,7 +1579,6 ＠＠＠node Scratching That Itch, Get the Sources, About Copyright Assignment, The Work Flow ＠section Scratching That Itch -＠c Edited: stephen 2005-01-18 ＠c #### needs revision As always in free software, a patch starts life when some developer ＠＠ -1319,7 +1592,8 ＠＠＠node Get the Sources, Write Low-Profile Code, Scratching That Itch, The Work Flow ＠section Get the Sources -Maybe he's never worked on XEmacs before. In that case, he'll need to +Maybe the developer has never worked on XEmacs before. In that case, +he'll need to check out the ＠samp{xemacs} module from the CVS repository ＠ref{CVS Repository}. True, he may already have the whole package because he built from source after downloading a tarball. However, tarballs often ＠＠ -1327,7 +1601,7 ＠＠ maintainer off like a patch that doesn't apply because it was generated against an old version. Furthermore, the developer needs to keep track of the original file in order to generate a correct patch, which can be -quite difficult if you go through several iterations woring on a complex +quite difficult if you go through several iterations working on a complex issue. It's true that CVS has problems in advanced usage, but for these simple housekeeping tasks it works very well. Use CVS. ＠＠ -1407,8 +1681,7 ＠＠＠node Add a ChangeLog Entry, Create the Patch, Test Your Changes, The Work Flow ＠section Add a ChangeLog Entry -＠c Created: stephen 2005-01-21 -＠strong{Needs revision!!} +＠strong{Needs review!!} Add a log entry to ＠file{ChangeLog} file in the ancestor directory closest to each changed file. ＠＠ -1421,8 +1694,6 ＠＠＠node ChangeLogs, Log Messages, Add a ChangeLog Entry, Add a ChangeLog Entry ＠subsection ChangeLogs -＠c Edited: stephen 2005-01-18 - ＠strong{This section is pretty close to correct for XEmacs. Needs review.} ＠cindex ChangeLog ＠＠ -1472,6 +1743,12 ＠＠ 4 a} (＠code{add-change-log-entry-other-window}) which inserts this text for you (even from a diff!), please do follow its conventions. +Note that the date, the full name, and the email address are separated +by pairs of ASCII spaces, the date is in YYYY-MM-DD format, and the +email address enclosed in angle brackets. The leading space in the log +entries is encoded as an ASCII TAB, not as 8 spaces. These formatting +rules are mandatory, because ChangeLog modes depend on these heuristics. + Multiple targets with the same text may appear in the same entry. ＠cindex Debian ＠＠ -1498,8 +1775,6 ＠＠＠node Log Messages, , ChangeLogs, Add a ChangeLog Entry ＠subsection Log Messages -＠c Edited: stephen 2005-01-18 - ＠strong{This section, written by Bill Wohler for MH-E and lightly edited to substitute ``XEmacs'' for ``MH-E'', is pretty close to correct for XEmacs, at least in the case of implicit self-approval. Needs review.} ＠＠ -1554,7 +1829,7 ＠＠ (The following lines describe the current patch creation standard for developers without commit access, committers, and reviewers alike. An -optional alternative procedure for ＠emph{reviewers only} is likely to be +optional alternative procedure for ＠emph{reviewers only} was adopted in first quarter 2005.) Patches should be created using a standard diff(1) such as provided by ＠＠ -1593,7 +1868,7 ＠＠ (The following lines describe the current patch submission procedure for developers without commit access, committers, and reviewers alike. An -optional alternative procedure for ＠emph{reviewers only} is likely to be +optional alternative procedure for ＠emph{reviewers only} was adopted in first quarter 2005.) Send the patch by email to ＠value{PATCHES-LIST}. The subject line ＠＠ -1654,13 +1929,13 ＠＠ commit the changes to CVS as appropriate. ＠menu -* Proposed Optional Alternate Procedure for Reviewers:: +* Optional Alternate Procedure for Reviewers:: ＠end menu -＠node Proposed Optional Alternate Procedure for Reviewers, , Submit the Patch, Submit the Patch -＠subsection Proposed Optional Alternate Procedure for Reviewers +＠node Optional Alternate Procedure for Reviewers, , Submit the Patch, Submit the Patch +＠subsection Optional Alternate Procedure for Reviewers Patches that are self-approved by a reviewer, and are either expected to be non-controversial or are part of a project that has the general ＠＠ -1670,8 +1945,9 ＠＠＠value{PATCHES-LIST}. This may be referred to as ＠dfn{implicit self-approval}. -＠strong{This procedure is not yet in effect, and the commit-trigger has -not yet been implemented at the time of writing. (2005-01-20)} +＠strong{The commit-trigger has +not yet been implemented at the time of writing. For this reason +implicit self-approvals should still be avoided. (2007-05-13)} ＠＠ -1684,7 +1960,7 ＠＠ (The following lines describe the current patch submission procedure for developers without commit access and committers. Reviewers may optionally use ``commit-and-review,'' described later. Another optional -alternative procedure for ＠emph{reviewers only} is likely to be adopted +alternative procedure for ＠emph{reviewers only} was adopted in first quarter 2005. Called ``implicit self-approval,'' it was described in the previous section.) ＠＠ -1712,7 +1988,7 ＠＠＠item REVISE The reviewer is demanding certain revisions, or the patch will be -vetoed. May be obsolete; current practice seems to favor use of +vetoed. May be obsolete; current practice strongly favors use of ＠strong{QUERY} both for required revisions and for further discussion, and there seems to be little need to distinguish these cases. ＠＠ -1898,10 +2174,9 ＠＠ -＠node XEmacs Resources on the Internet, Support Requests, The Work Flow, Top +＠node XEmacs Resources on the Internet, Copying, The Work Flow, Top ＠chapter XEmacs Resources on the Internet -＠c Edited: stephen 2005-01-18 ＠strong{Write this node! Get mailing list and newsgroup information from the ＠uref{http://www.xemacs.org/Lists/, mailing list page}, available as the module ＠emph{xemacsweb} ＠ref{CVS Repository}. ＠＠ -1926,8 +2201,6 ＠＠＠node Project Website, CVS Repository, XEmacs Resources on the Internet, XEmacs Resources on the Internet ＠section Project Website -＠c Edited: stephen 2005-01-18 - ＠strong{Needs review. Adrian?} ＠cindex Project Website ＠＠ -1949,8 +2222,6 ＠＠＠node CVS Repository, comp.emacs.xemacs, Project Website, XEmacs Resources on the Internet ＠section CVS Repository -＠c Edited: stephen 2005-01-18 - ＠cindex CVS Repository ＠c #### update the specific links for convenience!! ＠＠ -1978,10 +2249,13 ＠＠＠node xemacs-design, xemacs-patches, xemacs-beta, XEmacs Resources on the Internet ＠section The xemacs-design Mailing List -＠strong{Write me!} +This list is currently inactive. Traffic that used to go to +＠value{DESIGN-LIST} should be directed to ＠value{BETA-LIST} instead. +＠strong{Concerning content, write me!} + ＠node xemacs-patches, xemacs-mule, xemacs-design, XEmacs Resources on the Internet ＠section The xemacs-patches Mailing List ＠＠ -2003,203 +2277,613 ＠＠ -＠c ########################################################################## -＠c #### I haven't seriously worked on the following material. -- stephen #### -＠c ########################################################################## +＠node Copying, Nodes borrowed from other projects not adapted to XEmacs, XEmacs Resources on the Internet, Top +＠appendix GNU GENERAL PUBLIC LICENSE +＠center Version 2, June 1991 -＠node Support Requests, Bugs, XEmacs Resources on the Internet, Top -＠chapter Support Requests +＠display +Copyright ＠copyright{} 1989, 1991 Free Software Foundation, Inc. +59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -＠cindex Support Requests +Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +＠end display -Support requests are made to ＠value{BETA-LIST}. Developers should read -the mailing list frequently, and after a period of inactivity, browse -the ＠uref{http://list-archive.xemacs.org/xemacs-beta/,recent archives}. +＠appendixsec Preamble + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software---to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. -＠node Bugs, Feature Requests, Support Requests, Top -＠chapter Bugs + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. -＠c Edited: stephen 2005-01-18 + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. -＠strong{We don't have a tracker. We should. Describe what it should -look like here.} + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. -＠cindex Bugs -＠cindex priority -＠cindex bugs, priority + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. -Bug reports, feature requests, and discussions that are expected to lead -to bug reports or feature requests are created in -＠uref{https://sourceforge.net/bugs/?group_id=13357, Bugs}. Most -bugs should be set to a priority of 5. + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. -＠cindex bug-gnu-emacs -＠cindex Debian + The precise terms and conditions for copying, distribution and +modification follow. -Developers should follow the ＠i{bug-gnu-emacs} mailing lists/newsgroup -and move bug reports into Bugs if it has not been done already. -Similarly, XEmacs bugs reported in other systems should be transfered to -＠value{XEMACSORG}. The bug may be cut and pasted into a new bug report, or a -URL to the source of the original bug report may be all that appears -in the bug report. +＠iftex +＠appendixsec TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION +＠end iftex +＠ifinfo +＠center TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION +＠end ifinfo -A brief lifecycle of a bug proceeds something like this. A bug is -entered. A developer ensures that the Category, Priority and Group are -correct. The Group for an Open bug should be set to the version of -software in which the bug was found, or CVS if it was found in the -latest and greatest. +＠enumerate 0 +＠item +This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The ``Program,'' below, +refers to any such program or work, and a ``work based on the Program'' +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term ``modification.'') Each licensee is addressed as ``you.'' -The assignment of bugs in Bugs follows the honor system. If you see an -open bug that you think you could handle, assign the bug to yourself. -Bugs that remain open should be reviewed by a member of the -＠value{BOARD}, who should try to find a developer to work on the bug. +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. -If you fix a bug, set the resolution to Fixed and group to CVS. Please -also assign the bug to yourself if you have not done so already, so -you get credit in the -＠uref{https://sourceforge.net/tracker/reporting/?atid=113357&what=tech&span=&period=lifespan&group_id=13357#b, -reports}. If a documentation change is not required, set the status to -Closed. If a documentation change is required, set the category to -Documentation, and assign the bug to the documentation tsar, -leave the status Open, and set the priority to 3 to set it -aside in listings sorted by priority. +＠item +You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. -See ＠ref{File Releases} for a motivation of why this process is useful. +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. -The rest of this section describes the categories and groups that have -been set up for the XEmacs project. +＠item +You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: -＠menu -* Category:: -* Status:: -* Group:: -* Resolution:: -＠end menu +＠enumerate a +＠item +You must cause the modified files to carry prominent notices +stating that you changed the files and the date of any change. -＠node Category, Status, Bugs, Bugs -＠section Category +＠item +You must cause any work that you distribute or publish, that in +whole or in part contains or is derived from the Program or any +part thereof, to be licensed as a whole at no charge to all third +parties under the terms of this License. -＠cindex category -＠cindex bug category +＠item +If the modified program normally reads commands interactively +when run, you must cause it, when started running for such +interactive use in the most ordinary way, to print or display an +announcement including an appropriate copyright notice and a +notice that there is no warranty (or else, saying that you provide +a warranty) and that users may redistribute the program under +these conditions, and telling the user how to view a copy of this +License. (Exception: if the Program itself is interactive but +does not normally print such an announcement, your work based on +the Program is not required to print an announcement.) +＠end enumerate -Several categories have been created for the XEmacs project organized by -function. They include ＠i{General}, ＠i{UI}, ＠i{MIME}, ＠i{Security}, -＠i{Documentation}, and ＠i{Contrib} +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. -＠table ＠b +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. -＠item General +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. -＠cindex general bug category -＠cindex bug categories, general +＠item +You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: -The ＠dfn{General} category is used for bugs that do not belong in any of -the other categories. +＠enumerate a +＠item +Accompany it with the complete corresponding machine-readable +source code, which must be distributed under the terms of Sections +1 and 2 above on a medium customarily used for software interchange; or, -＠item UI - -＠cindex UI bug category -＠cindex bug categories, UI +＠item +Accompany it with a written offer, valid for at least three +years, to give any third party, for a charge no more than your +cost of physically performing source distribution, a complete +machine-readable copy of the corresponding source code, to be +distributed under the terms of Sections 1 and 2 above on a medium +customarily used for software interchange; or, -The ＠dfn{UI} category is used for bugs in the software that the user sees -such as font-lock, key definitions, menus, and customization. +＠item +Accompany it with the information you received as to the offer +to distribute corresponding source code. (This alternative is +allowed only for noncommercial distribution and only if you +received the program in object code or executable form with such +an offer, in accord with Subsection b above.) +＠end enumerate -＠item MIME +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. -＠cindex MIME bug category -＠cindex bug categories, MIME +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. -The ＠dfn{MIME} category is used for bugs that pertain to MIME. +＠item +You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. -＠item Security +＠item +You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. -＠cindex security bug category -＠cindex bug categories, security +＠item +Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. -The ＠dfn{Security} category is used for bugs in the security arena. At -present, XEmacs does not include any security code, so this category might -be used for PGP interaction. +＠item +If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. -＠item Documentation +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. -＠cindex documentation bug category -＠cindex bug categories, documentation +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. -The ＠dfn{Documentation} category is used for bugs in the documentation -arena. In addition, if there are any code changes made as a result of a -bug report or feature request that require changes to the documentation, -the category of that issue should be set to Documentation after the bug -has been fixed or the feature implemented. Assign the issue to -＠i{wohler} for editing and/or writing of the documentation, and set -the priority to 3 to set the issue aside in listings sorted by priority. +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. -＠item Contrib +＠item +If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. -＠cindex contrib bug category -＠cindex bug categories, contrib +＠item +The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. -The ＠dfn{Contrib} category is used for all bugs in the contributed -software. +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and ``any +later version,'' you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. -＠end table +＠item +If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. -＠node Status, Group, Category, Bugs -＠section Status +＠iftex +＠heading NO WARRANTY +＠end iftex +＠ifinfo +＠center NO WARRANTY +＠end ifinfo -＠cindex status -＠cindex bug status +＠item +BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW＠. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM ``AS IS'' WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE＠. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU＠. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. -The bug ＠dfn{status} is divided into four sections: ＠i{Open}, -＠i{Closed}, ＠i{Deleted} and ＠i{Pending}. +＠item +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. +＠end enumerate -＠table ＠b +＠iftex +＠heading END OF TERMS AND CONDITIONS +＠end iftex +＠ifinfo +＠center END OF TERMS AND CONDITIONS +＠end ifinfo -＠item Open +＠page +＠appendixsec How to Apply These Terms to Your New Programs -＠cindex open bug status -＠cindex bug status, open + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. -When bugs are initially created, they are marked ＠dfn{Open}. + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the ``copyright'' line and a pointer to where the full notice is found. -＠cindex discussing bugs -＠cindex bugs, discussing -＠cindex features, discussing +＠smallexample +＠var{one line to give the program's name and an idea of what it does.} +Copyright (C) 19＠var{yy} ＠var{name of author} -The Bugs and Feature Requests sections are also used as a method to -get the ball rolling among developers. They are used to register what -we feel we should work on. For example, a developer may have questions -about the way XEmacs handles MIME that we should discuss before we -attempt to fix it: What do other people do? How should we attack this? -That developer opens a bug report in the MIME category and a -discussion ensues. Once the disposition of the issue is resolved, the -bug is assigned to a developer. Later, when the bug is fixed, the bug -can be closed. +This program 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 2 +of the License, or (at your option) any later version. -Discussion about entirely new features should be opened in the Feature -Requests section (＠pxref{Feature Requests}) but otherwise handled in -the same way. +This program 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. -＠item Closed +You should have received a copy of the GNU General Public License along +with this program; if not, write to the Free Software Foundation, Inc., +59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. +＠end smallexample -＠cindex closed bug status -＠cindex bug status, closed +Also add information on how to contact you by electronic and paper mail. -When all aspects of a bug have been fixed, including code and -documentation, the bug is marked ＠dfn{Closed}. +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: -When setting the status to Closed, the group should be set to Fixed, -Works For Me, Invalid, or Rejected. +＠smallexample +Gnomovision version 69, Copyright (C) 20＠var{yy} ＠var{name of author} +Gnomovision comes with ABSOLUTELY NO WARRANTY; for details +type `show w'. This is free software, and you are welcome +to redistribute it under certain conditions; type `show c' +for details. +＠end smallexample -＠item Pending +The hypothetical commands ＠samp{show w} and ＠samp{show c} should show +the appropriate parts of the General Public License. Of course, the +commands you use may be called something other than ＠samp{show w} and +＠samp{show c}; they could even be mouse-clicks or menu items---whatever +suits your program. -＠cindex pending bug status -＠cindex bug status, pending +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a ``copyright disclaimer'' for the program, if +necessary. Here is a sample; alter the names: -You can set the status to ＠dfn{Pending} if you are waiting for a -response from the tracker item author. When the author responds, the -status is automatically reset to that of Open. Otherwise, if the +＠smallexample +＠group +Yoyodyne, Inc., hereby disclaims all copyright +interest in the program `Gnomovision' +(which makes passes at compilers) written +by James Hacker. + +＠var{signature of Ty Coon}, 1 April 1989 +Ty Coon, President of Vice +＠end group +＠end smallexample + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. + + +＠node Nodes borrowed from other projects not adapted to XEmacs, Index, Copying, Top +＠appendix Nodes borrowed from other projects not adapted to XEmacs + +＠c ######################################################################### +＠c #### I haven't seriously worked on the included material. -- stephen #### +＠c ######################################################################### + +＠menu +* Support Requests:: +* Bugs:: +* Feature Requests:: +* Patch Queue:: +* File Releases:: +* News:: +* Surveys:: +* Free Software Directories:: +＠end menu + + +＠node Support Requests, Bugs, , Top +＠chapter Support Requests + +＠cindex Support Requests + +Support requests are made to ＠value{BETA-LIST}. Developers should read +the mailing list frequently, and after a period of inactivity, browse +the ＠uref{http://list-archive.xemacs.org/xemacs-beta/,recent archives}. + + + +＠node Bugs, Feature Requests, Support Requests, Top +＠chapter Bugs + +＠strong{We don't have a tracker. We should. Describe what it should +look like here.} + +＠cindex Bugs +＠cindex priority +＠cindex bugs, priority + +Bug reports, feature requests, and discussions that are expected to lead +to bug reports or feature requests are created in +＠uref{https://sourceforge.net/bugs/?group_id=13357, Bugs}. Most +bugs should be set to a priority of 5. + +＠cindex bug-gnu-emacs +＠cindex Debian + +Developers should follow the ＠i{bug-gnu-emacs} mailing lists/newsgroup +and move bug reports into Bugs if it has not been done already. +Similarly, XEmacs bugs reported in other systems should be transfered to +＠value{XEMACSORG}. The bug may be cut and pasted into a new bug report, or a +URL to the source of the original bug report may be all that appears +in the bug report. + +A brief lifecycle of a bug proceeds something like this. A bug is +entered. A developer ensures that the Category, Priority and Group are +correct. The Group for an Open bug should be set to the version of +software in which the bug was found, or CVS if it was found in the +latest and greatest. + +The assignment of bugs in Bugs follows the honor system. If you see an +open bug that you think you could handle, assign the bug to yourself. +Bugs that remain open should be reviewed by a member of the +＠value{BOARD}, who should try to find a developer to work on the bug. + +If you fix a bug, set the resolution to Fixed and group to CVS. Please +also assign the bug to yourself if you have not done so already, so +you get credit in the +＠uref{https://sourceforge.net/tracker/reporting/?atid=113357&what=tech&span=&period=lifespan&group_id=13357#b, +reports}. If a documentation change is not required, set the status to +Closed. If a documentation change is required, set the category to +Documentation, and assign the bug to the documentation tsar, +leave the status Open, and set the priority to 3 to set it +aside in listings sorted by priority. + +See ＠ref{File Releases} for a motivation of why this process is useful. + +The rest of this section describes the categories and groups that have +been set up for the XEmacs project. + +＠menu +* Category:: +* Status:: +* Group:: +* Resolution:: +＠end menu + +＠node Category, Status, Bugs, Bugs +＠section Category + +＠cindex category +＠cindex bug category + +Several categories have been created for the XEmacs project organized by +function. They include ＠i{General}, ＠i{UI}, ＠i{MIME}, ＠i{Security}, +＠i{Documentation}, and ＠i{Contrib} + +＠table ＠b + +＠item General + +＠cindex general bug category +＠cindex bug categories, general + +The ＠dfn{General} category is used for bugs that do not belong in any of +the other categories. + +＠item UI + +＠cindex UI bug category +＠cindex bug categories, UI + +The ＠dfn{UI} category is used for bugs in the software that the user sees +such as font-lock, key definitions, menus, and customization. + +＠item MIME + +＠cindex MIME bug category +＠cindex bug categories, MIME + +The ＠dfn{MIME} category is used for bugs that pertain to MIME. + +＠item Security + +＠cindex security bug category +＠cindex bug categories, security + +The ＠dfn{Security} category is used for bugs in the security arena. At +present, XEmacs does not include any security code, so this category might +be used for PGP interaction. + +＠item Documentation + +＠cindex documentation bug category +＠cindex bug categories, documentation + +The ＠dfn{Documentation} category is used for bugs in the documentation +arena. In addition, if there are any code changes made as a result of a +bug report or feature request that require changes to the documentation, +the category of that issue should be set to Documentation after the bug +has been fixed or the feature implemented. Assign the issue to +＠i{wohler} for editing and/or writing of the documentation, and set +the priority to 3 to set the issue aside in listings sorted by priority. + +＠item Contrib + +＠cindex contrib bug category +＠cindex bug categories, contrib + +The ＠dfn{Contrib} category is used for all bugs in the contributed +software. + +＠end table + +＠node Status, Group, Category, Bugs +＠section Status + +＠cindex status +＠cindex bug status + +The bug ＠dfn{status} is divided into four sections: ＠i{Open}, +＠i{Closed}, ＠i{Deleted} and ＠i{Pending}. + +＠table ＠b + +＠item Open + +＠cindex open bug status +＠cindex bug status, open + +When bugs are initially created, they are marked ＠dfn{Open}. + +＠cindex discussing bugs +＠cindex bugs, discussing +＠cindex features, discussing + +The Bugs and Feature Requests sections are also used as a method to +get the ball rolling among developers. They are used to register what +we feel we should work on. For example, a developer may have questions +about the way XEmacs handles MIME that we should discuss before we +attempt to fix it: What do other people do? How should we attack this? +That developer opens a bug report in the MIME category and a +discussion ensues. Once the disposition of the issue is resolved, the +bug is assigned to a developer. Later, when the bug is fixed, the bug +can be closed. + +Discussion about entirely new features should be opened in the Feature +Requests section (＠pxref{Feature Requests}) but otherwise handled in +the same way. + +＠item Closed + +＠cindex closed bug status +＠cindex bug status, closed + +When all aspects of a bug have been fixed, including code and +documentation, the bug is marked ＠dfn{Closed}. + +When setting the status to Closed, the group should be set to Fixed, +Works For Me, Invalid, or Rejected. + +＠item Pending + +＠cindex pending bug status +＠cindex bug status, pending + +You can set the status to ＠dfn{Pending} if you are waiting for a +response from the tracker item author. When the author responds, the +status is automatically reset to that of Open. Otherwise, if the author doesn't respond within 14 days, then the item is given a status of Deleted. ＠＠ -2238,9 +2922,9 ＠＠ release. Just be sure to mention the issue number in the ChangeLog so that it can be noted in the next release announcement. -＠item mh-e* +＠item XE* -Bugs in groups starting with mh-e have either been found in the given +Bugs in groups starting with XE have either been found in the given version if the Status is Open, or fixed in the given version if the Status is Closed. ＠＠ -2362,12 +3046,10 ＠＠＠node Feature Requests, Patch Queue, Bugs, Top ＠chapter Feature Requests -＠c Edited: stephen 2005-01-18 - ＠cindex Feature Requests Developers should check the -＠uref{https://sourceforge.net/patch/?group_id=13357, Feature Requests} +Feature Requests occasionally for new feature requests and comment on the feature's usefulness and integrity. Unless a positive comment has ＠c #### define "reasonable" ＠＠ -2387,8 +3069,6 ＠＠＠node Patch Queue, File Releases, Feature Requests, Top ＠chapter Patch Queue -＠c Edited: stephen 2005-01-18 - ＠cindex Patch Queue Developers should check ＠value{PATCHES-LIST} ＠＠ -2408,8 +3088,6 ＠＠＠node File Releases, News, Patch Queue, Top ＠chapter File Releases -＠c Edited: stephen 2005-01-18 - ＠strong{This node and all of its children need to be reviewed and adapted to the XEmacs process. One topic that ＠emph{must} be addressed is regenerating and checking in generated files.} ＠＠ -2444,8 +3122,6 ＠＠＠node Release Schedule, Release Prerequisites, File Releases, File Releases ＠section Release Schedule -＠c Edited: stephen 2005-01-18 - ＠strong{Totally bogus for XEmacs historical practice, probably totally unrealistic as future policy.} ＠＠ -2508,8 +3184,6 ＠＠＠node Release Prerequisites, Updating NEWS, Release Schedule, File Releases ＠section Release Prerequisites -＠c Edited: stephen 2005-01-18 only to fix a makeinfo error - ＠cindex Release Prerequisites ＠cindex Coding Conventions ＠cindex Emacs Lisp Coding Conventions ＠＠ -2576,12 +3250,12 ＠＠＠end enumerate The previous steps usually catch most items. To use a finer sieve, use -the following commands. These assume that the last version of the XEmacs -package was 6.0. +the following commands. These assume that the last version of XEmacs +was 21.4.20. ＠example - cvs log -rmh-e-6_0 - cvs diff -rmh-e-6_0 + cvs log -rr21-4-20 + cvs diff -rr21-4-20 ＠end example See section ＠ref{Updating ChangeLogs} before checking in this file. ＠＠ -2710,15 +3384,21 ＠＠＠item ＠strong{Module} ＠tab ＠strong{Tarball} -＠item src -＠tab mh-e-M.N.tgz +＠item Full distro +＠tab xemacs-X.Y.Z.tar.gz -＠item doc -＠tab mh-e-doc-M.N.tgz +＠item Patch +＠tab xemacs-X.Y.Z-X.Y.(++Z).patch.gz -＠item contrib -＠tab mh-e-contrib-M.N.tgz +＠item Sources only +＠tab xemacs-X.Y.Z-src.tar.gz +＠item Compiled Lisp +＠tab xemacs-X.Y.Z-elc.tar.gz + +＠item Formatted Info +＠tab xemacs-X.Y.Z-info.tar.gz + ＠end multitable ＠end quotation ＠＠ -2730,40 +3410,8 ＠＠＠cindex version numbers The tarballs listed in the table above are built as follows: - -＠itemize - -＠cindex CVS, co - -＠item If ＠var{module} has not been checked out -already, check it out: - -＠example -export CVS_RSH=ssh -cvs -d -z3 $USER＠＠cvs.mh-e.sourceforge.net:/cvsroot/mh-e co -r ＠var{release} ＠var{module} -＠end example - -＠item If ＠var{module} has been checked out -already, set the sticky tag for the release: - -＠example -cvs update -r ＠var{release} -＠end example - -＠item Build the tarball. - -＠example -cd ＠var{module} -make dist -＠end example - -＠end itemize -The ＠code{make dist} command ensures that the tarball is named correctly -and that the tar extracts in a subdirectory that has the same name as -the tarball's prefix. For example, if ＠var{release} was mh-e-5_2, then -the tarball would be named mh-e-5.2.tgz and would extract into the -directory named mh-e-5.2. +＠strong{Write me!} ＠node Creating ＠value{XEMACSORG} Releases, Updating the Tracker, Creating Tarballs, File Releases ＠section Creating ＠value{XEMACSORG} Releases ＠＠ -2772,61 +3420,16 ＠＠＠cindex releases ＠cindex tarballs, making -First, create the tarballs (＠pxref{Creating Tarballs}). Then -＠uref{https://sourceforge.net/project/admin/editpackages.php?group_id=13357, -add the release} per the instructions in -＠uref{https://sourceforge.net/docman/display_doc.php?docid=6445&group_id=1#filereleasesteps, -The File Release System}. Be sure to check the box labeled -＠code{Preserve my pre-formatted text}. Use the entire ＠file{README} -file for the release notes and the appropriate section of the -＠file{NEWS} file for the Change Log. - -If there were any beta releases leading up to this release, -＠uref{https://sourceforge.net/project/admin/editreleases.php?package_id=11309&group_id=13357, -edit the release} and set the Status to Hidden. +＠strong{Write me!} ＠node Updating the Tracker, Announce the Release, Creating ＠value{XEMACSORG} Releases, File Releases ＠section Updating the Tracker ＠cindex Updating the Tracker -After XEmacs is released, update the tracker. First, change the group to -mh-e-doc-(a)var{m.n} (for example, mh-e-doc-1.3) for all open -＠uref{https://sourceforge.net/tracker/?group_id=13357&atid=113357, -bugs} and -＠uref{https://sourceforge.net/tracker/?group_id=13357&atid=363357&, -features} with a category of Documentation and a group of CVS. The -list is restricted to open issues since it is possible that an issue -was given a category of Documention for inclusion in the release -notes and then closed. Such an issue would not force a manual update. - -Then change the name of the group CVS to mh-e-(a)var{m.n} for both -＠uref{https://sourceforge.net/tracker/admin/index.php?group_id=13357&atid=113357&add_group=1, -bugs} and -＠uref{https://sourceforge.net/tracker/admin/index.php?group_id=13357&atid=363357&add_group=1, -features}. For example, when XEmacs version 6.0 is released, rename the -CVS group to mh-e-6.0. Then create a new CVS group. This should be -done for doc and contrib releases too. - -An exception to this occurs when releasing beta releases. The group -name in the series of beta releases leading up to the actual release -is reused. That way, in the end all the existing issues are left -pointing to the actual release rather than a beta. For example, CVS -would first be renamed to mh-e-6.1.90 which would in turn be renamed -to mh-e-6.1.91 which would in turn be renamed to mh-e-7.0. - -Another oddity occurs when you make a patch release. When you change -the name of the group from CVS to mh-e-(a)var{m.n.p}, you will probably -effect mainline work. So go back to -＠uref{https://sourceforge.net/tracker/?group_id=13357&atid=113357, -bugs} and -＠uref{https://sourceforge.net/tracker/?group_id=13357&atid=363357, -features}, and browse all issues with the new mh-e-(a)var{m.n.p} group -name. Perform a mass group name change from mh-e-(a)var{m.n.p} to CVS -for all issues that do not appear in the patch release. It may also be -easier to add a new group name of mh-e-(a)var{m.n.p} and set the group -of the items in the patch release to it. +＠strong{Write me! (and install a Tracker!)} + ＠node Announce the Release, Updating the Emacs Repository, Updating the Tracker, File Releases ＠section Announce the Release ＠＠ -2838,8 +3441,6 ＠＠＠node Updating the Emacs Repository, Updating the Debian Package, Announce the Release, File Releases ＠section Updating the Emacs Repository -＠c Edited: stephen 2005-01-19 - ＠strong{Needs review. Although on the face of it this obviously has nothing to do with XEmacs, in fact there are probably hints here for XEmacs release engineers.} ＠＠ -3018,6 +3619,7 ＠＠ time to put the new code on the Emacs branch. This makes it possible to detect changes to XEmacs that an Emacs developer may make later. + ＠node Updating the Debian Package, Updating the XEmacs Package, Updating the Emacs Repository, File Releases ＠section Updating the Debian Package ＠＠ -3025,9 +3627,9 ＠＠＠cindex Debian Package, Updating ＠cindex Debian -This task is the duty of Peter Galbraith <＠i{psg＠(a)debian.org}>. It may -be useful to others to want to make an unofficial package of the CVS -tree. +＠strong{Edit me! Or maybe not: currently the various distros have +their own maintainers. It might be useful for Debian/Ubuntu because of +the complex Debian Emacs policy.} To build a Debian package, you'll need to have installed the Debian package ＠code{build-essential} as well as those listed in the ＠＠ -3085,7 +3687,6 ＠＠＠node Updating the Online Documentation, Updating the Free Software Directories, Updating the XEmacs Package, File Releases ＠section Updating the Online Documentation -＠c Edited: stephen 2005-01-19 ＠strong{Adrian, please review.} ＠cindex Updating the Online Documentation ＠＠ -3135,7 +3736,6 ＠＠＠node Updating the Free Software Directories, After the Release, Updating the Online Documentation, File Releases ＠section Updating the Free Software Directories -＠c Edited: stephen 2005-01-18 ＠strong{Add FreshMeat, at least.} Update the ＠i{source-tarball} and ＠i{version} fields in the FSF/UNESCO ＠＠ -3181,8 +3781,6 ＠＠＠node News, Surveys, File Releases, Top ＠chapter News -＠c Edited: stephen 2005-01-18 - ＠strong{Needs review.} ＠cindex News ＠＠ -3214,8 +3812,7 ＠＠ As only the first paragraph is shown on the ＠value{XEMACSORG} front page, it should be written wisely. Emulate the look and feel of previous news postings. The first sentence should be the same as the first sentence -in the description on the -＠uref{https://sourceforge.net/projects/mh-e/, Summary} page. The +in the description on the home page. The following sentences are typically copied from the first paragraph of the release notes and should briefly describe the benefit of the release or otherwise entice the reader to read further. The contrib ＠＠ -3227,12 +3824,6 ＠＠ Read on for more details. ＠end example -Use the following for the second paragraph: - -＠example - Project home page at: http://mh-e.sourceforge.net/. -＠end example - Finally, include the release notes from ＠file{NEWS}. Because the introductory paragraph was already used, include the release notes starting with the ``New Features'' item. To avoid ugly wrapping, first ＠＠ -3265,18 +3856,17 ＠＠＠node Surveys, Free Software Directories, News, Top ＠chapter Surveys -＠c Edited: stephen 2005-01-18 - ＠strong{Interesting. Should we do this, maybe?} ＠cindex Surveys The project admin may create -＠uref{https://sourceforge.net/survey/?group_id=13357, Surveys}. The +＠c #### need to fix the group_id +＠uref{https://sourceforge.net/survey/?group_id=, Surveys}. The interface is backwards. First you create questions and note the question IDs. Then you create a survey and list the question IDs. -＠node Free Software Directories, Copying, Surveys, Top +＠node Free Software Directories, , Surveys, Top ＠chapter Free Software Directories ＠cindex FSF/UNESCO Free Software Directory ＠＠ -3340,404 +3930,8 ＠＠＠c * Public Forums:: ＠c * Anonymous FTP Space:: ＠c ＠end menu - -＠node Copying, Index, Free Software Directories, Top -＠appendix GNU GENERAL PUBLIC LICENSE -＠center Version 2, June 1991 - -＠display -Copyright ＠copyright{} 1989, 1991 Free Software Foundation, Inc. -59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -Everyone is permitted to copy and distribute verbatim copies -of this license document, but changing it is not allowed. -＠end display - -＠appendixsec Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software---to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - -＠iftex -＠appendixsec TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION -＠end iftex -＠ifinfo -＠center TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION -＠end ifinfo - -＠enumerate 0 -＠item -This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The ``Program,'' below, -refers to any such program or work, and a ``work based on the Program'' -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term ``modification.'') Each licensee is addressed as ``you.'' - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - -＠item -You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - -＠item -You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - -＠enumerate a -＠item -You must cause the modified files to carry prominent notices -stating that you changed the files and the date of any change. - -＠item -You must cause any work that you distribute or publish, that in -whole or in part contains or is derived from the Program or any -part thereof, to be licensed as a whole at no charge to all third -parties under the terms of this License. - -＠item -If the modified program normally reads commands interactively -when run, you must cause it, when started running for such -interactive use in the most ordinary way, to print or display an -announcement including an appropriate copyright notice and a -notice that there is no warranty (or else, saying that you provide -a warranty) and that users may redistribute the program under -these conditions, and telling the user how to view a copy of this -License. (Exception: if the Program itself is interactive but -does not normally print such an announcement, your work based on -the Program is not required to print an announcement.) -＠end enumerate - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - -＠item -You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - -＠enumerate a -＠item -Accompany it with the complete corresponding machine-readable -source code, which must be distributed under the terms of Sections -1 and 2 above on a medium customarily used for software interchange; or, - -＠item -Accompany it with a written offer, valid for at least three -years, to give any third party, for a charge no more than your -cost of physically performing source distribution, a complete -machine-readable copy of the corresponding source code, to be -distributed under the terms of Sections 1 and 2 above on a medium -customarily used for software interchange; or, - -＠item -Accompany it with the information you received as to the offer -to distribute corresponding source code. (This alternative is -allowed only for noncommercial distribution and only if you -received the program in object code or executable form with such -an offer, in accord with Subsection b above.) -＠end enumerate - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - -＠item -You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - -＠item -You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - -＠item -Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - -＠item -If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - -＠item -If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - -＠item -The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and ``any -later version,'' you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - -＠item -If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - -＠iftex -＠heading NO WARRANTY -＠end iftex -＠ifinfo -＠center NO WARRANTY -＠end ifinfo - -＠item -BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW＠. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM ``AS IS'' WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE＠. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU＠. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - -＠item -IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. -＠end enumerate - -＠iftex -＠heading END OF TERMS AND CONDITIONS -＠end iftex -＠ifinfo -＠center END OF TERMS AND CONDITIONS -＠end ifinfo - -＠page -＠appendixsec How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the ``copyright'' line and a pointer to where the full notice is found. - -＠smallexample -＠var{one line to give the program's name and an idea of what it does.} -Copyright (C) 19＠var{yy} ＠var{name of author} - -This program 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 2 -of the License, or (at your option) any later version. - -This program 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 this program; if not, write to the Free Software Foundation, Inc., -59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. -＠end smallexample - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - -＠smallexample -Gnomovision version 69, Copyright (C) 20＠var{yy} ＠var{name of author} -Gnomovision comes with ABSOLUTELY NO WARRANTY; for details -type `show w'. This is free software, and you are welcome -to redistribute it under certain conditions; type `show c' -for details. -＠end smallexample - -The hypothetical commands ＠samp{show w} and ＠samp{show c} should show -the appropriate parts of the General Public License. Of course, the -commands you use may be called something other than ＠samp{show w} and -＠samp{show c}; they could even be mouse-clicks or menu items---whatever -suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a ``copyright disclaimer'' for the program, if -necessary. Here is a sample; alter the names: - -＠smallexample -＠group -Yoyodyne, Inc., hereby disclaims all copyright -interest in the program `Gnomovision' -(which makes passes at compilers) written -by James Hacker. - -＠var{signature of Ty Coon}, 1 April 1989 -Ty Coon, President of Vice -＠end group -＠end smallexample - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. -＠node Index, , Copying, Top +＠node Index, , Nodes borrowed from other projects not adapted to XEmacs, Top ＠unnumbered Index ＠printindex cp _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

10 participants
10 comments

commit: Automated merge with ssh://aidan-guest@hg.debian.org//hg/xemacs/xemacs 7 years, 4 months

Aidan Kehoe

changeset: 4365:c9ab656691c04f41c53df820c0a83e4ee36f5177 tag: tip parent: 4364:d74913294e8794f2d973faf8af11028702444873 parent: 4362:f5693b5f7f2d6198ebb86a8983b786e62b3d4c05 user: Aidan Kehoe <kehoea(a)parhasard.net> date: Thu Dec 27 13:22:26 2007 +0100 files: lisp/ChangeLog description: Automated merge with ssh://aidan-guest＠hg.debian.org//hg/xemacs/xemacs diff -r d74913294e8794f2d973faf8af11028702444873 -r c9ab656691c04f41c53df820c0a83e4ee36f5177 ChangeLog --- a/ChangeLog Thu Dec 27 13:21:05 2007 +0100 +++ b/ChangeLog Thu Dec 27 13:22:26 2007 +0100 ＠＠ -1,6 +1,11 ＠＠ 2007-12-26 Stephen J. Turnbull <stephe 2007-12-26 Stephen J. Turnbull <stephen(a)xemacs.org> + * Makefile.in.in (mkpkgdir): Ensure only one late package directory. + +2007-12-26 Stephen J. Turnbull <stephen(a)xemacs.org> + * Makefile.in.in (check-available-packages): Say where to install. + (mkpkgdir): 2007-12-23 Stephen J. Turnbull <stephen(a)xemacs.org> diff -r d74913294e8794f2d973faf8af11028702444873 -r c9ab656691c04f41c53df820c0a83e4ee36f5177 Makefile.in.in --- a/Makefile.in.in Thu Dec 27 13:21:05 2007 +0100 +++ b/Makefile.in.in Thu Dec 27 13:22:26 2007 +0100 ＠＠ -513,11 +513,18 ＠＠ check-available-packages: then echo "To install the full set of packages with mule in"; \ echo "${package_path}/mule-packages, type:"; \ echo " make install-all-packages"; \ - fi; + fi + +# The test for a non-trivial path simply checks for the conventional Unix +# path separator ":". This is reasonable because this is basically just +# a convenience feature, anyway. mkpkgdir: FRC.mkdir ${MAKEPATH} ＠if test -z ${package_path}; \ - then echo "not configured --with-late-packages; no place to install."; \ + then echo "Not configured --with-late-packages; no place to install."; \ + exit -1; \ + elif echo ${package_path} | grep ":"; \ + then echo "Configured with multiple late package directories; you decide where to install."; \ exit -1; \ elif test -e ${package_path}/xemacs-packages \ -o -e ${package_path}/mule-packages; \ diff -r d74913294e8794f2d973faf8af11028702444873 -r c9ab656691c04f41c53df820c0a83e4ee36f5177 etc/ChangeLog --- a/etc/ChangeLog Thu Dec 27 13:21:05 2007 +0100 +++ b/etc/ChangeLog Thu Dec 27 13:22:26 2007 +0100 ＠＠ -1,3 +1,7 ＠＠ 2007-12-23 Stephen J. Turnbull <stephe +2007-12-26 Stephen J. Turnbull <stephen(a)xemacs.org> + + * bundled-packages/README: Document restriction on --with-late-packages. + 2007-12-23 Stephen J. Turnbull <stephen(a)xemacs.org> * bundled-packages/README: Documentation for bundled packages. diff -r d74913294e8794f2d973faf8af11028702444873 -r c9ab656691c04f41c53df820c0a83e4ee36f5177 etc/bundled-packages/README --- a/etc/bundled-packages/README Thu Dec 27 13:21:05 2007 +0100 +++ b/etc/bundled-packages/README Thu Dec 27 13:22:26 2007 +0100 ＠＠ -1,10 +1,13 ＠＠ Package distributions may be placed in t Package distributions may be placed in this directory. If present and a package-path is configured, packages can be installed -using the top-level makefile. +using the top-level Makefile. To configure the package path, use the --with-late-packages option to -configure, which specifies the path to the directory containing the -xemacs-packages and mule-packages hierarchies to install. +configure, which specifies a single directory in which to install the +xemacs-packages and mule-packages hierarchies provided. If this is null, +or contains a Unix-style search path (i.e., a colon is present in the +argument of the --with-late-packages option), you will have to install +the packages by hand. To find out if a distribution includes bundled packages, type diff -r d74913294e8794f2d973faf8af11028702444873 -r c9ab656691c04f41c53df820c0a83e4ee36f5177 lisp/ChangeLog --- a/lisp/ChangeLog Thu Dec 27 13:21:05 2007 +0100 +++ b/lisp/ChangeLog Thu Dec 27 13:22:26 2007 +0100 ＠＠ -5,6 +5,14 ＠＠ 2007-12-25 Aidan Kehoe <kehoea＠parhasa #'make-image-specifier with string arguments, and more noticeably truncation-glyph, continuation-glyph, octal-escape-glyph, control-arrow-glyph. + +2007-12-23 Mike Sperber <mike(a)xemacs.org> + + * font.el (xft-font-create-object): Use + `fc-pattern-get-or-compute-size' instead of + `fc-pattern-get-size'. + + * fontconfig.el (fc-pattern-get-or-compute-size): Add. 2007-12-22 Stephen J. Turnbull <stephen(a)xemacs.org> diff -r d74913294e8794f2d973faf8af11028702444873 -r c9ab656691c04f41c53df820c0a83e4ee36f5177 lisp/font.el --- a/lisp/font.el Thu Dec 27 13:21:05 2007 +0100 +++ b/lisp/font.el Thu Dec 27 13:22:26 2007 +0100 ＠＠ -813,7 +813,7 ＠＠ Optional DEVICE defaults to `default-x-d (pattern (fc-font-match device (fc-name-parse name))) (font-obj (make-font)) (family (fc-pattern-get-family pattern 0)) - (size (fc-pattern-get-size pattern 0)) + (size (fc-pattern-get-or-compute-size pattern 0)) (weight (fc-pattern-get-weight pattern 0))) (set-font-family font-obj (and (not (equal family 'fc-result-no-match)) diff -r d74913294e8794f2d973faf8af11028702444873 -r c9ab656691c04f41c53df820c0a83e4ee36f5177 lisp/fontconfig.el --- a/lisp/fontconfig.el Thu Dec 27 13:21:05 2007 +0100 +++ b/lisp/fontconfig.el Thu Dec 27 13:22:26 2007 +0100 ＠＠ -350,6 +350,21 ＠＠ corresponding Xft font slant constant." (let ((pair (assoc str fc-font-name-weight-mapping-string-reverse))) (if pair (cdr pair)))) +(defun fc-pattern-get-or-compute-size (pattern id) + "Get the size from `pattern' associated with `id' or try to compute it. +Returns 'fc-result-no-match if unsucessful." + ;; Many font patterns don't have a "size" property, but do have a + ;; "dpi" and a "pixelsize" property". + (let ((maybe (fc-pattern-get-size pattern id))) + (if (not (eq maybe 'fc-result-no-match)) + maybe + (let ((dpi (fc-pattern-get-dpi pattern id)) + (pixelsize (fc-pattern-get-pixelsize pattern id))) + (if (and (numberp dpi) + (numberp pixelsize)) + (* pixelsize (/ 72 dpi)) + 'fc-result-no-match))))) + (defun fc-copy-pattern-partial (pattern attribute-list) "Return a copy of PATTERN restricted to ATTRIBUTE-LIST. _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

2 participants
1 comments

[PATCH] xemacsweb: I can finally commit issue36 now that it is resolved 7 years, 4 months

Adrian Aichner

xemacsweb ChangeLog patch: Diff command: cvs -q diff -U 0 Files affected: About/ChangeLog Index: About/ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacsweb/About/ChangeLog,v retrieving revision 1.218 diff -u -U0 -r1.218 ChangeLog --- About/ChangeLog 6 Nov 2007 20:58:59 -0000 1.218 +++ About/ChangeLog 26 Nov 2007 19:00:20 -0000 ＠＠ -0,0 +1,4 ＠＠ +2007-11-26 Adrian Aichner <adrian(a)xemacs.org> + + * XEmacsServices.content: Document and resolve issue 36. + xemacsweb source patch: Diff command: cvs -f -z3 -q diff -u -w -N Files affected: About/XEmacsServices.content =================================================================== RCS Index: About/XEmacsServices.content =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacsweb/About/XEmacsServices.content,v retrieving revision 1.71 diff -u -w -r1.71 XEmacsServices.content --- About/XEmacsServices.content 6 Nov 2007 20:59:00 -0000 1.71 +++ About/XEmacsServices.content 26 Nov 2007 18:56:51 -0000 ＠＠ -87,9 +87,57 ＠＠ ;; See `sgml-comment-begin', `sgml-comment-end', and ;; http://htmlhelp.com/reference/wilbur/misc/comment.html (format - " <tr>\n %2$s Issue ID %3$s\n <td rowspan=\"7\" valign=\"top\"><a id=\"issue%1$d\" name=\"issue%1$d\">%1$d</a></td>\n %2$s Service(s) %3$s\n <td>all services of gwyn.tux.org are unavailable: DNS for xemacs.org, ssh, http, ftp</td>\n %2$s YYYY-MM-DD( HH:MM:SS UTC) Date found %3$s\n <td nowrap=\"nowrap\">YYYY-MM-DD( HH:MM:SS UTC)</td>\n %2$s YYYY-MM-DD( HH:MM:SS UTC) Date fixed %3$s\n <td nowrap=\"nowrap\">YYYY-MM-DD( HH:MM:SS UTC)</td>\n </tr>\n <tr>\n\t%2$s Error(s), Symptom(s) %3$s\n <th colspan=\"3\">Error(s), Symptom(s)</th>\n </tr>\n <tr>\n <td colspan=\"3\">\n\t free-form description of a error or symptom.\n <pre xml:space=\"preserve\">\nSending failed; SMTP protocol error\n221 Closing connection. Good bye.\n\t </pre>\n\t</td>\n </tr>\n <tr>\n\t%2$s Resolution(s) %3$s\n <th colspan=\"3\">Resolution(s)</th>\n </tr>\n <tr>\n ! <td colspan=\"3\">\n\t Description of resolution.\n\t</td>\n </tr>\n <tr>\n\t%2$s Reference(s) %3$s\n <th colspan=\"3\">References</th>\n </tr>\n <tr>\n <td colspan=\"3\">\n\t References to other information, like URLs for external issue documenation.\n\t</td>\n </tr>\n\n" + " <tr>\n %2$s Issue ID %3$s\n <td rowspan=\"7\" valign=\"top\"><a id=\"issue%1$d\" name=\"issue%1$d\">%1$d</a></td>\n %2$s Service(s) %3$s\n <td>all services of gwyn.tux.org are unavailable: DNS for xemacs.org, ssh, http, ftp</td>\n %2$s YYYY-MM-DD( HH:MM:SS UTC) Date found %3$s\n <td nowrap=\"nowrap\">YYYY-MM-DD( HH:MM:SS UTC)</td>\n %2$s YYYY-MM-DD( HH:MM:SS UTC) Date fixed %3$s\n <td nowrap=\"nowrap\">YYYY-MM-DD( HH:MM:SS UTC)</td>\n </tr>\n <tr>\n\t%2$s Error(s), Symptom(s) %3$s\n <th colspan=\"3\">Error(s), Symptom(s)</th>\n </tr>\n <tr>\n <td colspan=\"3\">\n\t free-form description of a error or symptom.\n <pre xml:space=\"preserve\">\nSending failed; SMTP protocol error\n221 Closing connection. Good bye.\n\t </pre>\n\t</td>\n </tr>\n <tr>\n\t%2$s Resolution(s) %3$s\n <th colspan=\"3\">Resolution(s)</th>\n </tr>\n <tr>\n ! <td colspan=\"3\">\n\t Description of resolution.\n\t</td>\n </tr>\n <tr>\n\t%2$s Reference(s) %3$s\n <th colspan=\"3\">References</th>\n </tr>\n <tr>\n <td colspan=\"3\">\n\t References to other information, like URLs for external issue documentation.\n\t</td>\n </tr>\n\n" next-issue-number sgml-comment-begin sgml-comment-end)))) --> + + <tr> +  + <td rowspan="7" valign="top"><a id="issue36" name="issue36">36</a></td> +  + <td>ssh</td> +  + <td nowrap="nowrap">2007-11-24</td> +  + <td nowrap="nowrap">2007-11-26</td> + </tr> + <tr> +  + <th colspan="3">Error(s), Symptom(s)</th> + </tr> + <tr> + <td colspan="3"> + ssh is not functional on cvs.xemacs.org. + Consequencially, cvs operations involving access via ssh do + not work. CVS read-only access via pserver is + operational. + <pre xml:space="preserve"> +Connection to cvs.xemacs.org closed by remote host. +cvs [update aborted]: end of file from server (consult above messages if any) + </pre> + <pre xml:space="preserve"> +ssh: connect to host dotsrc.org port 22: Connection timed out + </pre> + </td> + </tr> + <tr> +  + <th colspan="3">Resolution(s)</th> + </tr> + <tr> + <td colspan="3"> + + </td> + </tr> + <tr> +  + <th colspan="3">References</th> + </tr> + <tr> + <td colspan="3"> + The problem has been reported to dotsrc.org. + </td> + </tr> <tr>  -- Adrian Aichner mailto:adrian＠xemacs.org http://www.xemacs.org/ _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

3 participants
2 comments

[AC21.5] Improve resizing of echo area 7 years, 5 months

Stephen J. Turnbull

APPROVE COMMIT 21.5 This patch causes Adrian's patch of 2006-10-28 for resizing the echo area to respect resize-minibuffer-mode. I'm of two minds about that, but I think that these two facilities are so closely related that we should try to keep their behavior as similar as possible. Also, I've experienced a bit of annoyance (things like debug backtraces will max out the echo area, which won't return to normal size until you force a message), so I think it's important to have a way to turn it off. It also respects the defcustoms of resize-minibuffer-mode. I added a new defcustom, `resize-minibuffer-idle-height', which is the target height of the echo area/minibuffer window when it is idle. (Only partially unimplemented.) As with resize-minibuffer, there are two modes: adjust height exactly, and reduce only when too big. I'm reverting behavior to that of 21.5.27: those who do not enable resize-minibuffer mode won't get echo area resizing any more. If nobody objects, I'll enable resize-minibuffer-mode by default later. (This takes a little work since it was designed as a minor mode.) I've also added a function to use as an undisplay-echo-area-function, which reverts the echo area/minibuffer to small size when it's idle. Unfortunately, it seems really easy to get an uninterruptible infloop if that function signals or produces any output. Therefore it is disabled by default, and has lots of warnings in the code and documentation until I have more experience with it. Feel free to try it ... I *think* I've got all angles (except deliberate sabotage :-) covered in the current version. lisp/ChangeLog addition: 2007-04-30 Stephen J. Turnbull <stephen(a)xemacs.org> * simple.el (raw-append-message): Improve resizing of echo area --- now obeys resize-minibuffer conventions. * resize-minibuffer.el (resize-minibuffer-idle-height): New. * simple.el (undisplay-echo-area-resize-window-allowed): New. * simple.el (undisplay-echo-area-resize-window): New. Add function to shrink echo area when idle. (incomplete) * simple.el (log-message-ignore-regexps): * simple.el (undisplay-echo-area-function): * simple.el (clear-message): * simple.el (append-message): * simple.el (display-message): Improve docstrings. 21.5 source patch: Diff command: cvs -q diff -u Index: lisp/resize-minibuffer.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/resize-minibuffer.el,v retrieving revision 1.4 diff -u -u -r1.4 resize-minibuffer.el --- lisp/resize-minibuffer.el 15 Mar 2002 07:43:21 -0000 1.4 +++ lisp/resize-minibuffer.el 30 Apr 2007 13:48:01 -0000 ＠＠ -88,6 +88,15 ＠＠ :type '(choice (const nil) integer) :group 'resize-minibuffer) +;; #### Yeah, I know. The relation between the echo area and the +;; minibuffer needs rethinking. It's not really possible to unify them at +;; present. -- sjt +(defcustom resize-minibuffer-idle-height nil + "When minibuffer is idle, crop its window to this height. +Must be a positive integer or nil. nil indicates no limit. +Effective only when `undisplay-echo-area-function' respects it. One such +function is `undisplay-echo-area-resize-window'.") + (defcustom resize-minibuffer-window-exactly t "*If non-`nil', make minibuffer exactly the size needed to display all its contents. Otherwise, the minibuffer window can temporarily increase in size but Index: lisp/simple.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/simple.el,v retrieving revision 1.58 diff -u -u -r1.58 simple.el --- lisp/simple.el 29 Dec 2006 18:09:43 -0000 1.58 +++ lisp/simple.el 30 Apr 2007 13:48:03 -0000 ＠＠ -4127,9 +4127,10 ＠＠ "List of regular expressions matching messages which shouldn't be logged. See `log-message'. -Ideally, packages which generate messages which might need to be ignored -should label them with 'progress, 'prompt, or 'no-log, so they can be -filtered by the log-message-ignore-labels." +Adding entries to this list slows down messaging significantly. Wherever +possible, messages which might need to be ignored should be labeled with +'progress, 'prompt, or 'no-log, so they can be filtered by +log-message-ignore-labels." :type '(repeat regexp) :group 'log-message) ＠＠ -4146,9 +4147,39 ＠＠ :group 'log-message) (defcustom undisplay-echo-area-function nil - "The function to call to undisplay echo area buffer." -:type 'function -:group 'log-message) + "The function to call to undisplay echo area buffer. +WARNING: any problem with your function is likely to result in an +uninterruptible infinite loop. Use of custom functions is therefore not +recommended." +:type '(choice (const nil) + function) +:group 'log-message) + +(defvar undisplay-echo-area-resize-window-allowed t + "INTERNAL USE ONLY. +Guards against `undisplay-echo-area-resize-window' infloops. +Touch this at your own risk.") + +(defun undisplay-echo-area-resize-window () + "Resize idle echo area window to `resize-minibuffer-idle-height'. +If either `resize-minibuffer-idle-height' or `resize-minibuffer-mode' is nil, +does nothing. If `resize-minibuffer-window-exactly' is non-nil, always resize +to this height exactly, otherwise if current height is no larger than this, +leave it as is." + (when (default-value undisplay-echo-area-resize-window-allowed) + (setq-default undisplay-echo-area-resize-window-allowed nil) + (let* ((mbw (minibuffer-window)) + (height (window-height mbw))) + (with-boundp '(resize-minibuffer-idle-height) + (and resize-minibuffer-mode + (numberp resize-minibuffer-idle-height) + (> resize-minibuffer-idle-height 0) + (unless (if resize-minibuffer-window-exactly + (= resize-minibuffer-idle-height height) + (<= resize-minibuffer-idle-height height)) + (enlarge-window (- resize-minibuffer-idle-height height) + nil mbw)))) + (setq-default undisplay-echo-area-resize-window-allowed t)))) ;;Subsumed by view-lossage ;; Not really, I'm adding it back by popular demand. -slb ＠＠ -4235,6 +4266,9 ＠＠ is nil, it will be displayed. The string which remains in the echo area will be returned, or nil if the message-stack is now empty. If LABEL is nil, the entire message-stack is cleared. +STDOUT-P is ignored, except for output to stream devices. For streams, +STDOUT-P non-nil directs output to stdout, otherwise to stderr. \(This is +used only in case of restoring an earlier message from the stack.) Unless you need the return value or you need to specify a label, you should just use (message nil)." ＠＠ -4293,13 +4327,19 ＠＠ (setq log (cdr log))))) (defun append-message (label message &optional frame stdout-p) + "Add MESSAGE to the message-stack, or append it to the existing text. +LABEL is the class of the message. If it is the same as that of the top of +the message stack, MESSAGE is appended to the existing message, otherwise +it is pushed on the stack. +FRAME determines the minibuffer window to send the message to. +STDOUT-P is ignored, except for output to stream devices. For streams, +STDOUT-P non-nil directs output to stdout, otherwise to stderr." (or frame (setq frame (selected-frame))) ;; If outputting to the terminal, make sure output from anyone else clears ;; the left side first, but don't do it ourselves, otherwise we won't be ;; able to append to an existing message. (if (eq 'stream (frame-type frame)) (set-device-clear-left-side (frame-device frame) nil)) - ;; Add a new entry to the message-stack, or modify an existing one (let ((top (car message-stack))) (if (eq label (car top)) (setcdr top (concat (cdr top) message)) ＠＠ -4308,31 +4348,60 ＠＠ (if (eq 'stream (frame-type frame)) (set-device-clear-left-side (frame-device frame) t))) -;; Really append the message to the echo area. no fiddling with +;; Really append the message to the echo area. No fiddling with ;; message-stack. (defun raw-append-message (message &optional frame stdout-p) (unless (equal message "") (let ((inhibit-read-only t)) (with-current-buffer " *Echo Area*" (insert-string message) - ;; (fill-region (point-min) (point-max)) - (enlarge-window - (- - (ceiling - (/ (- (point-max) (point-min)) - (- (window-width (minibuffer-window)) 1.0))) - (window-height (minibuffer-window))) - nil (minibuffer-window))) - ;; Conditionalizing on the device type in this way is not that clean, - ;; but neither is having a device method, as I originally implemented - ;; it: all non-stream devices behave in the same way. Perhaps - ;; the cleanest way is to make the concept of a "redisplayable" - ;; device, which stream devices are not. Look into this more if - ;; we ever create another non-redisplayable device type (e.g. - ;; processes? printers?). + ;; #### This needs to be conditional; cf discussion by Stefan Monnier + ;; et al on emacs-devel in mid-to-late April 2007. One problem is + ;; there is no known good way to guess whether the user wants to have + ;; the echo area height changed on him asynchronously, especially + ;; after message display. + ;; There is also a problem where Lisp backtraces get sent to the echo + ;; area, thus maxing out the window height. Unfortunately, it doesn't + ;; return to a reasonable size very quickly. + ;; It is not clear that echo area and minibuffer behavior should be + ;; linked as we do here. It's OK for now; at least this obeys the + ;; minibuffer resizing conventions which seem a pretty good guess + ;; at user preference. + (when resize-minibuffer-mode + ;; #### interesting idea, unbearable implementation + ;; (fill-region (point-min) (point-max)) + ;; + ;; #### We'd like to be able to do something like + ;; + ;; (save-window-excursion + ;; (select-window (minibuffer-window frame)) + ;; (resize-minibuffer-window)))) + ;; + ;; but that can't work, because the echo area isn't a real window! + ;; We should fix that, but this is an approximation, duplicating the + ;; resize-minibuffer code. + (let* ((mbw (minibuffer-window frame)) + (height (window-height mbw)) + (lines (ceiling (/ (- (point-max) (point-min)) + (- (window-width mbw) 1.0))))) + (and (numberp resize-minibuffer-window-max-height) + (> resize-minibuffer-window-max-height 0) + (setq lines (min lines + resize-minibuffer-window-max-height))) + (or (if resize-minibuffer-window-exactly + (= lines height) + (<= lines height)) + (enlarge-window (- lines height) nil mbw))))) ;; Don't redisplay the echo area if we are executing a macro. (if (not executing-kbd-macro) + ;; Conditionalizing on the device type in this way isn't clean, but + ;; neither is having a device method, as I originally implemented + ;; it: all non-stream devices behave in the same way. Perhaps + ;; the cleanest way is to make the concept of a "redisplayable" + ;; device, which stream devices are not. Look into this more if + ;; we ever create another non-redisplayable device type (e.g. + ;; processes? printers?). (if (eq 'stream (frame-type frame)) (send-string-to-terminal message stdout-p (frame-device frame)) (funcall redisplay-echo-area-function)))))) ＠＠ -4341,6 +4410,8 ＠＠ "Print a one-line message at the bottom of the frame. First argument LABEL is an identifier for this message. MESSAGE is the string to display. Use `clear-message' to remove a labelled message. +STDOUT-P is ignored, except for output to stream devices. For streams, +STDOUT-P non-nil directs output to stdout, otherwise to stderr. Here are some standard labels (those marked with `*' are not logged by default--see the `log-message-ignore-labels' variable): ---------------- end of patch ---------------- _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

2 participants
1 comments

[PATCH] Changes the default so with-xft=yes results in xft activated 7 years, 7 months

The XEmacs Package Smoketest

Hi, My first hg patch coming up. Please inspect carefully. Maybe not a wise thing to start with changing configure behavior. After running make configure I got unexpected changes in lib-src/config.values.in. Am I doing something wrong here? Details below. There seemed to be a typo concerning with-xft-gauge and with-xft-gauges that results in gauges beeing selected unconditionally if with_xft_emacs=yes. I guess xft-gauges isn't used at the moment so it may be left as it is for some reason. Stephen? # HG changeset patch # User Mats Lidell <matsl(a)xemacs.org> # Date 1217196051 -7200 # Node ID 2e80c89e982f64e78281062454bfd06de74df56f # Parent 6b0000935adc3f79cb189350d6014d4b4aff734e Changes the default for with-xft so that with-xft=yes results in a default that has xft activated. Also fixes a typo. Both with-xft-gauge and with-xft-gauges was present. diff -r 6b0000935adc -r 2e80c89e982f ChangeLog --- a/ChangeLog Sat Jul 26 13:50:27 2008 +0300 +++ b/ChangeLog Mon Jul 28 00:00:51 2008 +0200 ＠＠ -1,3 +1,8 ＠＠ +2008-07-27 Mats Lidell <matsl(a)xemacs.org> + + * configure.ac (XE_COMPLEX_ARG): Use different defaults for with-xft + and without-xft. + 2008-07-06 Ville Skytt~ <scop(a)xemacs.org> * configure.ac (xe_fst): diff -r 6b0000935adc -r 2e80c89e982f configure --- a/configure Sat Jul 26 13:50:27 2008 +0300 +++ b/configure Mon Jul 28 00:00:51 2008 +0200 ＠＠ -1426,10 +1426,6 ＠＠ --enable-FEATURE[=ARG] alias for --with-FEATURE --without-FEATURE do not use FEATURE (same as --with-FEATURE=no) --disable-FEATURE alias for --without-FEATURE - -Compilation options -------------------- - --with-compiler C compiler to use --with-xemacs-compiler compiler to use to compile just the xemacs executable and C modules. If you want to compile ＠＠ -1538,7 +1534,8 ＠＠ `gauges'. Prefix component with `no' to disable its use of Xft. Requires X11, Xft, Xrender, freetype, and fontconfig support. Default is `noemacs, - nomenubars, notabs, nogauges'. + nomenubars, notabs, nogauges'. The default when + selected is `emacs, nomenubars, notabs, nogauges'. --with-gtk Support GTK on the X Window System. (EXPERIMENTAL) --with-gnome Support GNOME on the X Window System. (EXPERIMENTAL) --with-msw Support MS Windows as a window system (only under ＠＠ -2266,7 +2263,6 ＠＠ MAKE_SUBDIR="$MAKE_SUBDIR lib-src" && if test "$verbose" = "yes"; then echo " Appending \"lib-src\" to \$MAKE_SUBDIR"; fi INSTALL_ARCH_DEP_SUBDIR="$INSTALL_ARCH_DEP_SUBDIR lib-src" && if test "$verbose" = "yes"; then echo " Appending \"lib-src\" to \$INSTALL_ARCH_DEP_SUBDIR"; fi with_dragndrop_default="no" - # If --with-compiler or --without-compiler were given then copy the value to the # equivalent enable_compiler variable. if test "${with_compiler+set}" = set; then ＠＠ -2888,12 +2884,12 ＠＠ fi; _xft_notfirst="" -_xft_emacs_default=no +_xft_emacs_default=yes _xft_menubars_default=no _xft_tabs_default=no _xft_gauges_default=no _xft_types="emacs menubars tabs gauges" -_xft_default="noemacs,nomenubars,notabs,nogauges" +_xft_default="emacs,nomenubars,notabs,nogauges" # If --with-xft or --without-xft were given then copy the value to the # equivalent enable_xft variable. ＠＠ -2970,7 +2966,7 ＠＠ eval "enable_xft_$y=\$_xft_${y}_default" unset _xft_${y}_default done - +with_xft_emacs=no fi; # If --with-gtk or --without-gtk were given then copy the value to the # equivalent enable_gtk variable. ＠＠ -27332,11 +27328,11 ＠＠ with_xft_tabs="no" fi fi -if test "$with_xft_gauge" != "no" ; then +if test "$with_xft_gauges" != "no" ; then if test "$with_xft_emacs" = "yes" -a "$enable_widgets" != "no" ; then - with_xft_gauge="yes" - else - with_xft_gauge="no" + with_xft_gauges="yes" + else + with_xft_gauges="no" fi fi ＠＠ -27528,8 +27524,8 ＠＠ #define USE_XFT_TABS 1 _ACEOF -test "$with_xft_gauge" = "yes" && cat >>confdefs.h <<\_ACEOF -#define USE_XFT_GAUGE 1 +test "$with_xft_gauges" = "yes" && cat >>confdefs.h <<\_ACEOF +#define USE_XFT_GAUGES 1 _ACEOF diff -r 6b0000935adc -r 2e80c89e982f configure.ac --- a/configure.ac Sat Jul 26 13:50:27 2008 +0300 +++ b/configure.ac Mon Jul 28 00:00:51 2008 +0200 ＠＠ -540,23 +540,7 ＠＠ dnl Note that AS_HELP_STRING compresses whitespace, wraps, and indents the dnl string to fit the --help display; there's no need to preformat. dnl -dnl I think these will be caught by autoconf internal checks, -dnl only --with-* are unchecked -dnl --external-widget --enable-external-widget -dnl --native-sound-lib=LIB --with-native-sound-lib -dnl --mail-locking=TYPE --with-mail-locking -dnl --rel-alloc --with-rel-alloc -dnl --use-number-lib --enable-bignum -dnl --debug --enable-debug -dnl --error-checking --enable-error-checking -dnl --memory-usage-stats --enable-memory-usage-stats -dnl --quick-build --enable-quick-build -dnl --use-union-type --enable-union-type -dnl --pdump --enable-pdump -dnl --use-kkcc --enable-kkcc -dnl -dnl parse flags -XE_HELP_SUBSECTION([Compilation options]) +dnl I think these will be caught by autoconf inFTE_HELP_SUBSECTION([Compilation options]) XE_MERGED_ARG([compiler], AS_HELP_STRING([--with-compiler],[C compiler to use]), [], []) ＠＠ -690,9 +674,10 ＠＠ [Xft], [`emacs' (buffers), `menubars', `tabs', and `gauges'], [X11, Xft, Xrender, freetype, and fontconfig], - [`noemacs, nomenubars, notabs, nogauges'])], - [],[], - [XE_COMPLEX_OPTION([emacs],[no]), + [`noemacs, nomenubars, notabs, nogauges'. + The default when selected is `emacs, nomenubars, notabs, nogauges'])], + [],[with_xft_emacs=no], + [XE_COMPLEX_OPTION([emacs],[yes]), XE_COMPLEX_OPTION([menubars],[no]), XE_COMPLEX_OPTION([tabs],[no]), XE_COMPLEX_OPTION([gauges],[no])]) ＠＠ -3540,7 +3525,7 ＠＠ AC_DEFINE(HAVE_FONTCONFIG) AC_DEFINE(USE_XFT) dnl Due to interactions with other libraries, must postpone AC_DEFINE - dnl of USE_XFT_MENUBARS, USE_XFT_TABS, and USE_XFT_GAUGE. + dnl of USE_XFT_MENUBARS, USE_XFT_TABS, and USE_XFT_GAUGES. unset xft_includes_found fi fi ＠＠ -4429,11 +4414,11 ＠＠ fi fi dnl this is not in xft reloaded #3 -if test "$with_xft_gauge" != "no" ; then +if test "$with_xft_gauges" != "no" ; then if test "$with_xft_emacs" = "yes" -a "$enable_widgets" != "no" ; then - with_xft_gauge="yes" - else - with_xft_gauge="no" + with_xft_gauges="yes" + else + with_xft_gauges="no" fi fi ＠＠ -4526,7 +4511,7 ＠＠ test "$with_xft_menubars" = "yes" && AC_DEFINE(USE_XFT_MENUBARS) test "$with_xft_tabs" = "yes" && AC_DEFINE(USE_XFT_TABS) -test "$with_xft_gauge" = "yes" && AC_DEFINE(USE_XFT_GAUGE) +test "$with_xft_gauges" = "yes" && AC_DEFINE(USE_XFT_GAUGES) dnl ---------------------- dnl Mule-dependent options diff -r 6b0000935adc -r 2e80c89e982f lib-src/config.values.in --- a/lib-src/config.values.in Sat Jul 26 13:50:27 2008 +0300 +++ b/lib-src/config.values.in Mon Jul 28 00:00:51 2008 +0200 ＠＠ -15,178 +15,6 ＠＠ ;;; Variables defined in configure by AC_SUBST follow: ;;; (These are used in Makefiles) -ALLOCA "＠ALLOCA＠" -ARCHLIBDIR "＠ARCHLIBDIR＠" -ARCHLIBDIR_USER_DEFINED "＠ARCHLIBDIR_USER_DEFINED＠" -CC "＠CC＠" -CFLAGS "＠CFLAGS＠" -CPP "＠CPP＠" -CPPFLAGS "＠CPPFLAGS＠" -DEFS "＠DEFS＠" -DOCDIR "＠DOCDIR＠" -DOCDIR_USER_DEFINED "＠DOCDIR_USER_DEFINED＠" -EARLY_PACKAGE_DIRECTORIES "＠EARLY_PACKAGE_DIRECTORIES＠" -EARLY_PACKAGE_DIRECTORIES_USER_DEFINED "＠EARLY_PACKAGE_DIRECTORIES_USER_DEFINED＠" -ECHO_C "＠ECHO_C＠" -ECHO_N "＠ECHO_N＠" -ECHO_T "＠ECHO_T＠" -EGREP "＠EGREP＠" -ETCDIR "＠ETCDIR＠" -ETCDIR_USER_DEFINED "＠ETCDIR_USER_DEFINED＠" -EXEC_PREFIX "＠EXEC_PREFIX＠" -EXEC_PREFIX_USER_DEFINED "＠EXEC_PREFIX_USER_DEFINED＠" -EXEEXT "＠EXEEXT＠" -GTK_CONFIG "＠GTK_CONFIG＠" -INFODIR "＠INFODIR＠" -INFODIR_USER_DEFINED "＠INFODIR_USER_DEFINED＠" -INFOPATH "＠INFOPATH＠" -INFOPATH_USER_DEFINED "＠INFOPATH_USER_DEFINED＠" -INSTALL "＠INSTALL＠" -INSTALLPATH "＠INSTALLPATH＠" -INSTALL_ARCH_DEP_SUBDIR "＠INSTALL_ARCH_DEP_SUBDIR＠" -INSTALL_DATA "＠INSTALL_DATA＠" -INSTALL_PROGRAM "＠INSTALL_PROGRAM＠" -INSTALL_SCRIPT "＠INSTALL_SCRIPT＠" -LAST_PACKAGE_DIRECTORIES "＠LAST_PACKAGE_DIRECTORIES＠" -LAST_PACKAGE_DIRECTORIES_USER_DEFINED "＠LAST_PACKAGE_DIRECTORIES_USER_DEFINED＠" -LATE_PACKAGE_DIRECTORIES "＠LATE_PACKAGE_DIRECTORIES＠" -LATE_PACKAGE_DIRECTORIES_USER_DEFINED "＠LATE_PACKAGE_DIRECTORIES_USER_DEFINED＠" -LDFLAGS "＠LDFLAGS＠" -LIBOBJS "＠LIBOBJS＠" -LIBS "＠LIBS＠" -LIBSTDCPP "＠LIBSTDCPP＠" -LISPDIR "＠LISPDIR＠" -LISPDIR_USER_DEFINED "＠LISPDIR_USER_DEFINED＠" -LN_S "＠LN_S＠" -LTLIBOBJS "＠LTLIBOBJS＠" -MAKE_DOCFILE "＠MAKE_DOCFILE＠" -MAKE_SUBDIR "＠MAKE_SUBDIR＠" -MODARCHDIR "＠MODARCHDIR＠" -MODCFLAGS "＠MODCFLAGS＠" -MODULEDIR "＠MODULEDIR＠" -MODULEDIR_USER_DEFINED "＠MODULEDIR_USER_DEFINED＠" -MOD_CC "＠MOD_CC＠" -MOD_INSTALL_PROGRAM "＠MOD_INSTALL_PROGRAM＠" -OBJECT_TO_BUILD "＠OBJECT_TO_BUILD＠" -OBJEXT "＠OBJEXT＠" -PACKAGE_BUGREPORT "＠PACKAGE_BUGREPORT＠" -PACKAGE_NAME "＠PACKAGE_NAME＠" -PACKAGE_PATH "＠PACKAGE_PATH＠" -PACKAGE_PATH_USER_DEFINED "＠PACKAGE_PATH_USER_DEFINED＠" -PACKAGE_STRING "＠PACKAGE_STRING＠" -PACKAGE_TARNAME "＠PACKAGE_TARNAME＠" -PACKAGE_VERSION "＠PACKAGE_VERSION＠" -PATH_SEPARATOR "＠PATH_SEPARATOR＠" -PREFIX "＠PREFIX＠" -PREFIX_USER_DEFINED "＠PREFIX_USER_DEFINED＠" -PROGNAME "＠PROGNAME＠" -RANLIB "＠RANLIB＠" -RECURSIVE_MAKE_ARGS "＠RECURSIVE_MAKE_ARGS＠" -SET_MAKE "＠SET_MAKE＠" -SHELL "＠SHELL＠" -SITELISPDIR "＠SITELISPDIR＠" -SITELISPDIR_USER_DEFINED "＠SITELISPDIR_USER_DEFINED＠" -SITEMODULEDIR "＠SITEMODULEDIR＠" -SITEMODULEDIR_USER_DEFINED "＠SITEMODULEDIR_USER_DEFINED＠" -SRC_SUBDIR_DEPS "＠SRC_SUBDIR_DEPS＠" -SUBDIR_MAKEFILES "＠SUBDIR_MAKEFILES＠" -XEMACS_CC "＠XEMACS_CC＠" -XE_CFLAGS "＠XE_CFLAGS＠" -X_CFLAGS "＠X_CFLAGS＠" -X_EXTRA_LIBS "＠X_EXTRA_LIBS＠" -X_LIBS "＠X_LIBS＠" -X_PRE_LIBS "＠X_PRE_LIBS＠" -YACC "＠YACC＠" -abs_builddir "＠abs_builddir＠" -abs_srcdir "＠abs_srcdir＠" -abs_top_builddir "＠abs_top_builddir＠" -abs_top_srcdir "＠abs_top_srcdir＠" -ac_ct_CC "＠ac_ct_CC＠" -ac_ct_RANLIB "＠ac_ct_RANLIB＠" -archlibdir "＠archlibdir＠" -bindir "＠bindir＠" -bitmapdir "＠bitmapdir＠" -blddir "＠blddir＠" -build "＠build＠" -build_alias "＠build_alias＠" -build_cpu "＠build_cpu＠" -build_os "＠build_os＠" -build_vendor "＠build_vendor＠" -builddir "＠builddir＠" -c_switch_all "＠c_switch_all＠" -c_switch_general "＠c_switch_general＠" -c_switch_window_system "＠c_switch_window_system＠" -canna_libs "＠canna_libs＠" -configuration "＠configuration＠" -configure_input "＠configure_input＠" -datadir "＠datadir＠" -datarootdir "＠datarootdir＠" -dll_cflags "＠dll_cflags＠" -dll_ld "＠dll_ld＠" -dll_ldflags "＠dll_ldflags＠" -dll_ldo "＠dll_ldo＠" -dll_post "＠dll_post＠" -dnd_objs "＠dnd_objs＠" -docdir "＠docdir＠" -dynodump_arch "＠dynodump_arch＠" -early_packages "＠early_packages＠" -etcdir "＠etcdir＠" -exec_prefix "＠exec_prefix＠" -extra_includes "＠extra_includes＠" -extra_objs "＠extra_objs＠" -have_esd_config "＠have_esd_config＠" -host_alias "＠host_alias＠" -includedir "＠includedir＠" -infodir "＠infodir＠" -infopath "＠infopath＠" -install_pp "＠install_pp＠" -inststaticdir "＠inststaticdir＠" -instvardir "＠instvardir＠" -internal_makefile_list "＠internal_makefile_list＠" -last_packages "＠last_packages＠" -late_packages "＠late_packages＠" -ld "＠ld＠" -ld_dynamic_link_flags "＠ld_dynamic_link_flags＠" -ld_libs_all "＠ld_libs_all＠" -ld_libs_general "＠ld_libs_general＠" -ld_libs_window_system "＠ld_libs_window_system＠" -ld_switch_all "＠ld_switch_all＠" -ld_switch_general "＠ld_switch_general＠" -ld_switch_shared "＠ld_switch_shared＠" -ld_switch_window_system "＠ld_switch_window_system＠" -ldap_libs "＠ldap_libs＠" -lib_gcc "＠lib_gcc＠" -libdir "＠libdir＠" -libexecdir "＠libexecdir＠" -libs_xauth "＠libs_xauth＠" -lispdir "＠lispdir＠" -localstatedir "＠localstatedir＠" -lwlib_objs "＠lwlib_objs＠" -machfile "＠machfile＠" -mandir "＠mandir＠" -moduledir "＠moduledir＠" -native_sound_lib "＠native_sound_lib＠" -oldincludedir "＠oldincludedir＠" -opsysfile "＠opsysfile＠" -package_path "＠package_path＠" -postgresql_libs "＠postgresql_libs＠" -prefix "＠prefix＠" -program_transform_name "＠program_transform_name＠" -sbindir "＠sbindir＠" -sharedstatedir "＠sharedstatedir＠" -sitelispdir "＠sitelispdir＠" -sitemoduledir "＠sitemoduledir＠" -sound_cflags "＠sound_cflags＠" -srcdir "＠srcdir＠" -start_files "＠start_files＠" -start_flags "＠start_flags＠" -statedir "＠statedir＠" -sysconfdir "＠sysconfdir＠" -target_alias "＠target_alias＠" -top_builddir "＠top_builddir＠" -top_srcdir "＠top_srcdir＠" -version "＠version＠" -with_modules "＠with_modules＠" ;;; Variables defined in configure by AC_DEFINE and AC_DEFINE_UNQUOTED follow: ;;; (These are used in C code) diff -r 6b0000935adc -r 2e80c89e982f src/ChangeLog --- a/src/ChangeLog Sat Jul 26 13:50:27 2008 +0300 +++ b/src/ChangeLog Mon Jul 28 00:00:51 2008 +0200 ＠＠ -1,3 +1,7 ＠＠ +2008-07-27 Mats Lidell <matsl(a)xemacs.org> + + * config.h.in: Renamed USE_XFT_GAUGES. + 2008-07-20 John Paul Wallington <jpw(a)pobox.com> * nt.c (Fmswindows_short_file_name, Fmswindows_long_file_name): diff -r 6b0000935adc -r 2e80c89e982f src/config.h.in --- a/src/config.h.in Sat Jul 26 13:50:27 2008 +0300 +++ b/src/config.h.in Mon Jul 28 00:00:51 2008 +0200 ＠＠ -20,8 +20,7 ＠＠ Boston, MA 02111-1307, USA. */ /* Significantly divergent from FSF. */ - -/* No code in XEmacs #includes config.h twice, but some of the code +XEmacs #includes config.h twice, but some of the code intended to work with other packages as well (like gmalloc.c) think they can include it as many times as they like. */ #ifndef _SRC_CONFIG_H_ ＠＠ -225,7 +224,7 ＠＠ /* Per-widget stuff will go away? */ #undef USE_XFT_MENUBARS #undef USE_XFT_TABS -#undef USE_XFT_GAUGE +#undef USE_XFT_GAUGES /* Defines for building X applications */ #ifdef HAVE_X_WINDOWS Done 00:03:05 -- %% Mats _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

3 participants
12 comments

[PATCH] Move the heavy lifting from cl-seq.el to C. 13 years, 11 months

Aidan Kehoe

This hasn’t been committed yet, I’m going to give it a few days. It makes fns.c immense, and I think it’s reasonable to split off various functions in it into a sequence.c (for the more general functions) and a list.c (for those specifically limited to lists). But that’s best done after the below goes in. I also plan to write something similar to get_check_match_function for #'sort* and #'merge; it’s analagous to a bytecode, it’s easy to avoid funcalls for the common comparison operations, in particular #'< and #'string-lessp. I’ve compiled with and without --with-xemacs-compiler=g++-4.0, --with-union-type; I don’t get any warnings about declarations interleaving with statements, and I caught a couple of incompatibilities with the union build. There may still be incompatibilities, and I will be watching the buildbots once I commit it. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1293674392 0 # Node ID d1b17a33450bbfaa57820405a9dc556eda146582 # Parent f87bb35a6b94954e154e89f9138c6dd6487377cc Move the heavy lifting from cl-seq.el to C. src/ChangeLog addition: 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> Move the heavy lifting from cl-seq.el to C, finally making those functions first-class XEmacs citizens, with circularity checking, built-in support for tests other than #'eql, and as much compatibility with current Common Lisp as Paul Dietz' tests require. * fns.c (check_eq_nokey, check_eq_key, check_eql_nokey) (check_eql_key, check_equal_nokey, check_equal_key) (check_equalp_nokey, check_equalp_key, check_string_match_nokey) (check_string_match_key, check_other_nokey, check_other_key) (check_if_nokey, check_if_key, check_match_eq_key) (check_match_eql_key, check_match_equal_key) (check_match_equalp_key, check_match_other_key): New. These are basically to provide function pointers to be used by Lisp functions that take TEST, TEST-NOT and KEY arguments. (get_check_match_function_1, get_check_test_function) (get_check_match_function): These functions work out which of the previous list of functions to use, given the keywords supplied by the user. (count_with_tail): New. This is the bones of #'count. (list_count_from_end, string_count_from_end): Utility functions for #'count. (Fcount): New, moved from cl-seq.el. (list_position_cons_before): New. The implementation of #'member*, and important in implementing various other functions. (FmemberX, Fadjoin, FassocX, FrassocX, Fposition, Ffind) (FdeleteX, FremoveX, Fdelete_duplicates, Fremove_duplicates) (Fnsubstitute, Fsubstitute, Fsublis, Fnsublis, Fsubst, Fnsubst) (Ftree_equal, Fmismatch, Fsearch, Fintersection, Fnintersection) (Fsubsetp, Fset_difference, Fnset_difference, Fnunion, Funion) (Fset_exclusive_or, Fnset_exclusive_or): New, moved here from cl-seq.el. (position): New. The implementation of #'find and #'position. (list_delete_duplicates_from_end, subst, sublis, nsublis) (tree_equal, mismatch_from_end, mismatch_list_list) (mismatch_list_string, mismatch_list_array) (mismatch_string_array, mismatch_string_string) (mismatch_array_array, get_mismatch_func): Helper C functions for the Lisp-visible functions. (venn, nvenn): New. The implementation of the main Lisp functions that treat lists as sets. lisp/ChangeLog addition: 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> * cl-seq.el: Move the heavy lifting from this file to C. Dump the cl-parsing-keywords macro, but don't use defun* for the functions we define that do take keywords, dynamic scope lossage makes that not practical. * subr.el (sort, fillarray): Move these aliases here. (map-plist): #'nsublis is now built-in, but at this point #'eql isn't necessarily available as a test; use #'eq. * obsolete.el (cl-delete-duplicates): Make this available for old compiler macros and old code. (memql): Document that this is equivalent to #'member*, and worse. * cl.el (adjoin, subst): Removed. These are in C. diff -r f87bb35a6b94 -r d1b17a33450b lisp/ChangeLog --- a/lisp/ChangeLog Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/ChangeLog Thu Dec 30 01:59:52 2010 +0000 ＠＠ -1,3 +1,18 ＠＠ +2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> + + * cl-seq.el: + Move the heavy lifting from this file to C. Dump the + cl-parsing-keywords macro, but don't use defun* for the functions + we define that do take keywords, dynamic scope lossage makes that + not practical. + * subr.el (sort, fillarray): Move these aliases here. + (map-plist): #'nsublis is now built-in, but at this point #'eql + isn't necessarily available as a test; use #'eq. + * obsolete.el (cl-delete-duplicates): Make this available for old + compiler macros and old code. + (memql): Document that this is equivalent to #'member*, and worse. + * cl.el (adjoin, subst): Removed. These are in C. + 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> * simple.el (assoc-ignore-case): Remove a duplicate definition of diff -r f87bb35a6b94 -r d1b17a33450b lisp/cl-seq.el --- a/lisp/cl-seq.el Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/cl-seq.el Thu Dec 30 01:59:52 2010 +0000 ＠＠ -47,541 +47,189 ＠＠ ;; See cl.el for Change Log. - ;;; Code: -;;; Keyword parsing. This is special-cased here so that we can compile -;;; this file independent from cl-macs. +;; XEmacs; all the heavy lifting of this file is now in C. There's no need +;; for the cl-parsing-keywords macro. We could use defun* for the +;; keyword-parsing code, which would avoid the necessity of the arguments: +;; () lists in the docstrings, but that often breaks because of dynamic +;; scope (e.g. a variable called start bound in this file and one in a +;; user-supplied test predicate may well interfere with each other). -(defmacro cl-parsing-keywords (kwords other-keys &rest body) - "Helper macro for functions with keyword arguments. -This is a temporary solution, until keyword arguments are natively supported. -Declare your function ending with (... &rest cl-keys), then wrap the -function body in a call to `cl-parsing-keywords'. +;; XEmacs change: these two are in subr.el in GNU Emacs. +(defun remove (cl-item cl-seq) + "Remove all occurrences of ITEM in SEQUENCE, testing with `equal'. -KWORDS is a list of keyword definitions. Each definition should be -either a keyword or a list (KEYWORD DEFAULT-VALUE). In the former case, -the default value is nil. The keywords are available in BODY as the name -of the keyword, minus its initial colon and prepended with `cl-'. +This is a non-destructive function; it makes a copy of SEQUENCE if necessary +to avoid corrupting the original SEQUENCE. +Also see: `remove*', `delete', `delete*' -OTHER-KEYS specifies other keywords that are accepted but ignored. It -is either the value 't' (ignore all other keys, equivalent to the -&allow-other-keys argument declaration in Common Lisp) or a list in the -same format as KWORDS. If keywords are given that are not in KWORDS -and not allowed by OTHER-KEYS, an error will normally be signalled; but -the caller can override this by specifying a non-nil value for the -keyword:allow-other-keys (which defaults to t)." - (cons - 'let* - (cons (mapcar - (function - (lambda (x) - (let* ((var (if (consp x) (car x) x)) - (mem (list 'car (list 'cdr (list 'memq (list 'quote var) - 'cl-keys))))) - (if (eq var :test-not) - (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) - (if (eq var :if-not) - (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) - (list (intern - (format "cl-%s" (substring (symbol-name var) 1))) - (if (consp x) (list 'or mem (car (cdr x))) mem))))) - kwords) - (append - (and (not (eq other-keys t)) - (list - (list 'let '((cl-keys-temp cl-keys)) - (list 'while 'cl-keys-temp - (list 'or (list 'memq '(car cl-keys-temp) - (list 'quote - (mapcar - (function - (lambda (x) - (if (consp x) - (car x) x))) - (append kwords - other-keys)))) - '(car (cdr (memq (quote :allow-other-keys) - cl-keys))) - '(error 'invalid-keyword-argument - (car cl-keys-temp))) - '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) - body)))) -(put 'cl-parsing-keywords 'lisp-indent-function 2) -(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) +arguments: (ITEM SEQUENCE)" + (remove* cl-item cl-seq :test #'equal)) -(defmacro cl-check-key (x) - (list 'if 'cl-key (list 'funcall 'cl-key x) x)) +(defun remq (cl-item cl-seq) + "Remove all occurrences of ITEM in SEQUENCE, comparing with `eq'. -(defmacro cl-check-test-nokey (item x) - (list 'cond - (list 'cl-test - (list 'eq (list 'not (list 'funcall 'cl-test item x)) - 'cl-test-not)) - (list 'cl-if - (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) - (list 't (list 'if (list 'numberp item) - (list 'equal item x) (list 'eq item x))))) +This is a non-destructive function; it makes a copy of SEQUENCE to avoid +corrupting the original LIST. See also the more general `remove*'. -(defmacro cl-check-test (item x) - (list 'cl-check-test-nokey item (list 'cl-check-key x))) +arguments: (ITEM SEQUENCE)" + (remove* cl-item cl-seq :test #'eq)) -(defmacro cl-check-match (x y) - (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) - (list 'if 'cl-test - (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) - (list 'if (list 'numberp x) - (list 'equal x y) (list 'eq x y)))) +(defun remove-if (cl-predicate cl-seq &rest cl-keys) + "Remove all items satisfying PREDICATE in SEQUENCE. -(put 'cl-check-key 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) -(put 'cl-check-match 'edebug-form-spec 'edebug-forms) +This is a non-destructive function; it makes a copy of SEQUENCE if necessary +to avoid corrupting the original SEQUENCE. If SEQUENCE is a list, the copy +may share list structure with SEQUENCE. If no item satisfies PREDICATE, +SEQUENCE itself is returned, unmodified. -(defvar cl-test) (defvar cl-test-not) -(defvar cl-if) (defvar cl-if-not) -(defvar cl-key) +See `remove*' for the meaning of the keywords. -;; XEmacs; #'replace is in fns.c. +arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)" + (apply 'remove* 'remove* cl-seq :if cl-predicate cl-keys)) -(defun remove* (cl-item cl-seq &rest cl-keys) - "Remove all occurrences of ITEM in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :test :test-not :key :count :start :end :from-end -The keywords :test and :test-not specify two-argument test and negated-test -predicates, respectively; :test defaults to `eql'. :key specifies a -one-argument function that transforms elements of SEQ into \"comparison keys\" -before the test predicate is applied. See `member*' for more information -on these keywords. -:start and :end, if given, specify indices of a subsequence of SEQ to -be processed. Indices are 0-based and processing involves the subsequence -starting at the index given by :start and ending just before the index -given by :end. -:count, if given, limits the number of items removed to the number specified. -:from-end, if given, causes processing to proceed starting from the end -instead of the beginning; in this case, this matters only if :count is given." - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end - (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) - cl-seq - (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) - (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end - cl-from-end))) - (if cl-i - (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) - (append (if cl-from-end - (list :end (1+ cl-i)) - (list :start cl-i)) - cl-keys)))) - (typecase cl-seq - (list cl-res) - (string (concat cl-res)) - (vector (vconcat cl-res)) - (bit-vector (bvconcat cl-res)))) - cl-seq)) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (if (= cl-start 0) - (while (and cl-seq (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) - (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) - (> (setq cl-count (1- cl-count)) 0)))) - (if (and (> cl-count 0) (> cl-end 0)) - (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) - (setq cl-end (1- cl-end)) (cdr cl-seq)))) - (while (and cl-p (> cl-end 0) - (not (cl-check-test cl-item (car cl-p)))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end))) - (if (and cl-p (> cl-end 0)) - (nconc (ldiff cl-seq cl-p) - (if (= cl-count 1) (cdr cl-p) - (and (cdr cl-p) - (apply 'delete* cl-item - (copy-sequence (cdr cl-p)) - :start 0 :end (1- cl-end) - :count (1- cl-count) cl-keys)))) - cl-seq)) - cl-seq))))) +(defun remove-if-not (cl-predicate cl-seq &rest cl-keys) + "Remove all items not satisfying PREDICATE in SEQUENCE. -(defun remove-if (cl-pred cl-list &rest cl-keys) - "Remove all items satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'remove* nil cl-list :if cl-pred cl-keys)) +This is a non-destructive function; it makes a copy of SEQUENCE if necessary +to avoid corrupting the original SEQUENCE. If SEQUENCE is a list, the copy +may share list structure with SEQUENCE. -(defun remove-if-not (cl-pred cl-list &rest cl-keys) - "Remove all items not satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'remove* nil cl-list :if-not cl-pred cl-keys)) +See `remove*' for the meaning of the keywords. -(defun delete* (cl-item cl-seq &rest cl-keys) - "Remove all occurrences of ITEM in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :test :test-not :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end - (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) - cl-seq - (if (listp cl-seq) - (if (and cl-from-end (< cl-count 4000000)) - (let (cl-i) - (while (and (>= (setq cl-count (1- cl-count)) 0) - (setq cl-i (cl-position cl-item cl-seq cl-start - cl-end cl-from-end))) - (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) - (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) - (setcdr cl-tail (cdr (cdr cl-tail))))) - (setq cl-end cl-i)) - cl-seq) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (if (= cl-start 0) - (progn - (while (and cl-seq - (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) - (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) - (> (setq cl-count (1- cl-count)) 0))) - (setq cl-end (1- cl-end))) - (setq cl-start (1- cl-start))) - (if (and (> cl-count 0) (> cl-end 0)) - (let ((cl-p (nthcdr cl-start cl-seq))) - (while (and (cdr cl-p) (> cl-end 0)) - (if (cl-check-test cl-item (car (cdr cl-p))) - (progn - (setcdr cl-p (cdr (cdr cl-p))) - (if (= (setq cl-count (1- cl-count)) 0) - (setq cl-end 1))) - (setq cl-p (cdr cl-p))) - (setq cl-end (1- cl-end))))) - cl-seq) - (apply 'remove* cl-item cl-seq cl-keys))))) +arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)" + (apply 'remove* 'remove* cl-seq :if-not cl-predicate cl-keys)) -(defun delete-if (cl-pred cl-list &rest cl-keys) - "Remove all items satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'delete* nil cl-list :if cl-pred cl-keys)) +(defun delete-if (cl-predicate cl-seq &rest cl-keys) + "Remove all items satisfying PREDICATE in SEQUENCE. -(defun delete-if-not (cl-pred cl-list &rest cl-keys) - "Remove all items not satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'delete* nil cl-list :if-not cl-pred cl-keys)) +This is a destructive function; if SEQUENCE is a list, it reuses its +storage. If SEQUENCE is an array and some element satisfies SEQUENCE, a +copy is always returned. -;; XEmacs change: this is in subr.el in GNU Emacs -(defun remove (cl-item cl-seq) - "Remove all occurrences of ITEM in SEQ, testing with `equal' -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Also see: `remove*', `delete', `delete*'" - (remove* cl-item cl-seq ':test 'equal)) +See `remove*' for the meaning of the keywords. -;; XEmacs change: this is in subr.el in GNU Emacs -(defun remq (cl-elt cl-list) - "Remove all occurrences of ELT in LIST, comparing with `eq'. -This is a non-destructive function; it makes a copy of LIST to avoid -corrupting the original LIST. -Also see: `delq', `delete', `delete*', `remove', `remove*'." - (if (memq cl-elt cl-list) - (delq cl-elt (copy-list cl-list)) - cl-list)) +arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)" + (apply 'delete* 'delete* cl-seq :if cl-predicate cl-keys)) -(defun remove-duplicates (cl-seq &rest cl-keys) - "Return a copy of SEQ with all duplicate elements removed. -Keywords supported: :test :test-not :key :start :end :from-end -See `remove*' for the meaning of the keywords." - (cl-delete-duplicates cl-seq cl-keys t)) +(defun delete-if-not (cl-predicate cl-seq &rest cl-keys) + "Remove all items not satisfying PREDICATE in SEQUENCE. -(defun delete-duplicates (cl-seq &rest cl-keys) - "Remove all duplicate elements from SEQ (destructively). -Keywords supported: :test :test-not :key :start :end :from-end -See `remove*' for the meaning of the keywords." - (cl-delete-duplicates cl-seq cl-keys nil)) +This is a destructive function; it reuses the storage of SEQUENCE whenever +possible. -(defun cl-delete-duplicates (cl-seq cl-keys cl-copy) - (if (listp cl-seq) - (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) - () - (if cl-from-end - (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) - (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) - (while (> cl-end 1) - (setq cl-i 0) - (while (setq cl-i (cl-position (cl-check-key (car cl-p)) - (cdr cl-p) cl-i (1- cl-end))) - (if cl-copy (setq cl-seq (copy-sequence cl-seq) - cl-p (nthcdr cl-start cl-seq) cl-copy nil)) - (let ((cl-tail (nthcdr cl-i cl-p))) - (setcdr cl-tail (cdr (cdr cl-tail)))) - (setq cl-end (1- cl-end))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end) - cl-start (1+ cl-start))) - cl-seq) - (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) - (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) - (cl-position (cl-check-key (car cl-seq)) - (cdr cl-seq) 0 (1- cl-end))) - (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) - (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) - (setq cl-end (1- cl-end) cl-start 1) cl-seq))) - (while (and (cdr (cdr cl-p)) (> cl-end 1)) - (if (cl-position (cl-check-key (car (cdr cl-p))) - (cdr (cdr cl-p)) 0 (1- cl-end)) - (progn - (if cl-copy (setq cl-seq (copy-sequence cl-seq) - cl-p (nthcdr (1- cl-start) cl-seq) - cl-copy nil)) - (setcdr cl-p (cdr (cdr cl-p)))) - (setq cl-p (cdr cl-p))) - (setq cl-end (1- cl-end) cl-start (1+ cl-start))) - cl-seq))) - (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) - (typecase cl-seq - (string (concat cl-res)) - (vector (vconcat cl-res)) - (bit-vector (bvconcat cl-res)))))) +See `remove*' for the meaning of the keywords. -(defun substitute (cl-new cl-old cl-seq &rest cl-keys) - "Substitute NEW for OLD in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :test :test-not :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (cl-parsing-keywords (:test :test-not :key :if :if-not :count - (:start 0) :end :from-end) () - (if (or (eq cl-old cl-new) - (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) - cl-seq - (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) - (if (not cl-i) - cl-seq - (setq cl-seq (copy-sequence cl-seq)) - (or cl-from-end - (progn (cl-set-elt cl-seq cl-i cl-new) - (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) - (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count - :start cl-i cl-keys)))))) +arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)" + (apply 'delete* 'delete* cl-seq :if-not cl-predicate cl-keys)) -(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -See `remove*' for the meaning of the keywords." - (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) +(defun substitute-if (cl-new cl-predicate cl-seq &rest cl-keys) + "Substitute NEW for all items satisfying PREDICATE in SEQUENCE. -(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items not satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -See `remove*' for the meaning of the keywords." - (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) +This is a non-destructive function; it makes a copy of SEQUENCE if necessary +to avoid corrupting the original SEQUENCE. -(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) - "Substitute NEW for OLD in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :test :test-not :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (cl-parsing-keywords (:test :test-not :key :if :if-not :count - (:start 0) :end :from-end) () - (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) - (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) - (let ((cl-p (nthcdr cl-start cl-seq))) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (while (and cl-p (> cl-end 0) (> cl-count 0)) - (if (cl-check-test cl-old (car cl-p)) - (progn - (setcar cl-p cl-new) - (setq cl-count (1- cl-count)))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) - (or cl-end (setq cl-end (length cl-seq))) - (if cl-from-end - (while (and (< cl-start cl-end) (> cl-count 0)) - (setq cl-end (1- cl-end)) - (if (cl-check-test cl-old (elt cl-seq cl-end)) - (progn - (cl-set-elt cl-seq cl-end cl-new) - (setq cl-count (1- cl-count))))) - (while (and (< cl-start cl-end) (> cl-count 0)) - (if (cl-check-test cl-old (aref cl-seq cl-start)) - (progn - (aset cl-seq cl-start cl-new) - (setq cl-count (1- cl-count)))) - (setq cl-start (1+ cl-start)))))) - cl-seq)) +See `remove*' for the meaning of the keywords. -(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) +arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)" + (apply 'substitute cl-new 'substitute cl-seq :if cl-predicate cl-keys)) -(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items not satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) +(defun substitute-if-not (cl-new cl-predicate cl-seq &rest cl-keys) + "Substitute NEW for all items not satisfying PREDICATE in SEQUENCE. -(defun find (cl-item cl-seq &rest cl-keys) - "Find the first occurrence of ITEM in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :test :test-not :key :start :end :from-end -See `remove*' for the meaning of the keywords." - (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) - (and cl-pos (elt cl-seq cl-pos)))) +This is a non-destructive function; it makes a copy of SEQUENCE if necessary +to avoid corrupting the original SEQUENCE. -(defun find-if (cl-pred cl-list &rest cl-keys) - "Find the first item satisfying PREDICATE in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :key :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'find nil cl-list :if cl-pred cl-keys)) +See `remove*' for the meaning of the keywords. -(defun find-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item not satisfying PREDICATE in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :key :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'find nil cl-list :if-not cl-pred cl-keys)) +arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)" + (apply 'substitute cl-new 'substitute cl-seq :if-not cl-predicate + cl-keys)) -(defun position (cl-item cl-seq &rest cl-keys) - "Find the first occurrence of ITEM in LIST. +(defun nsubstitute-if (cl-new cl-predicate cl-seq &rest cl-keys) + "Substitute NEW for all items satisfying PREDICATE in SEQUENCE. + +This is destructive function; it modifies SEQUENCE directly, never returning +a copy. See `substitute-if' for a non-destructive version. + +See `remove*' for the meaning of the keywords. + +arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)" + (apply 'nsubstitute cl-new 'nsubstitute cl-seq :if cl-predicate + cl-keys)) + +(defun nsubstitute-if-not (cl-new cl-predicate cl-seq &rest cl-keys) + "Substitute NEW for all items not satisfying PREDICATE in SEQUENCE. + +This is destructive function; it modifies SEQUENCE directly, never returning +a copy. See `substitute-if-not' for a non-destructive version. + +See `remove*' for the meaning of the keywords. + +arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)" + (apply 'nsubstitute cl-new 'nsubstitute cl-seq :if-not cl-predicate + cl-keys)) + +(defun find-if (cl-predicate cl-seq &rest cl-keys) + "Find the first item satisfying PREDICATE in SEQUENCE. + +Return the matching item, or DEFAULT (not a keyword specified for this +function by Common Lisp) if not found. + +See `remove*' for the meaning of the other keywords. + +arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END DEFAULT)" + (apply 'find 'find cl-seq :if cl-predicate cl-keys)) + +(defun find-if-not (cl-predicate cl-seq &rest cl-keys) + "Find the first item not satisfying PREDICATE in SEQUENCE. + +Return the matching ITEM, or DEFAULT (not a keyword specified for this +function by Common Lisp) if not found. + +See `remove*' for the meaning of the keywords. + +arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END DEFAULT)" + (apply 'find 'find cl-seq :if-not cl-predicate cl-keys)) + +(defun position-if (cl-predicate cl-seq &rest cl-keys) + "Find the first item satisfying PREDICATE in SEQUENCE. + Return the index of the matching item, or nil if not found. -Keywords supported: :test :test-not :key :start :end :from-end -See `remove*' for the meaning of the keywords." - (cl-parsing-keywords (:test :test-not :key :if :if-not - (:start 0) :end :from-end) () - (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) -(defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) - (if (listp cl-seq) - (let ((cl-p (nthcdr cl-start cl-seq))) - (or cl-end (setq cl-end 8000000)) - (let ((cl-res nil)) - (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) - (if (cl-check-test cl-item (car cl-p)) - (setq cl-res cl-start)) - (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) - cl-res)) - (or cl-end (setq cl-end (length cl-seq))) - (if cl-from-end - (progn - (while (and (>= (setq cl-end (1- cl-end)) cl-start) - (not (cl-check-test cl-item (aref cl-seq cl-end))))) - (and (>= cl-end cl-start) cl-end)) - (while (and (< cl-start cl-end) - (not (cl-check-test cl-item (aref cl-seq cl-start)))) - (setq cl-start (1+ cl-start))) - (and (< cl-start cl-end) cl-start)))) +See `remove*' for the meaning of the keywords. -(defun position-if (cl-pred cl-list &rest cl-keys) - "Find the first item satisfying PREDICATE in LIST. +arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)" + (apply 'position 'position cl-seq :if cl-predicate cl-keys)) + +(defun position-if-not (cl-predicate cl-seq &rest cl-keys) + "Find the first item not satisfying PREDICATE in SEQUENCE. + Return the index of the matching item, or nil if not found. -Keywords supported: :key :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'position nil cl-list :if cl-pred cl-keys)) -(defun position-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item not satisfying PREDICATE in LIST. -Return the index of the matching item, or nil if not found. -Keywords supported: :key :start :end :from-end -See `remove*' for the meaning of the keywords." - (apply 'position nil cl-list :if-not cl-pred cl-keys)) +See `remove*' for the meaning of the keywords. -(defun count (cl-item cl-seq &rest cl-keys) - "Count the number of occurrences of ITEM in LIST. -Keywords supported: :test :test-not :key :start :end -See `remove*' for the meaning of the keywords." - (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () - (let ((cl-count 0) cl-x) - (or cl-end (setq cl-end (length cl-seq))) - (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) - (while (< cl-start cl-end) - (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) - (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) - (setq cl-start (1+ cl-start))) - cl-count))) +arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)" + (apply 'position 'position cl-seq :if-not cl-predicate cl-keys)) -(defun count-if (cl-pred cl-list &rest cl-keys) - "Count the number of items satisfying PREDICATE in LIST. -Keywords supported: :key :start :end -See `remove*' for the meaning of the keywords." - (apply 'count nil cl-list :if cl-pred cl-keys)) +(defun count-if (cl-predicate cl-seq &rest cl-keys) + "Count the number of items satisfying PREDICATE in SEQUENCE. -(defun count-if-not (cl-pred cl-list &rest cl-keys) - "Count the number of items not satisfying PREDICATE in LIST. -Keywords supported: :key :start :end -See `remove*' for the meaning of the keywords." - (apply 'count nil cl-list :if-not cl-pred cl-keys)) +See `remove*' for the meaning of the keywords. -(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) - "Compare SEQ1 with SEQ2, return index of first mismatching element. -Return nil if the sequences match. If one sequence is a prefix of the -other, the return value indicates the end of the shorter sequence. -Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end -See `search' for the meaning of the keywords." - (cl-parsing-keywords (:test :test-not :key :from-end - (:start1 0) :end1 (:start2 0) :end2) () - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) - (if cl-from-end - (progn - (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (elt cl-seq1 (1- cl-end1)) - (elt cl-seq2 (1- cl-end2)))) - (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) - (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) - (1- cl-end1))) - (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) - (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) - (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (if cl-p1 (car cl-p1) - (aref cl-seq1 cl-start1)) - (if cl-p2 (car cl-p2) - (aref cl-seq2 cl-start2)))) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) - cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) - (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) - cl-start1))))) +arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)" + (apply 'count 'count cl-seq :if cl-predicate cl-keys)) -(defun search (cl-seq1 cl-seq2 &rest cl-keys) - "Search for SEQ1 as a subsequence of SEQ2. -Return the index of the leftmost element of the first match found; -return nil if there are no matches. -Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end -See `remove*' for the meaning of the keywords. In this case, :start1 and :end1 -specify a subsequence of SEQ1, and :start2 and :end2 specify a subsequence -of SEQ2." - (cl-parsing-keywords (:test :test-not :key :from-end - (:start1 0) :end1 (:start2 0) :end2) () - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) - (if (>= cl-start1 cl-end1) - (if cl-from-end cl-end2 cl-start2) - (let* ((cl-len (- cl-end1 cl-start1)) - (cl-first (cl-check-key (elt cl-seq1 cl-start1))) - (cl-if nil) cl-pos) - (setq cl-end2 (- cl-end2 (1- cl-len))) - (while (and (< cl-start2 cl-end2) - (setq cl-pos (cl-position cl-first cl-seq2 - cl-start2 cl-end2 cl-from-end)) - (apply 'mismatch cl-seq1 cl-seq2 - :start1 (1+ cl-start1) :end1 cl-end1 - :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) - :from-end nil cl-keys)) - (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) - (and (< cl-start2 cl-end2) cl-pos))))) +(defun count-if-not (cl-predicate cl-seq &rest cl-keys) + "Count the number of items not satisfying PREDICATE in SEQUENCE. -(defun stable-sort (cl-seq cl-pred &rest cl-keys) +See `remove*' for the meaning of the keywords. + +arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)" + (apply 'count 'count cl-seq :if-not cl-predicate cl-keys)) + +(defun stable-sort (cl-seq cl-predicate &rest cl-keys) "Sort the argument SEQUENCE stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQUENCE if possible. Keywords supported: :key ＠＠ -589,144 +237,52 ＠＠ into \"comparison keys\" before the test predicate is applied. See `member*' for more information. -arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY))" - (apply 'sort* cl-seq cl-pred cl-keys)) +arguments: (SEQUENCE PREDICATE &key (KEY #'identity))" + (apply 'sort* cl-seq cl-predicate cl-keys)) -;;; See compiler macro in cl-macs.el -(defun member* (cl-item cl-list &rest cl-keys) - "Find the first occurrence of ITEM in LIST. -Return the sublist of LIST whose car is ITEM. -Keywords supported: :test :test-not :key -The keyword :test specifies a two-argument function that is used to - compare ITEM with elements in LIST; if omitted, it defaults to `eql'. -The keyword :test-not is similar, but specifies a negated predicate. That - is, ITEM is considered equal to an element in LIST if the given predicate - returns nil. -:key specifies a one-argument function that transforms elements of LIST into -\"comparison keys\" before the test predicate is applied. For example, -if:key is #'car, then ITEM is compared with the car of elements from LIST1. -The:key function, however, is not applied to ITEM, and does not affect the -elements in the returned list, which are taken directly from the elements in -LIST." - (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) - (setq cl-list (cdr cl-list))) - cl-list) - (if (and (numberp cl-item) (not (fixnump cl-item))) - (member cl-item cl-list) - (memq cl-item cl-list)))) - -(defun member-if (cl-pred cl-list &rest cl-keys) +(defun member-if (cl-predicate cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'member* nil cl-list :if cl-pred cl-keys)) +See `member*' for the meaning of :key. -(defun member-if-not (cl-pred cl-list &rest cl-keys) +arguments: (PREDICATE LIST &key (KEY #'identity))" + (apply 'member* 'member* cl-list :if cl-predicate cl-keys)) + +(defun member-if-not (cl-predicate cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'member* nil cl-list :if-not cl-pred cl-keys)) +See `member*' for the meaning of :key. -(defun cl-adjoin (cl-item cl-list &rest cl-keys) - (if (cl-parsing-keywords (:key) t - (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) - cl-list - (cons cl-item cl-list))) +arguments: (PREDICATE LIST &key (KEY #'identity))" + (apply 'member* 'member* cl-list :if-not cl-predicate cl-keys)) -;;; See compiler macro in cl-macs.el -(defun assoc* (cl-item cl-alist &rest cl-keys) - "Find the first item whose car matches ITEM in LIST. -Keywords supported: :test :test-not :key -See `member*' for the meaning of :test, :test-not and :key." - (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-alist - (or (not (consp (car cl-alist))) - (not (cl-check-test cl-item (car (car cl-alist)))))) - (setq cl-alist (cdr cl-alist))) - (and cl-alist (car cl-alist))) - (if (and (numberp cl-item) (not (fixnump cl-item))) - (assoc cl-item cl-alist) - (assq cl-item cl-alist)))) +(defun assoc-if (cl-predicate cl-alist &rest cl-keys) + "Return the first item whose car satisfies PREDICATE in ALIST. +See `member*' for the meaning of :key. -(defun assoc-if (cl-pred cl-list &rest cl-keys) - "Find the first item whose car satisfies PREDICATE in LIST. -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'assoc* nil cl-list :if cl-pred cl-keys)) +arguments: (PREDICATE ALIST &key (KEY #'identity))" + (apply 'assoc* 'assoc* cl-alist :if cl-predicate cl-keys)) -(defun assoc-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item whose car does not satisfy PREDICATE in LIST. -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'assoc* nil cl-list :if-not cl-pred cl-keys)) +(defun assoc-if-not (cl-predicate cl-alist &rest cl-keys) + "Return the first item whose car does not satisfy PREDICATE in ALIST. +See `member*' for the meaning of :key. -(defun rassoc* (cl-item cl-alist &rest cl-keys) - "Find the first item whose cdr matches ITEM in LIST. -Keywords supported: :test :test-not :key -See `member*' for the meaning of :test, :test-not and :key." - (if (or cl-keys (and (numberp cl-item) (not (fixnump cl-item)))) - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-alist - (or (not (consp (car cl-alist))) - (not (cl-check-test cl-item (cdr (car cl-alist)))))) - (setq cl-alist (cdr cl-alist))) - (and cl-alist (car cl-alist))) - (rassq cl-item cl-alist))) +arguments: (PREDICATE ALIST &key (KEY #'identity))" + (apply 'assoc* 'assoc* cl-alist :if-not cl-predicate cl-keys)) -(defun rassoc-if (cl-pred cl-list &rest cl-keys) - "Find the first item whose cdr satisfies PREDICATE in LIST. -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'rassoc* nil cl-list :if cl-pred cl-keys)) +(defun rassoc-if (cl-predicate cl-alist &rest cl-keys) + "Return the first item whose cdr satisfies PREDICATE in ALIST. +See `member*' for the meaning of :key. -(defun rassoc-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item whose cdr does not satisfy PREDICATE in LIST. -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys)) +arguments: (PREDICATE ALIST &key (KEY #'identity))" + (apply 'rassoc* 'rassoc* cl-alist :if cl-predicate cl-keys)) -(defun union (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-union operation. -The result list contains all items that appear in either LIST1 or LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key -The keywords :test and :test-not specify two-argument test and negated-test -predicates, respectively; :test defaults to `eql'. see `member*' for more -information. -:key specifies a one-argument function that transforms elements of LIST1 -and LIST2 into \"comparison keys\" before the test predicate is applied. -For example, if :key is #'car, then the car of elements from LIST1 is -compared with the car of elements from LIST2. The :key function, however, -does not affect the elements in the returned list, which are taken directly -from the elements in LIST1 and LIST2." - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) cl-list1) - (t - (or (>= (length cl-list1) (length cl-list2)) - (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) - (while cl-list2 - (if (or cl-keys (numberp (car cl-list2))) - (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) - (or (memq (car cl-list2) cl-list1) - (push (car cl-list2) cl-list1))) - (pop cl-list2)) - cl-list1))) +(defun rassoc-if-not (cl-predicate cl-alist &rest cl-keys) + "Return the first item whose cdr does not satisfy PREDICATE in ALIST. +See `member*' for the meaning of :key. -(defun nunion (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-union operation. -The result list contains all items that appear in either LIST1 or LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - (t (apply 'union cl-list1 cl-list2 cl-keys)))) +arguments: (PREDICATE ALIST &key (KEY #'identity))" + (apply 'rassoc* 'rassoc* cl-alist :if-not cl-predicate cl-keys)) ;; XEmacs addition: NOT IN COMMON LISP. (defun stable-union (cl-list1 cl-list2 &rest cl-keys) ＠＠ -736,257 +292,90 ＠＠ LIST1 and LIST2. The result specifically consists of the elements in LIST1 in order, followed by any elements in LIST2 that are not also in LIST1, in the order given in LIST2. + This is a non-destructive function; it makes a copy of the data if necessary to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key + See `union' for the meaning of :test, :test-not and :key. NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs -extension." +extension. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)" ;; The standard `union' doesn't produce a "stable" union -- ;; it iterates over the second list instead of the first one, and returns ;; the values in backwards order. According to the CLTL2 documentation, ;; `union' is not required to preserve the ordering of elements in ;; any fashion, so we add a new function rather than changing the ;; semantics of `union'. - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) cl-list1) - (t - (append - cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) - (loop for cl-l in cl-list2 - if (not (if (or cl-keys (numberp cl-l)) - (apply 'member* (cl-check-key cl-l) - cl-list1 cl-keys) - (memq cl-l cl-list1))) - collect cl-l)))))) - -(defun intersection (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-intersection operation. -The result list contains all items that appear in both LIST1 and LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (and cl-list1 cl-list2 - (if (equal cl-list1 cl-list2) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) - (let ((cl-res nil)) - (or (>= (length cl-list1) (length cl-list2)) - (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) - (while cl-list2 - (if (if (or cl-keys (numberp (car cl-list2))) - (apply 'member* (cl-check-key (car cl-list2)) - cl-list1 cl-keys) - (memq (car cl-list2) cl-list1)) - (push (car cl-list2) cl-res)) - (pop cl-list2)) - cl-res))))) - -(defun nintersection (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-intersection operation. -The result list contains all items that appear in both LIST1 and LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) + (apply 'union cl-list1 cl-list2 :stable t cl-keys)) ;; XEmacs addition: NOT IN COMMON LISP. (defun stable-intersection (cl-list1 cl-list2 &rest cl-keys) "Stably combine LIST1 and LIST2 using a set-intersection operation. + The result list contains all items that appear in both LIST1 and LIST2. The result is \"stable\" in that it preserves the ordering of elements in LIST1 that are also in LIST2. + This is a non-destructive function; it makes a copy of the data if necessary to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key + See `union' for the meaning of :test, :test-not and :key. NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs -extension." +extension. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)" ;; The standard `intersection' doesn't produce a "stable" intersection -- ;; it iterates over the second list instead of the first one, and returns ;; the values in backwards order. According to the CLTL2 documentation, ;; `intersection' is not required to preserve the ordering of elements in - ;; any fashion, so we add a new function rather than changing the - ;; semantics of `intersection'. - (and cl-list1 cl-list2 - (if (equal cl-list1 cl-list2) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) - (loop for cl-l in cl-list1 - if (if (or cl-keys (numberp cl-l)) - (apply 'member* (cl-check-key cl-l) - cl-list2 cl-keys) - (memq cl-l cl-list2)) - collect cl-l))))) + ;; any fashion, but it's trivial to implement a stable ordering in C, + ;; given that the order of arguments to the test function is specified. + (apply 'intersection cl-list1 cl-list2 :stable t cl-keys)) -(defun set-difference (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-difference operation. -The result list contains all items that appear in LIST1 but not LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) - (let ((cl-res nil)) - (while cl-list1 - (or (if (or cl-keys (numberp (car cl-list1))) - (apply 'member* (cl-check-key (car cl-list1)) - cl-list2 cl-keys) - (memq (car cl-list1) cl-list2)) - (push (car cl-list1) cl-res)) - (pop cl-list1)) - cl-res)))) +(defun subst-if (cl-new cl-predicate cl-tree &rest cl-keys) + "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). -(defun nset-difference (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-difference operation. -The result list contains all items that appear in LIST1 but not LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (apply 'set-difference cl-list1 cl-list2 cl-keys))) +Return a copy of TREE with all matching elements replaced by NEW. If no +element matches PREDICATE, return tree. -(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-exclusive-or operation. -The result list contains all items that appear in exactly one of LIST1, LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) nil) - (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) - (apply 'set-difference cl-list2 cl-list1 cl-keys))))) +See `member*' for the meaning of :key. -(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-exclusive-or operation. -The result list contains all items that appear in exactly one of LIST1, LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) nil) - (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) - (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) +arguments: (NEW PREDICATE TREE &key (KEY #'identity))" + (apply 'subst cl-new 'subst cl-tree :if cl-predicate cl-keys)) -(defun subsetp (cl-list1 cl-list2 &rest cl-keys) - "True if LIST1 is a subset of LIST2. -I.e., if every element of LIST1 also appears in LIST2. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (cond ((null cl-list1) t) ((null cl-list2) nil) - ((equal cl-list1 cl-list2) t) - (t (cl-parsing-keywords (:key) (:test :test-not) - (while (and cl-list1 - (apply 'member* (cl-check-key (car cl-list1)) - cl-list2 cl-keys)) - (pop cl-list1)) - (null cl-list1))))) +(defun subst-if-not (cl-new cl-predicate cl-tree &rest cl-keys) + "Substitute NEW for elements not matching PREDICATE in TREE. -(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). -Return a copy of TREE with all matching elements replaced by NEW. -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) +Return a copy of TREE with all matching elements replaced by NEW. If every +element matches PREDICATE, return tree. -(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). -Return a copy of TREE with all non-matching elements replaced by NEW. -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) +See `member*' for the meaning of :key. -(defun nsubst (cl-new cl-old cl-tree &rest cl-keys) - "Substitute NEW for OLD everywhere in TREE (destructively). -Any element of TREE which is `eql' to OLD is changed to NEW (via a call -to `setcar'). -Keywords supported: :test :test-not :key -See `member*' for the meaning of :test, :test-not and :key." - (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) +arguments: (NEW PREDICATE TREE &key (KEY #'identity))" + (apply 'subst cl-new 'subst cl-tree :if-not cl-predicate cl-keys)) -(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) +(defun nsubst-if (cl-new cl-predicate cl-tree &rest cl-keys) "Substitute NEW for elements matching PREDICATE in TREE (destructively). + Any element of TREE which matches is changed to NEW (via a call to `setcar'). -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) -(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) +See `member*' for the meaning of :key. + +arguments: (NEW PREDICATE TREE &key (KEY #'identity))" + (apply 'nsubst cl-new 'nsubst cl-tree :if cl-predicate cl-keys)) + +(defun nsubst-if-not (cl-new cl-predicate cl-tree &rest cl-keys) "Substitute NEW for elements not matching PREDICATE in TREE (destructively). + Any element of TREE which matches is changed to NEW (via a call to `setcar'). -Keywords supported: :key -See `member*' for the meaning of :key." - (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) -(defun sublis (cl-alist cl-tree &rest cl-keys) - "Perform substitutions indicated by ALIST in TREE (non-destructively). -Return a copy of TREE with all matching elements replaced. -Keywords supported: :test :test-not :key -See `member*' for the meaning of :test, :test-not and :key." - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (cl-sublis-rec cl-tree))) +See `member*' for the meaning of :key. -(defvar cl-alist) -(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* - (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p (cdr (car cl-p)) - (if (consp cl-tree) - (let ((cl-a (cl-sublis-rec (car cl-tree))) - (cl-d (cl-sublis-rec (cdr cl-tree)))) - (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) - cl-tree - (cons cl-a cl-d))) - cl-tree)))) - -(defun nsublis (cl-alist cl-tree &rest cl-keys) - "Perform substitutions indicated by ALIST in TREE (destructively). -Any matching element of TREE is changed via a call to `setcar'. -Keywords supported: :test :test-not :key -See `member*' for the meaning of :test, :test-not and :key." - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (let ((cl-hold (list cl-tree))) - (cl-nsublis-rec cl-hold) - (car cl-hold)))) - -(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* - (while (consp cl-tree) - (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p (setcar cl-tree (cdr (car cl-p))) - (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) - (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p - (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) - (setq cl-tree (cdr cl-tree)))))) - -(defun tree-equal (cl-x cl-y &rest cl-keys) - "Return t if trees X and Y have `eql' leaves. -Atoms are compared by `eql'; cons cells are compared recursively. -Keywords supported: :test :test-not :key -See `union' for the meaning of :test, :test-not and :key." - (cl-parsing-keywords (:test :test-not :key) () - (cl-tree-equal-rec cl-x cl-y))) - -(defun cl-tree-equal-rec (cl-x cl-y) - (while (and (consp cl-x) (consp cl-y) - (cl-tree-equal-rec (car cl-x) (car cl-y))) - (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) - (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) - - -(run-hooks 'cl-seq-load-hook) +arguments: (NEW PREDICATE TREE &key (KEY #'identity))" + (apply 'nsubst cl-new 'nsubst cl-tree :if-not cl-predicate cl-keys)) ;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c ;;; cl-seq.el ends here diff -r f87bb35a6b94 -r d1b17a33450b lisp/cl.el --- a/lisp/cl.el Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/cl.el Thu Dec 30 01:59:52 2010 +0000 ＠＠ -557,36 +557,6 ＠＠ (defalias 'cl-round 'round*) (defalias 'cl-mod 'mod*) -(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs - "Return ITEM consed onto the front of LIST only if it's not already there. -Otherwise, return LIST unmodified. -Keywords supported: :test :test-not :key -See `member*' for the meaning of :test, :test-not and :key." - (cond ((or (equal cl-keys '(:test eq)) - (and (null cl-keys) (not (numberp cl-item)))) - (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) - ((or (equal cl-keys '(:test equal)) (null cl-keys)) - (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) - (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) - -(defun subst (cl-new cl-old cl-tree &rest cl-keys) - "Substitute NEW for OLD everywhere in TREE (non-destructively). -Return a copy of TREE with all elements `eql' to OLD replaced by NEW. -Keywords supported: :test :test-not :key -See `member*' for the meaning of :test, :test-not and :key." - (if (or cl-keys (and (numberp cl-old) (not (fixnump cl-old)))) - (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys) - (cl-do-subst cl-new cl-old cl-tree))) - -(defun cl-do-subst (cl-new cl-old cl-tree) - (cond ((eq cl-tree cl-old) cl-new) - ((consp cl-tree) - (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) - (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) - (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) - cl-tree (cons a d)))) - (t cl-tree))) - (defun acons (key value alist) "Return a new alist created by adding (KEY . VALUE) to ALIST." (cons (cons key value) alist)) diff -r f87bb35a6b94 -r d1b17a33450b lisp/obsolete.el --- a/lisp/obsolete.el Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/obsolete.el Thu Dec 30 01:59:52 2010 +0000 ＠＠ -244,6 +244,15 ＠＠ (define-compatible-function-alias 'cl-mapc 'mapc) +;; 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 +;; 12:06:41 IST 2010 +(defun cl-delete-duplicates (cl-seq cl-keys cl-copy) + (apply (if cl-copy #'remove-duplicates #'delete-duplicates) cl-seq cl-keys)) + +(make-obsolete 'cl-delete-duplicates 'delete-duplicates) + ; old names (define-compatible-function-alias 'byte-code-function-p 'compiled-function-p) ;FSFmacs ＠＠ -433,5 +442,8 ＠＠ (define-compatible-function-alias 'process-plist 'object-plist) (define-compatible-function-alias 'set-process-plist 'object-setplist) +(define-function 'memql 'member*) +(make-compatible 'memql "use the more full-featured `member*' instead.") + (provide 'obsolete) ;;; obsolete.el ends here diff -r f87bb35a6b94 -r d1b17a33450b lisp/subr.el --- a/lisp/subr.el Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/subr.el Thu Dec 30 01:59:52 2010 +0000 ＠＠ -226,6 +226,9 ＠＠ ;; XEmacs; this is in Lisp, its bytecode now taken by subseq. (define-function 'substring 'subseq) + +(define-function 'sort 'sort*) +(define-function 'fillarray 'fill) ;; XEmacs: (defun local-variable-if-set-p (sym buffer) ＠＠ -1104,13 +1107,13 ＠＠ "Replace the variable names in MAP-PLIST-DEFINITION with uninterned symbols, avoiding the risk of interference with variables in other functions introduced by dynamic scope." - (if-fboundp 'nsublis - (nsublis - '((mp-function . #:function) - (plist . #:plist) - (result . #:result)) - map-plist-definition) - map-plist-definition))) + (nsublis '((mp-function . #:function) + (plist . #:plist) + (result . #:result)) + ;; Need to specify #'eq as the test, otherwise we have a + ;; bootstrap issue, since #'eql is in cl.el, loaded after + ;; this file. + map-plist-definition :test #'eq))) (defun map-plist (mp-function plist) "Map FUNCTION (a function of two args) over each key/value pair in PLIST. Return a list of the results." diff -r f87bb35a6b94 -r d1b17a33450b src/ChangeLog --- a/src/ChangeLog Thu Dec 30 01:14:13 2010 +0000 +++ b/src/ChangeLog Thu Dec 30 01:59:52 2010 +0000 ＠＠ -1,3 +1,50 ＠＠ +2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> + + Move the heavy lifting from cl-seq.el to C, finally making those + functions first-class XEmacs citizens, with circularity checking, + built-in support for tests other than #'eql, and as much + compatibility with current Common Lisp as Paul Dietz' tests require. + + * fns.c (check_eq_nokey, check_eq_key, check_eql_nokey) + (check_eql_key, check_equal_nokey, check_equal_key) + (check_equalp_nokey, check_equalp_key, check_string_match_nokey) + (check_string_match_key, check_other_nokey, check_other_key) + (check_if_nokey, check_if_key, check_match_eq_key) + (check_match_eql_key, check_match_equal_key) + (check_match_equalp_key, check_match_other_key): New. These are + basically to provide function pointers to be used by Lisp + functions that take TEST, TEST-NOT and KEY arguments. + + (get_check_match_function_1, get_check_test_function) + (get_check_match_function): These functions work out which of the + previous list of functions to use, given the keywords supplied by + the user. + + (count_with_tail): New. This is the bones of #'count. + (list_count_from_end, string_count_from_end): Utility functions + for #'count. + (Fcount): New, moved from cl-seq.el. + (list_position_cons_before): New. The implementation of #'member*, + and important in implementing various other functions. + + (FmemberX, Fadjoin, FassocX, FrassocX, Fposition, Ffind) + (FdeleteX, FremoveX, Fdelete_duplicates, Fremove_duplicates) + (Fnsubstitute, Fsubstitute, Fsublis, Fnsublis, Fsubst, Fnsubst) + (Ftree_equal, Fmismatch, Fsearch, Fintersection, Fnintersection) + (Fsubsetp, Fset_difference, Fnset_difference, Fnunion, Funion) + (Fset_exclusive_or, Fnset_exclusive_or): New, moved here from + cl-seq.el. + + (position): New. The implementation of #'find and #'position. + (list_delete_duplicates_from_end, subst, sublis, nsublis) + (tree_equal, mismatch_from_end, mismatch_list_list) + (mismatch_list_string, mismatch_list_array) + (mismatch_string_array, mismatch_string_string) + (mismatch_array_array, get_mismatch_func): Helper C functions for + the Lisp-visible functions. + (venn, nvenn): New. The implementation of the main Lisp functions that + treat lists as sets. + 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> * lisp.h (DECLARE_N_KEYWORDS_8, DECLARE_N_KEYWORDS_9) diff -r f87bb35a6b94 -r d1b17a33450b src/fns.c --- a/src/fns.c Thu Dec 30 01:14:13 2010 +0000 +++ b/src/fns.c Thu Dec 30 01:59:52 2010 +0000 ＠＠ -54,17 +54,24 ＠＠ /* NOTE: This symbol is also used in lread.c */ #define FEATUREP_SYNTAX -Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill, Qreplace; -Lisp_Object Qidentity; +Lisp_Object Qstring_lessp, Qmerge, Qfill, Qreplace, QassocX, QrassocX; +Lisp_Object Qposition, Qfind, QdeleteX, QremoveX, Qidentity, Qadjoin; Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value; Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into; -Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce; -Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2; +Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce, Qsubstitute; +Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable; +Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch; + +Lisp_Object Qintersection, Qnintersection, Qset_difference, Qnset_difference; +Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qnset_difference; Lisp_Object Qbase64_conversion_error; Lisp_Object Vpath_separator; +extern Fixnum max_lisp_eval_depth; +extern int lisp_eval_depth; + static int internal_old_equal (Lisp_Object, Lisp_Object, int); Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth); ＠＠ -199,6 +206,445 ＠＠ bit_vector_description, size_bit_vector, Lisp_Bit_Vector); + +/* Various test functions for #'member*, #'assoc* and the other functions + that take both TEST and KEY arguments. */ + +typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key, + Lisp_Object item, Lisp_Object elt); + +static Boolint +check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + return EQ (item, elt); +} + +static Boolint +check_eq_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item, + Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return EQ (item, elt); +} + +/* The next two are not used by #'member* and #'assoc*, since we can decide + on #'eq vs. #'equal when we have the type of ITEM. */ +static Boolint +check_eql_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object elt1, Lisp_Object elt2) +{ + return EQ (elt1, elt2) + || (NON_FIXNUM_NUMBER_P (elt1) && internal_equal (elt1, elt2, 0)); +} + +static Boolint +check_eql_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item, + Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return EQ (item, elt) + || (NON_FIXNUM_NUMBER_P (item) && internal_equal (item, elt, 0)); +} + +static Boolint +check_equal_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + return internal_equal (item, elt, 0); +} + +static Boolint +check_equal_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item, + Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return internal_equal (item, elt, 0); +} + +static Boolint +check_equalp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + return internal_equalp (item, elt, 0); +} + +static Boolint +check_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object item, Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return internal_equalp (item, elt, 0); +} + +static Boolint +check_string_match_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + return !NILP (Fstring_match (item, elt, Qnil, Qnil)); +} + +static Boolint +check_string_match_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object item, Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return !NILP (Fstring_match (item, elt, Qnil, Qnil)); +} + +static Boolint +check_other_nokey (Lisp_Object test, Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + Lisp_Object args[] = { test, item, elt }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !NILP (item); +} + +static Boolint +check_other_key (Lisp_Object test, Lisp_Object key, + Lisp_Object item, Lisp_Object elt) +{ + Lisp_Object args[] = { item, key, elt }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args) - 1, args + 1)); + args[1] = item; + args[0] = test; + item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !NILP (item); +} + +static Boolint +check_if_nokey (Lisp_Object test, Lisp_Object UNUSED (key), + Lisp_Object UNUSED (item), Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (test, elt)); + return !NILP (elt); +} + +static Boolint +check_if_key (Lisp_Object test, Lisp_Object key, + Lisp_Object UNUSED (item), Lisp_Object elt) +{ + Lisp_Object args[] = { key, elt }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + args[0] = test; + elt = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !NILP (elt); +} + +static Boolint +check_match_eq_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return EQ (args[0], args[1]); +} + +static Boolint +check_match_eql_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return EQ (args[0], args[1]) || + (NON_FIXNUM_NUMBER_P (args[0]) && internal_equal (args[0], args[1], 0)); +} + +static Boolint +check_match_equal_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return internal_equal (args[0], args[1], 0); +} + +static Boolint +check_match_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return internal_equalp (args[0], args[1], 0); +} + +static Boolint +check_match_other_key (Lisp_Object test, Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + args[1] = args[0]; + args[0] = test; + + elt1 = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !NILP (elt1); +} + +static check_test_func_t +get_check_match_function_1 (Lisp_Object item, + Lisp_Object *test_inout, Lisp_Object test_not, + Lisp_Object if_, Lisp_Object if_not, + Lisp_Object key, Boolint *test_not_unboundp_out, + check_test_func_t *test_func_out) +{ + Lisp_Object test = *test_inout; + check_test_func_t result = NULL, test_func = NULL; + Boolint force_if = 0; + + if (!NILP (if_)) + { + if (!(NILP (test) && NILP (test_not) && NILP (if_not))) + { + invalid_argument ("only one keyword among :test :test-not " + ":if :if-not allowed", if_); + } + + test = *test_inout = if_; + force_if = 1; + } + else if (!NILP (if_not)) + { + if (!(NILP (test) && NILP (test_not))) + { + invalid_argument ("only one keyword among :test :test-not " + ":if :if-not allowed", if_not); + } + + test_not = if_not; + force_if = 1; + } + + if (NILP (test)) + { + if (!NILP (test_not)) + { + test = *test_inout = test_not; + if (NULL != test_not_unboundp_out) + { + *test_not_unboundp_out = 0; + } + } + else + { + test = Qeql; + if (NULL != test_not_unboundp_out) + { + *test_not_unboundp_out = 1; + } + } + } + else if (!NILP (test_not)) + { + invalid_argument_2 ("conflicting :test and :test-not keyword arguments", + test, test_not); + } + + test = indirect_function (test, 1); + + if (NILP (key) || + EQ (indirect_function (key, 1), XSYMBOL_FUNCTION (Qidentity))) + { + key = Qidentity; + } + + if (force_if) + { + result = EQ (key, Qidentity) ? check_if_nokey : check_if_key; + + if (NULL != test_func_out) + { + *test_func_out = result; + } + + return result; + } + + if (!UNBOUNDP (item) && EQ (test, XSYMBOL_FUNCTION (Qeql))) + { + test = XSYMBOL_FUNCTION (NON_FIXNUM_NUMBER_P (item) ? Qequal : Qeq); + } + +#define FROB(known_test, eq_condition) \ + if (EQ (test, XSYMBOL_FUNCTION (Q##known_test))) do \ + { \ + if (eq_condition) \ + { \ + test = XSYMBOL_FUNCTION (Qeq); \ + goto force_eq_check; \ + } \ + \ + if (!EQ (Qidentity, key)) \ + { \ + test_func = check_##known_test##_key; \ + result = check_match_##known_test##_key; \ + } \ + else \ + { \ + result = test_func = check_##known_test##_nokey; \ + } \ + } while (0) + + FROB (eql, 0); + else if (SUBRP (test)) + { + force_eq_check: + FROB (eq, 0); + else FROB (equal, (SYMBOLP (item) || INTP (item) || CHARP (item))); + else FROB (equalp, (SYMBOLP (item))); + else if (EQ (test, XSYMBOL_FUNCTION (Qstring_match))) + { + if (EQ (Qidentity, key)) + { + test_func = result = check_string_match_nokey; + } + else + { + test_func = check_string_match_key; + result = check_other_key; + } + } + } + + if (NULL == result) + { + if (EQ (Qidentity, key)) + { + test_func = result = check_other_nokey; + } + else + { + test_func = check_other_key; + result = check_match_other_key; + } + } + + if (NULL != test_func_out) + { + *test_func_out = test_func; + } + + return result; +} +#undef FROB + +/* Given TEST, TEST_NOT, IF, IF_NOT, KEY, and ITEM, return a C function + pointer appropriate for use in deciding whether a given element of a + sequence satisfies TEST. + + Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero + if it was bound, and set *test_inout to the value it was bound to. If + TEST was not bound, leave *test_inout alone; the value is not used by + check_eq_*key() or check_equal_*key(), which are the defaults, depending + on the type of ITEM. + + The returned function takes arguments (TEST, KEY, ITEM, ELT), where ITEM + is the item being searched for and ELT is the element of the sequence + being examined. + + Error if both TEST and TEST_NOT were specified, which Common Lisp says is + undefined behaviour. */ + +static check_test_func_t +get_check_test_function (Lisp_Object item, + Lisp_Object *test_inout, Lisp_Object test_not, + Lisp_Object if_, Lisp_Object if_not, + Lisp_Object key, Boolint *test_not_unboundp_out) +{ + check_test_func_t result = NULL; + get_check_match_function_1 (item, test_inout, test_not, if_, if_not, + key, test_not_unboundp_out, &result); + return result; +} + +/* Given TEST, TEST_NOT, IF, IF_NOT and KEY, return a C function pointer + appropriate for use in deciding whether two given elements of a sequence + satisfy TEST. + + Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero + if it was bound, and set *test_inout to the value it was bound to. If + TEST was not bound, leave *test_inout alone; the value is not used by + check_eql_*key(). + + The returned function takes arguments (TEST, KEY, ELT1, ELT2), where ELT1 + and ELT2 are elements of the sequence being examined. + + The value that would be given by get_check_test_function() is returned in + *TEST_FUNC_OUT, which allows calling functions to do their own key checks + if they're processing one element at a time. + + Error if both TEST and TEST_NOT were specified, which Common Lisp says is + undefined behaviour. */ + +static check_test_func_t +get_check_match_function (Lisp_Object *test_inout, Lisp_Object test_not, + Lisp_Object if_, Lisp_Object if_not, + Lisp_Object key, Boolint *test_not_unboundp_out, + check_test_func_t *test_func_out) +{ + return get_check_match_function_1 (Qunbound, test_inout, test_not, + if_, if_not, key, + test_not_unboundp_out, test_func_out); +} DEFUN ("identity", Fidentity, 1, 1, 0, /* ＠＠ -366,7 +812,316 ＠＠ return EQ (hare, tortoise) && len != 0 ? Qnil : make_int (len); } - + +static Lisp_Object string_count_from_end (Lisp_Object, Lisp_Object , + check_test_func_t, Boolint, + Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); + +static Lisp_Object list_count_from_end (Lisp_Object, Lisp_Object, + check_test_func_t, Boolint, + Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); + +/* Count the number of occurrences of ITEM in SEQUENCE; if SEQUENCE is a + list, store the cons cell of which the car is the last ITEM in SEQUENCE, + at the address given by tail_out. */ + +static Lisp_Object +count_with_tail (Lisp_Object *tail_out, int nargs, Lisp_Object *args, + Lisp_Object caller) +{ + Lisp_Object item = args[0], sequence = args[1]; + Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0; + Elemcount len, ii = 0, counting = EMACS_INT_MAX; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS_8 (caller, nargs, args, 9, + (test, key, start, end, from_end, test_not, count, + if_, if_not), (start = Qzero), 2, 0); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end); + } + + if (!NILP (count)) + { + CHECK_INTEGER (count); + counting = BIGNUMP (count) ? EMACS_INT_MAX + 1 : XINT (count); + + /* Our callers should have filtered out non-positive COUNT. */ + assert (counting >= 0); + /* And we're not prepared to handle COUNT from any other caller at the + moment. */ + assert (EQ (caller, QremoveX)); + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + *tail_out = Qnil; + + 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)) + { + /* #'count, #'count-if, and #'count-if-not are documented to have + a given traversal order if :from-end t is passed in, even + though forward traversal of the sequence has the same result + and is algorithmically less expensive for lists and strings. + This order isn't necessary for other callers, though. */ + return list_count_from_end (item, sequence, check_test, + test_not_unboundp, test, key, + 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 + count_with_tail(), our callers will return immediately on seeing + it). */ + if (!NILP (count) && !NILP (from_end)) + { + counting = EMACS_INT_MAX; + } + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + { + if (!(ii < ending)) + { + break; + } + + if (starting <= ii && + check_test (test, key, item, elt) == test_not_unboundp) + { + encountered++; + *tail_out = tail; + + if (encountered == counting) + { + break; + } + } + + ii++; + } + } + + UNGCPRO; + + if ((ii < starting || (ii < ending && !NILP (end))) && + encountered != counting) + { + check_sequence_range (args[1], start, end, Flength (args[1])); + } + } + else if (STRINGP (sequence)) + { + Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp; + Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0; + Lisp_Object character = Qnil; + + if (EQ (caller, Qcount) && !NILP (from_end) + && (!EQ (key, Qnil) || + check_test == check_other_nokey || check_test == check_if_nokey)) + { + /* See comment above in the list code. */ + return string_count_from_end (item, sequence, + check_test, test_not_unboundp, + test, key, start, end); + } + + while (cursor_offset < byte_len && ii < ending && encountered < counting) + { + if (ii >= starting) + { + character = make_char (itext_ichar (cursor)); + + if (check_test (test, key, item, character) + == test_not_unboundp) + { + encountered++; + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (caller, sequence); + } + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + } + else + { + Lisp_Object object = Qnil; + + len = XINT (Flength (sequence)); + check_sequence_range (sequence, start, end, make_int (len)); + + ending = min (ending, len); + if (0 == len) + { + /* Catches the case where we have nil. */ + return make_integer (encountered); + } + + if (NILP (from_end)) + { + for (ii = starting; ii < ending && encountered < counting; ii++) + { + object = Faref (sequence, make_int (ii)); + if (check_test (test, key, item, object) == test_not_unboundp) + { + encountered++; + } + } + } + else + { + for (ii = ending - 1; ii >= starting && encountered < counting; ii--) + { + object = Faref (sequence, make_int (ii)); + if (check_test (test, key, item, object) == test_not_unboundp) + { + encountered++; + } + } + } + } + + return make_integer (encountered); +} + +static Lisp_Object +list_count_from_end (Lisp_Object item, Lisp_Object sequence, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Lisp_Object start, Lisp_Object end) +{ + Elemcount length = XINT (Flength (sequence)), ii = 0, starting = XINT (start); + Elemcount ending = NILP (end) ? length : XINT (end), encountered = 0; + Lisp_Object *storage; + struct gcpro gcpro1; + + check_sequence_range (sequence, start, end, make_integer (length)); + + storage = alloca_array (Lisp_Object, ending - starting); + + { + EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + if (starting <= ii && ii < ending) + { + storage[ii - starting] = elt; + } + ii++; + } + } + + GCPRO1 (storage[0]); + gcpro1.nvars = ending - starting; + + for (ii = ending - 1; ii >= starting; ii--) + { + if (check_test (test, key, item, storage[ii - starting]) + == test_not_unboundp) + { + encountered++; + } + } + + UNGCPRO; + + return make_integer (encountered); +} + +static Lisp_Object +string_count_from_end (Lisp_Object item, Lisp_Object sequence, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Lisp_Object start, Lisp_Object end) +{ + Elemcount length = string_char_length (sequence), ii = 0; + Elemcount starting = XINT (start), ending = NILP (end) ? length : XINT (end); + Elemcount encountered = 0; + Ibyte *cursor = XSTRING_DATA (sequence); + Ibyte *endp = cursor + XSTRING_LENGTH (sequence); + Ichar *storage; + + check_sequence_range (sequence, start, end, make_integer (length)); + + storage = alloca_array (Ichar, ending - starting); + + while (cursor < endp && ii < ending) + { + if (starting <= ii && ii < ending) + { + storage [ii - starting] = itext_ichar (cursor); + } + + ii++; + INC_IBYTEPTR (cursor); + } + + for (ii = ending - 1; ii >= starting; ii--) + { + if (check_test (test, key, item, make_char (storage [ii - starting])) + == test_not_unboundp) + { + encountered++; + } + } + + return make_integer (encountered); +} + +DEFUN ("count", Fcount, 2, MANY, 0, /* +Count the number of occurrences of ITEM in SEQUENCE. + +See `remove*' for the meaning of the keywords. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object tail = Qnil; + + /* count_with_tail() accepts more keywords than we do, check those we've + been given. */ + PARSE_KEYWORDS (Fcount, nargs, args, 8, + (test, test_not, if_, if_not, key, start, end, from_end), + NULL); + + return count_with_tail (&tail, nargs, args, Qcount); +} + /*** string functions. ***/ DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /* ＠＠ -1002,7 +1757,7 ＠＠ Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth) { - if (depth > 200) + if (depth + lisp_eval_depth > max_lisp_eval_depth) stack_overflow ("Stack overflow in copy-tree", arg); if (CONSP (arg)) ＠＠ -1742,978 +2497,116 ＠＠ return Qnil; } -DEFUN ("assoc", Fassoc, 2, 2, 0, /* -Return non-nil if KEY is `equal' to the car of an element of ALIST. -The value is actually the element of ALIST whose car equals KEY. -*/ - (key, alist)) -{ - /* This function can GC. */ - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) - { - if (internal_equal (key, elt_car, 0)) - return elt; - } - return Qnil; -} - -DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /* -Return non-nil if KEY is `old-equal' to the car of an element of ALIST. -The value is actually the element of ALIST whose car equals KEY. -*/ - (key, alist)) -{ - /* This function can GC. */ - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) - { - if (internal_old_equal (key, elt_car, 0)) - return elt; - } - return Qnil; -} - -Lisp_Object -assoc_no_quit (Lisp_Object key, Lisp_Object alist) -{ - int speccount = specpdl_depth (); - specbind (Qinhibit_quit, Qt); - return unbind_to_1 (speccount, Fassoc (key, alist)); -} - -DEFUN ("assq", Fassq, 2, 2, 0, /* -Return non-nil if KEY is `eq' to the car of an element of ALIST. -The value is actually the element of ALIST whose car is KEY. -Elements of ALIST that are not conses are ignored. -*/ - (key, alist)) -{ - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) - { - if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) - return elt; - } - return Qnil; -} - -DEFUN ("old-assq", Fold_assq, 2, 2, 0, /* -Return non-nil if KEY is `old-eq' to the car of an element of ALIST. -The value is actually the element of ALIST whose car is KEY. -Elements of ALIST that are not conses are ignored. -This function is provided only for byte-code compatibility with v19. -Do not use it. -*/ - (key, alist)) -{ - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) - { - if (HACKEQ_UNSAFE (key, elt_car)) - return elt; - } - return Qnil; -} - -/* Like Fassq but never report an error and do not allow quits. - Use only on lists known never to be circular. */ - -Lisp_Object -assq_no_quit (Lisp_Object key, Lisp_Object alist) -{ - /* This cannot GC. */ - LIST_LOOP_2 (elt, alist) - { - Lisp_Object elt_car = XCAR (elt); - if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) - return elt; - } - return Qnil; -} - -DEFUN ("rassoc", Frassoc, 2, 2, 0, /* -Return non-nil if VALUE is `equal' to the cdr of an element of ALIST. -The value is actually the element of ALIST whose cdr equals VALUE. -*/ - (value, alist)) -{ - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) - { - if (internal_equal (value, elt_cdr, 0)) - return elt; - } - return Qnil; -} - -DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /* -Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST. -The value is actually the element of ALIST whose cdr equals VALUE. -*/ - (value, alist)) -{ - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) - { - if (internal_old_equal (value, elt_cdr, 0)) - return elt; - } - return Qnil; -} - -DEFUN ("rassq", Frassq, 2, 2, 0, /* -Return non-nil if VALUE is `eq' to the cdr of an element of ALIST. -The value is actually the element of ALIST whose cdr is VALUE. -*/ - (value, alist)) -{ - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) - { - if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) - return elt; - } - return Qnil; -} - -DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* -Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST. -The value is actually the element of ALIST whose cdr is VALUE. -*/ - (value, alist)) -{ - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) - { - if (HACKEQ_UNSAFE (value, elt_cdr)) - return elt; - } - return Qnil; -} - -/* Like Frassq, but caller must ensure that ALIST is properly - nil-terminated and ebola-free. */ -Lisp_Object -rassq_no_quit (Lisp_Object value, Lisp_Object alist) -{ - LIST_LOOP_2 (elt, alist) - { - Lisp_Object elt_cdr = XCDR (elt); - if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) - return elt; - } - return Qnil; -} - - -DEFUN ("delete", Fdelete, 2, 2, 0, /* -Delete by side effect any occurrences of ELT as a member of LIST. -The modified LIST is returned. Comparison is done with `equal'. -If the first member of LIST is ELT, there is no way to remove it by side -effect; therefore, write `(setq foo (delete element foo))' to be sure -of changing the value of `foo'. -Also see: `remove'. -*/ - (elt, list)) -{ - EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, - (internal_equal (elt, list_elt, 0))); - return list; -} - -DEFUN ("old-delete", Fold_delete, 2, 2, 0, /* -Delete by side effect any occurrences of ELT as a member of LIST. -The modified LIST is returned. Comparison is done with `old-equal'. -If the first member of LIST is ELT, there is no way to remove it by side -effect; therefore, write `(setq foo (old-delete element foo))' to be sure -of changing the value of `foo'. -*/ - (elt, list)) -{ - EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, - (internal_old_equal (elt, list_elt, 0))); - return list; -} - -DEFUN ("delq", Fdelq, 2, 2, 0, /* -Delete by side effect any occurrences of ELT as a member of LIST. -The modified LIST is returned. Comparison is done with `eq'. -If the first member of LIST is ELT, there is no way to remove it by side -effect; therefore, write `(setq foo (delq element foo))' to be sure of -changing the value of `foo'. -*/ - (elt, list)) -{ - EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, - (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); - return list; -} - -DEFUN ("old-delq", Fold_delq, 2, 2, 0, /* -Delete by side effect any occurrences of ELT as a member of LIST. -The modified LIST is returned. Comparison is done with `old-eq'. -If the first member of LIST is ELT, there is no way to remove it by side -effect; therefore, write `(setq foo (old-delq element foo))' to be sure of -changing the value of `foo'. -*/ - (elt, list)) -{ - EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, - (HACKEQ_UNSAFE (elt, list_elt))); - return list; -} - -/* Like Fdelq, but caller must ensure that LIST is properly - nil-terminated and ebola-free. */ - -Lisp_Object -delq_no_quit (Lisp_Object elt, Lisp_Object list) -{ - LIST_LOOP_DELETE_IF (list_elt, list, - (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); - return list; -} - -/* Be VERY careful with this. This is like delq_no_quit() but - also calls free_cons() on the removed conses. You must be SURE - that no pointers to the freed conses remain around (e.g. - someone else is pointing to part of the list). This function - is useful on internal lists that are used frequently and where - the actual list doesn't escape beyond known code bounds. */ - -Lisp_Object -delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) -{ - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object tem = XCAR (tail); - if (EQ (elt, tem)) - { - Lisp_Object cons_to_free = tail; - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - tail = XCDR (tail); - free_cons (cons_to_free); - } - else - { - prev = tail; - tail = XCDR (tail); - } - } - return list; -} - -DEFUN ("remassoc", Fremassoc, 2, 2, 0, /* -Delete by side effect any elements of ALIST whose car is `equal' to KEY. -The modified ALIST is returned. If the first member of ALIST has a car -that is `equal' to KEY, there is no way to remove it by side effect; -therefore, write `(setq foo (remassoc key foo))' to be sure of changing -the value of `foo'. -*/ - (key, alist)) -{ - EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, - (CONSP (elt) && - internal_equal (key, XCAR (elt), 0))); - return alist; -} - -Lisp_Object -remassoc_no_quit (Lisp_Object key, Lisp_Object alist) -{ - int speccount = specpdl_depth (); - specbind (Qinhibit_quit, Qt); - return unbind_to_1 (speccount, Fremassoc (key, alist)); -} - -DEFUN ("remassq", Fremassq, 2, 2, 0, /* -Delete by side effect any elements of ALIST whose car is `eq' to KEY. -The modified ALIST is returned. If the first member of ALIST has a car -that is `eq' to KEY, there is no way to remove it by side effect; -therefore, write `(setq foo (remassq key foo))' to be sure of changing -the value of `foo'. -*/ - (key, alist)) -{ - EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, - (CONSP (elt) && - EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); - return alist; -} - -/* no quit, no errors; be careful */ - -Lisp_Object -remassq_no_quit (Lisp_Object key, Lisp_Object alist) -{ - LIST_LOOP_DELETE_IF (elt, alist, - (CONSP (elt) && - EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); - return alist; -} - -DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /* -Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE. -The modified ALIST is returned. If the first member of ALIST has a car -that is `equal' to VALUE, there is no way to remove it by side effect; -therefore, write `(setq foo (remrassoc value foo))' to be sure of changing -the value of `foo'. -*/ - (value, alist)) -{ - EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, - (CONSP (elt) && - internal_equal (value, XCDR (elt), 0))); - return alist; -} - -DEFUN ("remrassq", Fremrassq, 2, 2, 0, /* -Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE. -The modified ALIST is returned. If the first member of ALIST has a car -that is `eq' to VALUE, there is no way to remove it by side effect; -therefore, write `(setq foo (remrassq value foo))' to be sure of changing -the value of `foo'. -*/ - (value, alist)) -{ - EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, - (CONSP (elt) && - EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); - return alist; -} - -/* Like Fremrassq, fast and unsafe; be careful */ -Lisp_Object -remrassq_no_quit (Lisp_Object value, Lisp_Object alist) -{ - LIST_LOOP_DELETE_IF (elt, alist, - (CONSP (elt) && - EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); - return alist; -} - -DEFUN ("nreverse", Fnreverse, 1, 1, 0, /* -Reverse SEQUENCE, destructively. - -Return the beginning of the reversed sequence, which will be a distinct Lisp -object if SEQUENCE is a list with length greater than one. See also -`reverse', the non-destructive version of this function. -*/ - (sequence)) -{ - CHECK_SEQUENCE (sequence); - - if (CONSP (sequence)) - { - struct gcpro gcpro1, gcpro2; - Lisp_Object prev = Qnil; - Lisp_Object tail = sequence; - - /* We gcpro our args; see `nconc' */ - GCPRO2 (prev, tail); - while (!NILP (tail)) - { - REGISTER Lisp_Object next; - CONCHECK_CONS (tail); - next = XCDR (tail); - XCDR (tail) = prev; - prev = tail; - tail = next; - } - UNGCPRO; - return prev; - } - else if (VECTORP (sequence)) - { - Elemcount length = XVECTOR_LENGTH (sequence), ii = length; - Elemcount half = length / 2; - Lisp_Object swap = Qnil; - CHECK_LISP_WRITEABLE (sequence); - - while (ii > half) - { - swap = XVECTOR_DATA (sequence) [length - ii]; - XVECTOR_DATA (sequence) [length - ii] - = XVECTOR_DATA (sequence) [ii - 1]; - XVECTOR_DATA (sequence) [ii - 1] = swap; - --ii; - } - } - else if (STRINGP (sequence)) - { - Elemcount length = XSTRING_LENGTH (sequence); - Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length; - Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length; - - CHECK_LISP_WRITEABLE (sequence); - while (cursor < endp) - { - staging_end -= itext_ichar_len (cursor); - itext_copy_ichar (cursor, staging_end); - INC_IBYTEPTR (cursor); - } - - assert (staging == staging_end); - - memcpy (XSTRING_DATA (sequence), staging, length); - init_string_ascii_begin (sequence); - bump_string_modiff (sequence); - sledgehammer_check_ascii_begin (sequence); - } - else if (BIT_VECTORP (sequence)) - { - Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence); - Elemcount length = bit_vector_length (bv), ii = length; - Elemcount half = length / 2; - int swap = 0; - - CHECK_LISP_WRITEABLE (sequence); - while (ii > half) - { - swap = bit_vector_bit (bv, length - ii); - set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1)); - set_bit_vector_bit (bv, ii - 1, swap); - --ii; - } - } - else - { - assert (NILP (sequence)); - } - - return sequence; -} - -DEFUN ("reverse", Freverse, 1, 1, 0, /* -Reverse SEQUENCE, copying. Return the reversed sequence. -See also the function `nreverse', which is used more often. -*/ - (sequence)) -{ - Lisp_Object result = Qnil; - - CHECK_SEQUENCE (sequence); - - if (CONSP (sequence)) - { - EXTERNAL_LIST_LOOP_2 (elt, sequence) - { - result = Fcons (elt, result); - } - } - else if (VECTORP (sequence)) - { - Elemcount length = XVECTOR_LENGTH (sequence), ii = length; - Lisp_Object *staging = alloca_array (Lisp_Object, length); - - while (ii > 0) - { - staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1]; - --ii; - } - - result = Fvector (length, staging); - } - else if (STRINGP (sequence)) - { - Elemcount length = XSTRING_LENGTH (sequence); - Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length; - Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length; - - while (cursor < endp) - { - staging_end -= itext_ichar_len (cursor); - itext_copy_ichar (cursor, staging_end); - INC_IBYTEPTR (cursor); - } - - assert (staging == staging_end); - - result = make_string (staging, length); - } - else if (BIT_VECTORP (sequence)) - { - Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res; - Elemcount length = bit_vector_length (bv), ii = length; - - result = make_bit_vector (length, Qzero); - res = XBIT_VECTOR (result); - - while (ii > 0) - { - set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1)); - --ii; - } - } - else - { - assert (NILP (sequence)); - } - - return result; -} - -static Lisp_Object -c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2, - Lisp_Object pred, Lisp_Object key_func) -{ - struct gcpro gcpro1; - Lisp_Object args[3]; - - /* We could use call2() and call3() here, but we're called O(nlogn) times - for a sequence of length n, it make some sense to inline them. */ - args[0] = key_func; - args[1] = obj1; - args[2] = Qnil; - - GCPRO1 (args[0]); - gcpro1.nvars = countof (args); - - obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); - - args[1] = obj2; - obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); - - args[0] = pred; - args[1] = obj1; - args[2] = obj2; - - RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args))); -} - -static Lisp_Object -c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2, - Lisp_Object pred, Lisp_Object UNUSED (key_func)) -{ - struct gcpro gcpro1; - Lisp_Object args[3]; - - /* This is (almost) the implementation of call2, it makes some sense to - inline it here. */ - args[0] = pred; - args[1] = obj1; - args[2] = obj2; - - GCPRO1 (args[0]); - gcpro1.nvars = countof (args); - - RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args))); -} - -Lisp_Object -list_merge (Lisp_Object org_l1, Lisp_Object org_l2, - Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object), - Lisp_Object predicate, Lisp_Object key_func) -{ - Lisp_Object value; - Lisp_Object tail; - Lisp_Object tem; - Lisp_Object l1, l2; - Lisp_Object tortoises[2]; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; - int l1_count = 0, l2_count = 0; - - l1 = org_l1; - l2 = org_l2; - tail = Qnil; - value = Qnil; - tortoises[0] = org_l1; - tortoises[1] = org_l2; - - if (NULL == c_predicate) - { - c_predicate = EQ (key_func, Qidentity) ? - c_merge_predicate_nokey : c_merge_predicate_key; - } - - /* It is sufficient to protect org_l1 and org_l2. - When l1 and l2 are updated, we copy the new values - back into the org_ vars. */ - - GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]); - gcpro5.nvars = 2; - - while (1) - { - if (NILP (l1)) - { - UNGCPRO; - if (NILP (tail)) - return l2; - Fsetcdr (tail, l2); - return value; - } - if (NILP (l2)) - { - UNGCPRO; - if (NILP (tail)) - return l1; - Fsetcdr (tail, l1); - return value; - } - - if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func))) - { - tem = l1; - l1 = Fcdr (l1); - org_l1 = l1; - - if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH) - { - if (l1_count & 1) - { - if (!CONSP (tortoises[0])) - { - mapping_interaction_error (Qmerge, tortoises[0]); - } - - tortoises[0] = XCDR (tortoises[0]); - } - - if (EQ (org_l1, tortoises[0])) - { - signal_circular_list_error (org_l1); - } - } - } - else - { - tem = l2; - l2 = Fcdr (l2); - org_l2 = l2; - - if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH) - { - if (l2_count & 1) - { - if (!CONSP (tortoises[1])) - { - mapping_interaction_error (Qmerge, tortoises[1]); - } - - tortoises[1] = XCDR (tortoises[1]); - } - - if (EQ (org_l2, tortoises[1])) - { - signal_circular_list_error (org_l2); - } - } - } - - if (NILP (tail)) - value = tem; - else - Fsetcdr (tail, tem); - - tail = tem; - } -} - -static void -array_merge (Lisp_Object *dest, Elemcount dest_len, - Lisp_Object *front, Elemcount front_len, - Lisp_Object *back, Elemcount back_len, - Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object), - Lisp_Object predicate, Lisp_Object key_func) -{ - Elemcount ii, fronting, backing; - Lisp_Object *front_staging = front; - Lisp_Object *back_staging = back; +/* Return the first index of ITEM in LIST. In CONS_OUT, return the cons cell + before that containing the element. If the element is in the first cons + cell, return Qnil in CONS_OUT. TEST, KEY, START, END are as in + #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should have been initialized + with get_check_match_function() or get_check_test_function(). A non-zero + REVERSE_TEST_ORDER means call TEST with the element from LIST as its + first argument and ITEM as its second. Error if LIST is ill-formed, or + circular. */ +static Lisp_Object +list_position_cons_before (Lisp_Object *cons_out, + Lisp_Object item, Lisp_Object list, + check_test_func_t check_test, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint reverse_test_order, + Lisp_Object start, Lisp_Object end) +{ struct gcpro gcpro1, gcpro2; - - assert (dest_len == (back_len + front_len)); - - if (0 == dest_len) - { - return; - } - - if (front >= dest && front < (dest + dest_len)) - { - front_staging = alloca_array (Lisp_Object, front_len); - - for (ii = 0; ii < front_len; ++ii) - { - front_staging[ii] = front[ii]; - } - } - - if (back >= dest && back < (dest + dest_len)) - { - back_staging = alloca_array (Lisp_Object, back_len); - - for (ii = 0; ii < back_len; ++ii) - { - back_staging[ii] = back[ii]; - } - } - - GCPRO2 (front_staging[0], back_staging[0]); - gcpro1.nvars = front_len; - gcpro2.nvars = back_len; - - for (ii = fronting = backing = 0; ii < dest_len; ++ii) - { - if (fronting >= front_len) - { - while (ii < dest_len) - { - dest[ii] = back_staging[backing]; - ++ii, ++backing; - } - UNGCPRO; - return; - } - - if (backing >= back_len) - { - while (ii < dest_len) - { - dest[ii] = front_staging[fronting]; - ++ii, ++fronting; - } - UNGCPRO; - return; - } - - if (NILP (c_predicate (back_staging[backing], front_staging[fronting], - predicate, key_func))) - { - dest[ii] = front_staging[fronting]; - ++fronting; - } - else - { - dest[ii] = back_staging[backing]; - ++backing; - } - } - - UNGCPRO; -} - -static Lisp_Object -list_array_merge_into_list (Lisp_Object list, - Lisp_Object *array, Elemcount array_len, - Lisp_Object (*c_predicate) (Lisp_Object, - Lisp_Object, - Lisp_Object, - Lisp_Object), - Lisp_Object predicate, Lisp_Object key_func, - Boolint reverse_order) -{ - Lisp_Object tail = Qnil, value = Qnil, tortoise = list; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - Elemcount array_index = 0; - int looped = 0; - - GCPRO4 (list, tail, value, tortoise); - - while (1) - { - if (NILP (list)) - { - UNGCPRO; - - if (NILP (tail)) - { - return Flist (array_len, array); - } - - Fsetcdr (tail, Flist (array_len - array_index, array + array_index)); - return value; - } - - if (array_index >= array_len) - { - UNGCPRO; - if (NILP (tail)) - { - return list; - } - - Fsetcdr (tail, list); - return value; - } - - - if (reverse_order ? - !NILP (c_predicate (Fcar (list), array [array_index], predicate, - key_func)) : - NILP (c_predicate (array [array_index], Fcar (list), predicate, - key_func))) - { - if (NILP (tail)) - { - value = tail = list; - } - else - { - Fsetcdr (tail, list); - tail = XCDR (tail); - } - - list = Fcdr (list); - } - else - { - if (NILP (tail)) - { - value = tail = Fcons (array [array_index], Qnil); - } - else - { - Fsetcdr (tail, Fcons (array [array_index], tail)); - tail = XCDR (tail); - } - ++array_index; - } - - if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH) - { - if (looped & 1) - { - tortoise = XCDR (tortoise); - } - - if (EQ (list, tortoise)) - { - signal_circular_list_error (list); - } - } - } -} - -static void -list_list_merge_into_array (Lisp_Object *output, Elemcount output_len, - Lisp_Object list_one, Lisp_Object list_two, - Lisp_Object (*c_predicate) (Lisp_Object, - Lisp_Object, - Lisp_Object, - Lisp_Object), - Lisp_Object predicate, Lisp_Object key_func) -{ - Elemcount output_index = 0; - - while (output_index < output_len) - { - if (NILP (list_one)) - { - while (output_index < output_len) - { - output [output_index] = Fcar (list_two); - list_two = Fcdr (list_two), ++output_index; - } - return; - } - - if (NILP (list_two)) - { - while (output_index < output_len) - { - output [output_index] = Fcar (list_one); - list_one = Fcdr (list_one), ++output_index; - } - return; - } - - if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate, - key_func))) - { - output [output_index] = XCAR (list_one); - list_one = XCDR (list_one); - } - else - { - output [output_index] = XCAR (list_two); - list_two = XCDR (list_two); - } - - ++output_index; - - /* No need to check for circularity. */ - } -} - -static void -list_array_merge_into_array (Lisp_Object *output, Elemcount output_len, - Lisp_Object list, - Lisp_Object *array, Elemcount array_len, - Lisp_Object (*c_predicate) (Lisp_Object, - Lisp_Object, - Lisp_Object, - Lisp_Object), - Lisp_Object predicate, Lisp_Object key_func, - Boolint reverse_order) -{ - Elemcount output_index = 0, array_index = 0; - - while (output_index < output_len) - { - if (NILP (list)) - { - if (array_len - array_index != output_len - output_index) - { - mapping_interaction_error (Qmerge, list); - } - - while (array_index < array_len) - { - output [output_index++] = array [array_index++]; - } - - return; - } - - if (array_index >= array_len) - { - while (output_index < output_len) - { - output [output_index++] = Fcar (list); - list = Fcdr (list); - } - - return; - } - - if (reverse_order ? - !NILP (c_predicate (Fcar (list), array [array_index], predicate, - key_func)) : - NILP (c_predicate (array [array_index], Fcar (list), predicate, - key_func))) - { - output [output_index] = XCAR (list); - list = XCDR (list); - } - else - { - output [output_index] = array [array_index]; - ++array_index; - } - - ++output_index; - } -} - -#define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \ - do { \ - c_array = alloca_array (Lisp_Object, len); \ - for (counter = 0; counter < len; ++counter) \ - { \ - c_array[counter] = make_char (itext_ichar (strdata)); \ - INC_IBYTEPTR (strdata); \ - } \ - } while (0) - -#define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \ - c_array = alloca_array (Lisp_Object, len); \ - for (counter = 0; counter < len; ++counter) \ - { \ - c_array[counter] = make_int (bit_vector_bit (v, counter)); \ - } \ - } while (0) + Lisp_Object elt = Qnil, tail = list, tail_before = Qnil; + Elemcount len, ii = 0, starting = XINT (start); + Elemcount ending = NILP (end) ? EMACS_INT_MAX : XINT (end); + + GCPRO2 (elt, tail); + + 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) + { + if (starting <= ii && ii < ending && + EQ (item, elt) == test_not_unboundp) + { + *cons_out = tail_before; + RETURN_UNGCPRO (make_integer (ii)); + } + else + { + if (ii >= ending) + { + break; + } + } + ii++; + tail_before = tail; + } + } + else + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len) + { + if (starting <= ii && ii < ending && + (reverse_test_order ? + check_test (test, key, elt, item) : + check_test (test, key, item, elt)) == test_not_unboundp) + { + *cons_out = tail_before; + RETURN_UNGCPRO (make_integer (ii)); + } + else + { + if (ii >= ending) + { + break; + } + } + ii++; + tail_before = tail; + } + } + + RETURN_UNGCPRO (Qnil); +} + +DEFUN ("member*", FmemberX, 2, MANY, 0, /* +Return the first sublist of LIST with car ITEM, or nil if no such sublist. + +The keyword :test specifies a two-argument function that is used to compare +ITEM with elements in LIST; if omitted, it defaults to `eql'. + +The keyword :test-not is similar, but specifies a negated function. That +is, ITEM is considered equal to an element in LIST if the given function +returns nil. Common Lisp deprecates :test-not, and if both are specified, +XEmacs signals an error. + +:key specifies a one-argument function that transforms elements of LIST into +\"comparison keys\" before the test predicate is applied. For example, +if:key is #'car, then ITEM is compared with the car of elements from LIST. +The:key function, however, is not applied to ITEM, and does not affect the +elements in the returned list, which are taken directly from the elements in +LIST. + +arguments: (ITEM LIST &key (TEST #'eql) TEST-NOT (KEY #'identity)) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], list = args[1], result = Qnil, position0; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (FmemberX, nargs, args, 5, (test, if_not, if_, test_not, key), + NULL); + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + position0 + = list_position_cons_before (&result, item, list, check_test, + test_not_unboundp, test, key, 0, Qzero, Qnil); + + return CONSP (result) ? XCDR (result) : ZEROP (position0) ? list : Qnil; +} /* This macro might eventually find a better home than here. */ ＠＠ -2727,9 +2620,2568 ＠＠ if (!EQ (key, Qidentity)) \ { \ key = indirect_function (key, 1); \ + if (EQ (key, XSYMBOL_FUNCTION (Qidentity))) \ + { \ + key = Qidentity; \ + } \ } \ } while (0) +#define KEY(key, item) (EQ (Qidentity, key) ? item : \ + IGNORE_MULTIPLE_VALUES (call1 (key, item))) + +DEFUN ("adjoin", Fadjoin, 2, MANY, 0, /* +Return ITEM consed onto the front of LIST, if not already in LIST. + +Otherwise, return LIST unmodified. + +See `member*' for the meaning of the keywords. + +arguments: (ITEM LIST &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], list = args[1], keyed = Qnil, ignore = Qnil; + struct gcpro gcpro1; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fadjoin, nargs, args, 3, (test, key, test_not), + NULL); + + CHECK_KEY_ARGUMENT (key); + + keyed = KEY (key, item); + + GCPRO1 (keyed); + check_test = get_check_test_function (keyed, &test, test_not, Qnil, Qnil, + key, &test_not_unboundp); + if (NILP (list_position_cons_before (&ignore, keyed, list, check_test, + test_not_unboundp, test, key, 0, Qzero, + Qnil))) + { + RETURN_UNGCPRO (Fcons (item, list)); + } + + RETURN_UNGCPRO (list); +} + +DEFUN ("assoc", Fassoc, 2, 2, 0, /* +Return non-nil if KEY is `equal' to the car of an element of ALIST. +The value is actually the element of ALIST whose car equals KEY. +*/ + (key, alist)) +{ + /* This function can GC. */ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (internal_equal (key, elt_car, 0)) + return elt; + } + return Qnil; +} + +DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /* +Return non-nil if KEY is `old-equal' to the car of an element of ALIST. +The value is actually the element of ALIST whose car equals KEY. +*/ + (key, alist)) +{ + /* This function can GC. */ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (internal_old_equal (key, elt_car, 0)) + return elt; + } + return Qnil; +} + +Lisp_Object +assoc_no_quit (Lisp_Object key, Lisp_Object alist) +{ + int speccount = specpdl_depth (); + specbind (Qinhibit_quit, Qt); + return unbind_to_1 (speccount, Fassoc (key, alist)); +} + +DEFUN ("assq", Fassq, 2, 2, 0, /* +Return non-nil if KEY is `eq' to the car of an element of ALIST. +The value is actually the element of ALIST whose car is KEY. +Elements of ALIST that are not conses are ignored. +*/ + (key, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) + return elt; + } + return Qnil; +} + +DEFUN ("old-assq", Fold_assq, 2, 2, 0, /* +Return non-nil if KEY is `old-eq' to the car of an element of ALIST. +The value is actually the element of ALIST whose car is KEY. +Elements of ALIST that are not conses are ignored. +This function is provided only for byte-code compatibility with v19. +Do not use it. +*/ + (key, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (HACKEQ_UNSAFE (key, elt_car)) + return elt; + } + return Qnil; +} + +/* Like Fassq but never report an error and do not allow quits. + Use only on lists known never to be circular. */ + +Lisp_Object +assq_no_quit (Lisp_Object key, Lisp_Object alist) +{ + /* This cannot GC. */ + LIST_LOOP_2 (elt, alist) + { + Lisp_Object elt_car = XCAR (elt); + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) + return elt; + } + return Qnil; +} + +DEFUN ("assoc*", FassocX, 2, MANY, 0, /* +Find the first item whose car matches ITEM in ALIST. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], alist = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (FassocX, nargs, args, 5, (test, if_, if_not, test_not, key), + NULL); + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (check_test == check_eq_nokey) + { + /* TEST is #'eq, no need to call any C functions. */ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (EQ (item, elt_car) == test_not_unboundp) + { + return elt; + } + } + } + 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) + { + RETURN_UNGCPRO (elt); + } + } + } + UNGCPRO; + } + + return Qnil; +} + +DEFUN ("rassoc", Frassoc, 2, 2, 0, /* +Return non-nil if VALUE is `equal' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr equals VALUE. +*/ + (value, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (internal_equal (value, elt_cdr, 0)) + return elt; + } + return Qnil; +} + +DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /* +Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr equals VALUE. +*/ + (value, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (internal_old_equal (value, elt_cdr, 0)) + return elt; + } + return Qnil; +} + +DEFUN ("rassq", Frassq, 2, 2, 0, /* +Return non-nil if VALUE is `eq' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr is VALUE. +*/ + (value, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) + return elt; + } + return Qnil; +} + +DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* +Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr is VALUE. +*/ + (value, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (HACKEQ_UNSAFE (value, elt_cdr)) + return elt; + } + return Qnil; +} + +/* Like Frassq, but caller must ensure that ALIST is properly + nil-terminated and ebola-free. */ +Lisp_Object +rassq_no_quit (Lisp_Object value, Lisp_Object alist) +{ + LIST_LOOP_2 (elt, alist) + { + Lisp_Object elt_cdr = XCDR (elt); + if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) + return elt; + } + return Qnil; +} + +DEFUN ("rassoc*", FrassocX, 2, MANY, 0, /* +Find the first item whose cdr matches ITEM in ALIST. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], alist = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (FrassocX, nargs, args, 5, (test, if_, if_not, test_not, key), + NULL); + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (check_test == check_eq_nokey) + { + /* TEST is #'eq, no need to call any C functions. */ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (EQ (item, elt_cdr) == test_not_unboundp) + { + return elt; + } + } + } + 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; + } + + return Qnil; +} + +/* This is the implementation of both #'find and #'position. */ +static Lisp_Object +position (Lisp_Object *object_out, Lisp_Object item, Lisp_Object sequence, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, Lisp_Object start, Lisp_Object end, + Lisp_Object from_end, Lisp_Object default_, Lisp_Object caller) +{ + Lisp_Object result = Qnil; + Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0; + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = INTP (start) ? XINT (start) : 1 + EMACS_INT_MAX; + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = INTP (end) ? XINT (end) : 1 + EMACS_INT_MAX; + } + + *object_out = default_; + + if (CONSP (sequence)) + { + Lisp_Object elt, tail = Qnil; + struct gcpro gcpro1; + + if (!(starting < ending)) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + /* starting could be equal to ending, in which case nil is what + we want to return. */ + return Qnil; + } + + GCPRO1 (tail); + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + { + if (starting <= ii && ii < ending + && check_test (test, key, item, elt) == test_not_unboundp) + { + result = make_integer (ii); + *object_out = elt; + + if (NILP (from_end)) + { + UNGCPRO; + return result; + } + } + else if (ii == ending) + { + break; + } + + ii++; + } + } + + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + } + else if (STRINGP (sequence)) + { + Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp; + Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0; + Lisp_Object character = Qnil; + + while (cursor_offset < byte_len && ii < ending) + { + if (ii >= starting) + { + character = make_char (itext_ichar (cursor)); + + if (check_test (test, key, item, character) == test_not_unboundp) + { + result = make_integer (ii); + *object_out = character; + + if (NILP (from_end)) + { + return result; + } + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (caller, sequence); + } + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + } + else + { + Lisp_Object object = Qnil; + len = XINT (Flength (sequence)); + check_sequence_range (sequence, start, end, make_int (len)); + + ending = min (ending, len); + if (0 == len) + { + /* Catches the case where we have nil. */ + return result; + } + + if (NILP (from_end)) + { + for (ii = starting; ii < ending; ii++) + { + object = Faref (sequence, make_int (ii)); + if (check_test (test, key, item, object) == test_not_unboundp) + { + result = make_integer (ii); + *object_out = object; + return result; + } + } + } + else + { + for (ii = ending - 1; ii >= starting; ii--) + { + object = Faref (sequence, make_int (ii)); + if (check_test (test, key, item, object) == test_not_unboundp) + { + result = make_integer (ii); + *object_out = object; + return result; + } + } + } + } + + return result; +} + +DEFUN ("position", Fposition, 2, MANY, 0, /* +Return the index of the first occurrence of ITEM in SEQUENCE. + +Return nil if not found. See `remove*' for the meaning of the keywords. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object object = Qnil, item = args[0], sequence = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fposition, nargs, args, 8, + (test, if_, test_not, if_not, key, start, end, from_end), + (start = Qzero)); + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + return position (&object, item, sequence, check_test, test_not_unboundp, + test, key, start, end, from_end, Qnil, Qposition); +} + +DEFUN ("find", Ffind, 2, MANY, 0, /* +Find the first occurrence of ITEM in SEQUENCE. + +Return the matching ITEM, or nil if not found. See `remove*' for the +meaning of the keywords. + +The keyword :default, not specified by Common Lisp, designates an object to +return instead of nil if ITEM is not found. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) DEFAULT FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object object = Qnil, item = args[0], sequence = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fposition, nargs, args, 9, + (test, if_, test_not, if_not, key, start, end, from_end, + default_), + (start = Qzero)); + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + position (&object, item, sequence, check_test, test_not_unboundp, + test, key, start, end, from_end, Qnil, Qposition); + + return object; +} + +DEFUN ("delete", Fdelete, 2, 2, 0, /* +Delete by side effect any occurrences of ELT as a member of LIST. +The modified LIST is returned. Comparison is done with `equal'. +If the first member of LIST is ELT, there is no way to remove it by side +effect; therefore, write `(setq foo (delete element foo))' to be sure +of changing the value of `foo'. +Also see: `remove'. +*/ + (elt, list)) +{ + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (internal_equal (elt, list_elt, 0))); + return list; +} + +DEFUN ("old-delete", Fold_delete, 2, 2, 0, /* +Delete by side effect any occurrences of ELT as a member of LIST. +The modified LIST is returned. Comparison is done with `old-equal'. +If the first member of LIST is ELT, there is no way to remove it by side +effect; therefore, write `(setq foo (old-delete element foo))' to be sure +of changing the value of `foo'. +*/ + (elt, list)) +{ + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (internal_old_equal (elt, list_elt, 0))); + return list; +} + +DEFUN ("delq", Fdelq, 2, 2, 0, /* +Delete by side effect any occurrences of ELT as a member of LIST. +The modified LIST is returned. Comparison is done with `eq'. +If the first member of LIST is ELT, there is no way to remove it by side +effect; therefore, write `(setq foo (delq element foo))' to be sure of +changing the value of `foo'. +*/ + (elt, list)) +{ + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); + return list; +} + +DEFUN ("old-delq", Fold_delq, 2, 2, 0, /* +Delete by side effect any occurrences of ELT as a member of LIST. +The modified LIST is returned. Comparison is done with `old-eq'. +If the first member of LIST is ELT, there is no way to remove it by side +effect; therefore, write `(setq foo (old-delq element foo))' to be sure of +changing the value of `foo'. +*/ + (elt, list)) +{ + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (HACKEQ_UNSAFE (elt, list_elt))); + return list; +} + +/* Like Fdelq, but caller must ensure that LIST is properly + nil-terminated and ebola-free. */ + +Lisp_Object +delq_no_quit (Lisp_Object elt, Lisp_Object list) +{ + LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); + return list; +} + +/* Be VERY careful with this. This is like delq_no_quit() but + also calls free_cons() on the removed conses. You must be SURE + that no pointers to the freed conses remain around (e.g. + someone else is pointing to part of the list). This function + is useful on internal lists that are used frequently and where + the actual list doesn't escape beyond known code bounds. */ + +Lisp_Object +delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) +{ + REGISTER Lisp_Object tail = list; + REGISTER Lisp_Object prev = Qnil; + + while (!NILP (tail)) + { + REGISTER Lisp_Object tem = XCAR (tail); + if (EQ (elt, tem)) + { + Lisp_Object cons_to_free = tail; + if (NILP (prev)) + list = XCDR (tail); + else + XCDR (prev) = XCDR (tail); + tail = XCDR (tail); + free_cons (cons_to_free); + } + else + { + prev = tail; + tail = XCDR (tail); + } + } + return list; +} + +DEFUN ("delete*", FdeleteX, 2, MANY, 0, /* +Remove all occurrences of ITEM in SEQUENCE, destructively. + +If SEQUENCE is a non-nil list, this modifies the list directly. A non-list +SEQUENCE will not be destructively modified, rather, if ITEM occurs in it, a +new SEQUENCE of the same type without ITEM will be returned. + +See `remove*' for a non-destructive alternative, and for explanation of the +keyword arguments. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], sequence = args[1], tail = sequence; + 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, + count), (start = Qzero, count = Qunbound)); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end); + } + + if (!UNBOUNDP (count)) + { + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (BIGNUMP (count)) + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + EMACS_INT_MAX : EMACS_INT_MIN - 1; + } + else + { + counting = XINT (count); + } + + if (counting < 1) + { + return sequence; + } + } + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (CONSP (sequence)) + { + Lisp_Object prev_tail_list_elt = Qnil, list_elt = Qnil; + Elemcount list_len = 0, deleted = 0; + + 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, + QdeleteX); + + if (ZEROP (present)) + { + return sequence; + } + + presenting = XINT (present); + + /* If there are fewer items in the list than we have permission to + delete, we don't need to differentiate between the :from-end + nil and :from-end t cases. Otherwise, presenting is the number + of matching items we need to ignore before we start to + delete. */ + presenting = presenting <= counting ? 0 : presenting - counting; + } + + GCPRO1 (tail); + ii = -1; + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (list_elt, sequence, tail, list_len) + { + ii++; + + if (starting <= ii && ii < ending && + (check_test (test, key, item, list_elt) == test_not_unboundp) + && (presenting ? encountered++ >= presenting +: encountered++ < counting)) + { + if (NILP (prev_tail_list_elt)) + { + sequence = XCDR (tail); + } + else + { + XSETCDR (prev_tail_list_elt, XCDR (tail)); + } + + /* Keep tortoise from ever passing hare. */ + list_len = 0; + deleted++; + } + else + { + prev_tail_list_elt = tail; + if (ii >= ending || (!presenting && encountered > counting)) + { + break; + } + } + } + } + + UNGCPRO; + + if ((ii < starting || (ii < ending && !NILP (end))) && + !(presenting ? encountered == presenting : encountered == counting)) + { + check_sequence_range (args[1], start, end, + make_int (deleted + XINT (Flength (args[1])))); + } + + return sequence; + } + else if (STRINGP (sequence)) + { + Ibyte *staging = alloca_ibytes (XSTRING_LENGTH (sequence)); + Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence); + Ibyte *cursor = startp; + Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence); + Lisp_Object character, result = sequence; + + if (!NILP (count) && !NILP (from_end)) + { + Lisp_Object present = count_with_tail (&character, nargs, args, + QdeleteX); + + if (ZEROP (present)) + { + return sequence; + } + + presenting = XINT (present); + + /* If there are fewer items in the list than we have permission to + delete, we don't need to differentiate between the :from-end + nil and :from-end t cases. Otherwise, presenting is the number + of matching items we need to ignore before we start to + delete. */ + presenting = presenting <= counting ? 0 : presenting - counting; + } + + ii = 0; + while (cursor_offset < byte_len) + { + if (ii >= starting && ii < ending) + { + character = make_char (itext_ichar (cursor)); + + if ((check_test (test, key, item, character) + == test_not_unboundp) + && (presenting ? encountered++ >= presenting : + encountered++ < counting)) + { + DO_NOTHING; + } + else + { + staging_cursor + += set_itext_ichar (staging_cursor, XCHAR (character)); + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (QdeleteX, sequence); + } + } + else + { + staging_cursor += itext_copy_ichar (cursor, staging_cursor); + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + + if (0 != encountered) + { + result = make_string (staging, staging_cursor - staging); + copy_string_extents (result, sequence, 0, 0, + staging_cursor - staging); + sequence = result; + } + + return sequence; + } + else + { + Lisp_Object position0 = Qnil, object = Qnil; + Lisp_Object *staging = NULL, *staging_cursor, *staging_limit; + Elemcount positioning; + + len = XINT (Flength (sequence)); + + check_sequence_range (sequence, start, end, make_int (len)); + + position0 = position (&object, item, sequence, check_test, + test_not_unboundp, test, key, start, end, + from_end, Qnil, QdeleteX); + if (NILP (position0)) + { + return sequence; + } + + ending = min (ending, len); + positioning = XINT (position0); + encountered = 1; + + if (NILP (from_end)) + { + staging = alloca_array (Lisp_Object, len - 1); + staging_cursor = staging; + + ii = 0; + while (ii < positioning) + { + *staging_cursor++ = Faref (sequence, make_int (ii)); + ii++; + } + + ii = positioning + 1; + while (ii < ending) + { + object = Faref (sequence, make_int (ii)); + if (encountered < counting + && (check_test (test, key, item, object) + == test_not_unboundp)) + { + encountered++; + } + else + { + *staging_cursor++ = object; + } + ii++; + } + + while (ii < len) + { + *staging_cursor++ = Faref (sequence, make_int (ii)); + ii++; + } + } + else + { + staging = alloca_array (Lisp_Object, len - 1); + staging_cursor = staging_limit = staging + len - 1; + + ii = len - 1; + while (ii > positioning) + { + *--staging_cursor = Faref (sequence, make_int (ii)); + ii--; + } + + ii = positioning - 1; + while (ii >= starting) + { + object = Faref (sequence, make_int (ii)); + if (encountered < counting + && (check_test (test, key, item, object) == + test_not_unboundp)) + { + encountered++; + } + else + { + *--staging_cursor = object; + } + + ii--; + } + + while (ii >= 0) + { + *--staging_cursor = Faref (sequence, make_int (ii)); + ii--; + } + + staging = staging_cursor; + staging_cursor = staging_limit; + } + + if (VECTORP (sequence)) + { + return Fvector (staging_cursor - staging, staging); + } + else if (BIT_VECTORP (sequence)) + { + return Fbit_vector (staging_cursor - staging, staging); + } + + /* A nil sequence will have given us a nil #'position, + above. */ + ABORT (); + + return Qnil; + } +} + +DEFUN ("remove*", FremoveX, 2, MANY, 0, /* +Remove all occurrences of ITEM in SEQUENCE, non-destructively. + +If SEQUENCE is a list, `remove*' makes a copy if that is necessary to avoid +corrupting the original SEQUENCE. + +The keywords :test and :test-not specify two-argument test and negated-test +predicates, respectively; :test defaults to `eql'. :key specifies a +one-argument function that transforms elements of SEQUENCE into \"comparison +keys\" before the test predicate is applied. See `member*' for more +information on these keywords. + +:start and :end, if given, specify indices of a subsequence of SEQUENCE to +be processed. Indices are 0-based and processing involves the subsequence +starting at the index given by :start and ending just before the index given +by:end. + +:count, if given, limits the number of items removed to the number +specified.:from-end, if given, causes processing to proceed starting from +the end instead of the beginning; in this case, this matters only if :count +is given. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + 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; + 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, + count), (start = Qzero)); + + if (!CONSP (sequence)) + { + return FdeleteX (nargs, args); + } + + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end); + } + + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (BIGNUMP (count)) + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN; + } + else + { + counting = XINT (count); + } + + if (counting <= 0) + { + return sequence; + } + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + matched_count = count_with_tail (&tail, nargs, args, QremoveX); + + if (!ZEROP (matched_count)) + { + Lisp_Object elt, tailing = Qnil, result = Qnil, result_tail = Qnil; + GCPRO1 (tailing); + + if (!NILP (count) && !NILP (from_end)) + { + presenting = XINT (matched_count); + + /* If there are fewer matching elements in the list than we have + permission to delete, we don't need to differentiate between + the :from-end nil and :from-end t cases. Otherwise, presenting + is the number of matching items we need to ignore before we + start to delete. */ + presenting = presenting <= counting ? 0 : presenting - counting; + } + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tailing, len) + { + if (EQ (tail, tailing)) + { + if (NILP (result)) + { + RETURN_UNGCPRO (XCDR (tail)); + } + + XSETCDR (result_tail, XCDR (tail)); + RETURN_UNGCPRO (result); + } + else if (starting <= ii && ii < ending && + (check_test (test, key, item, elt) == test_not_unboundp) + && (presenting ? encountered++ >= presenting +: encountered++ < counting)) + { + DO_NOTHING; + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + + if (ii == ending) + { + break; + } + + ii++; + } + } + + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + + return result; + } + + return sequence; +} + +DEFUN ("remassoc", Fremassoc, 2, 2, 0, /* +Delete by side effect any elements of ALIST whose car is `equal' to KEY. +The modified ALIST is returned. If the first member of ALIST has a car +that is `equal' to KEY, there is no way to remove it by side effect; +therefore, write `(setq foo (remassoc key foo))' to be sure of changing +the value of `foo'. +*/ + (key, alist)) +{ + EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + internal_equal (key, XCAR (elt), 0))); + return alist; +} + +Lisp_Object +remassoc_no_quit (Lisp_Object key, Lisp_Object alist) +{ + int speccount = specpdl_depth (); + specbind (Qinhibit_quit, Qt); + return unbind_to_1 (speccount, Fremassoc (key, alist)); +} + +DEFUN ("remassq", Fremassq, 2, 2, 0, /* +Delete by side effect any elements of ALIST whose car is `eq' to KEY. +The modified ALIST is returned. If the first member of ALIST has a car +that is `eq' to KEY, there is no way to remove it by side effect; +therefore, write `(setq foo (remassq key foo))' to be sure of changing +the value of `foo'. +*/ + (key, alist)) +{ + EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); + return alist; +} + +/* no quit, no errors; be careful */ + +Lisp_Object +remassq_no_quit (Lisp_Object key, Lisp_Object alist) +{ + LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); + return alist; +} + +DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /* +Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE. +The modified ALIST is returned. If the first member of ALIST has a car +that is `equal' to VALUE, there is no way to remove it by side effect; +therefore, write `(setq foo (remrassoc value foo))' to be sure of changing +the value of `foo'. +*/ + (value, alist)) +{ + EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + internal_equal (value, XCDR (elt), 0))); + return alist; +} + +DEFUN ("remrassq", Fremrassq, 2, 2, 0, /* +Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE. +The modified ALIST is returned. If the first member of ALIST has a car +that is `eq' to VALUE, there is no way to remove it by side effect; +therefore, write `(setq foo (remrassq value foo))' to be sure of changing +the value of `foo'. +*/ + (value, alist)) +{ + EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); + return alist; +} + +/* Like Fremrassq, fast and unsafe; be careful */ +Lisp_Object +remrassq_no_quit (Lisp_Object value, Lisp_Object alist) +{ + LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); + return alist; +} + +/* Remove duplicate elements between START and END from LIST, a non-nil + list; if COPY is zero, do so destructively. Items to delete are selected + according to the algorithm used when :from-end t is passed to + #'delete-duplicates. Error if LIST is ill-formed or circular. + + TEST and KEY are as in #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should + reflect them, having been initialised with get_check_match_function() or + get_check_test_function(). */ +static Lisp_Object +list_delete_duplicates_from_end (Lisp_Object list, + check_test_func_t check_test, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Lisp_Object start, + Lisp_Object end, Boolint copy) +{ + Lisp_Object checking = Qnil, elt, tail, 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; + + /* 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) + algorithm to an ON^2 algorithm; list_position_cons_before() would need to + be modified to return the cons *before* the one containing the item for + that. Here and now it doesn't matter, though, #'delete-duplicates is + relatively expensive no matter what. */ + struct Lisp_Bit_Vector *deleting + = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector) + + (sizeof (long) + * (BIT_VECTOR_LONG_STORAGE (len) + - 1))); + + check_sequence_range (list, start, end, make_integer (len)); + + deleting->size = len; + memset (&(deleting->bits), 0, + sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); + + GCPRO2 (tail, keyed); + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len) + { + if (!(starting <= ii && ii <= ending) || bit_vector_bit (deleting, ii)) + { + ii++; + continue; + } + + keyed = KEY (key, elt); + checking = XCDR (tail); + pos = ii + 1; + + while (!NILP ((positioned = list_position_cons_before + (&position_cons, keyed, checking, check_test, + test_not_unboundp, test, key, 0, + make_int (max (starting - pos, 0)), + make_int (ending - pos))))) + { + pos = XINT (positioned) + pos; + set_bit_vector_bit (deleting, pos, 1); + greatest_pos_seen = max (greatest_pos_seen, pos); + checking = NILP (position_cons) ? + XCDR (checking) : XCDR (XCDR (position_cons)); + pos += 1; + } + ii++; + } + } + + UNGCPRO; + + ii = 0; + + if (greatest_pos_seen > -1) + { + if (copy) + { + result = result_tail = Fcons (XCAR (list), Qnil); + list = XCDR (list); + ii = 1; + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len) + { + if (ii == greatest_pos_seen) + { + XSETCDR (result_tail, XCDR (tail)); + break; + } + else if (!bit_vector_bit (deleting, ii)) + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + ii++; + } + } + } + else + { + EXTERNAL_LIST_LOOP_DELETE_IF (elt0, list, + bit_vector_bit (deleting, ii++)); + } + } + + return result; +} + +DEFUN ("delete-duplicates", Fdelete_duplicates, 1, MANY, 0, /* +Remove all duplicate elements from SEQUENCE, destructively. + +If SEQUENCE is a list and has duplicates, modify and return it. Note that +SEQUENCE may start with an element to be deleted; because of this, if +modifying a variable, be sure to write `(setq VARIABLE (delete-duplicates +VARIABLE))' to be certain to have a list without duplicate elements. + +If SEQUENCE is an array and has duplicates, return a newly-allocated array +of the same type comprising all unique elements of SEQUENCE. + +If there are no duplicate elements in SEQUENCE, return it unmodified. + +See `remove*' for the meaning of the keywords. See `remove-duplicates' for +a non-destructive version of this function. + +arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence = args[0], tail = sequence, keyed = Qnil, elt = Qnil; + Lisp_Object elt0 = Qnil, 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; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Fdelete_duplicates, nargs, args, 6, + (test, key, test_not, start, end, from_end), + (start = Qzero)); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end); + } + + CHECK_KEY_ARGUMENT (key); + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + if (CONSP (sequence)) + { + if (NILP (from_end)) + { + Lisp_Object prev_tail = Qnil; + Elemcount deleted = 0; + + GCPRO2 (tail, keyed); + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + { + if (starting <= ii && ii < ending) + { + keyed = KEY (key, elt); + positioned + = list_position_cons_before (&ignore, keyed, + XCDR (tail), check_test, + test_not_unboundp, test, key, + 0, make_int (max (starting + - (ii + 1), + 0)), + make_int (ending + - (ii + 1))); + if (!NILP (positioned)) + { + sequence = XCDR (tail); + deleted++; + } + else + { + break; + } + } + else + { + break; + } + + ii++; + } + } + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt0, sequence, tail, len) + { + if (!(starting <= ii && ii <= ending)) + { + prev_tail = tail; + ii++; + continue; + } + + keyed = KEY (key, elt0); + positioned + = list_position_cons_before (&ignore, keyed, XCDR (tail), + check_test, test_not_unboundp, + test, key, 0, + make_int (max (starting + - (ii + 1), 0)), + make_int (ending - (ii + 1))); + if (!NILP (positioned)) + { + /* We know this isn't the first iteration of the loop, + because we advanced above to the point where we have at + least one non-duplicate entry at the head of the + list. */ + XSETCDR (prev_tail, XCDR (tail)); + len = 0; + deleted++; + } + else + { + prev_tail = tail; + if (ii >= ending) + { + break; + } + } + + ii++; + } + } + UNGCPRO; + + if ((ii < starting || (ii < ending && !NILP (end)))) + { + check_sequence_range (args[0], start, end, + make_int (deleted + + XINT (Flength (args[0])))); + } + } + else + { + sequence = list_delete_duplicates_from_end (sequence, check_test, + test_not_unboundp, + test, key, start, end, + 0); + } + } + else if (STRINGP (sequence)) + { + if (EQ (Qidentity, key)) + { + /* We know all the elements will be characters; set check_test to + reflect that. This isn't useful if KEY is not #'identity, since + it may return non-characters for the elements. */ + check_test = get_check_test_function (make_char ('a'), + &test, test_not, + Qnil, Qnil, key, + &test_not_unboundp); + } + + if (NILP (from_end)) + { + Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0; + Ibyte *staging = alloca_ibytes (byte_len), *staging_cursor = staging; + Ibyte *cursor = XSTRING_DATA (sequence), *startp = cursor; + Elemcount deleted = 0; + + elt = Qnil; + GCPRO1 (elt); + + while (cursor_offset < byte_len) + { + if (starting <= ii && ii < ending) + { + Ibyte *cursor0 = cursor; + Bytecount cursor0_offset; + Boolint delete_this = 0; + + elt = KEY (key, make_char (itext_ichar (cursor))); + INC_IBYTEPTR (cursor0); + cursor0_offset = cursor0 - startp; + + for (jj = ii + 1; jj < ending && cursor0_offset < byte_len; + jj++) + { + if (check_test (test, key, elt, + make_char (itext_ichar (cursor0))) + == test_not_unboundp) + { + delete_this = 1; + deleted++; + break; + } + + startp = XSTRING_DATA (sequence); + cursor0 = startp + cursor0_offset; + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor0)) + { + mapping_interaction_error (Qdelete_duplicates, + sequence); + } + + INC_IBYTEPTR (cursor0); + cursor0_offset = cursor0 - startp; + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qdelete_duplicates, sequence); + } + + if (!delete_this) + { + staging_cursor + += itext_copy_ichar (cursor, staging_cursor); + + } + } + else + { + staging_cursor += itext_copy_ichar (cursor, staging_cursor); + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + + if (0 != deleted) + { + sequence = make_string (staging, staging_cursor - staging); + } + } + else + { + Elemcount deleted = 0; + Ibyte *staging = alloca_ibytes ((len = string_char_length (sequence)) + * MAX_ICHAR_LEN); + Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence); + Ibyte *endp = startp + XSTRING_LENGTH (sequence); + struct Lisp_Bit_Vector *deleting + = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector) + + (sizeof (long) + * (BIT_VECTOR_LONG_STORAGE (len) + - 1))); + + check_sequence_range (sequence, start, end, make_integer (len)); + + /* For the from_end t case; transform contents to an array with + elements addressable in constant time, use the same algorithm + as for vectors. */ + deleting->size = len; + memset (&(deleting->bits), 0, + sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); + + while (startp < endp) + { + itext_copy_ichar (startp, staging + (ii * MAX_ICHAR_LEN)); + INC_IBYTEPTR (startp); + ii++; + } + + GCPRO1 (elt); + + ending = min (ending, len); + + for (ii = ending - 1; ii >= starting; ii--) + { + elt = KEY (key, make_char (itext_ichar (staging + + (ii * MAX_ICHAR_LEN)))); + for (jj = ii - 1; jj >= starting; jj--) + { + if (check_test (test, key, elt, + make_char (itext_ichar + (staging + (jj * MAX_ICHAR_LEN)))) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + + UNGCPRO; + + if (0 != deleted) + { + startp = XSTRING_DATA (sequence); + + for (ii = 0; ii < len; ii++) + { + if (!bit_vector_bit (deleting, ii)) + { + staging_cursor + += itext_copy_ichar (startp, staging_cursor); + } + + INC_IBYTEPTR (startp); + } + + sequence = make_string (staging, staging_cursor - staging); + } + } + } + else if (VECTORP (sequence)) + { + Elemcount deleted = 0; + Lisp_Object *content = XVECTOR_DATA (sequence); + struct Lisp_Bit_Vector *deleting; + + len = XVECTOR_LENGTH (sequence); + check_sequence_range (sequence, start, end, make_integer (len)); + + deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector) + + (sizeof (long) + * (BIT_VECTOR_LONG_STORAGE (len) + - 1))); + deleting->size = len; + memset (&(deleting->bits), 0, + sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); + + GCPRO1 (elt); + + ending = min (ending, len); + + if (NILP (from_end)) + { + for (ii = starting; ii < ending; ii++) + { + elt = KEY (key, content[ii]); + + for (jj = ii + 1; jj < ending; jj++) + { + if (check_test (test, key, elt, content[jj]) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + } + else + { + for (ii = ending - 1; ii >= starting; ii--) + { + elt = KEY (key, content[ii]); + + for (jj = ii - 1; jj >= starting; jj--) + { + if (check_test (test, key, elt, content[jj]) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + } + + UNGCPRO; + + if (deleted) + { + Lisp_Object res = make_vector (len - deleted, Qnil), + *res_content = XVECTOR_DATA (res); + + for (ii = jj = 0; ii < len; ii++) + { + if (!bit_vector_bit (deleting, ii)) + { + res_content[jj++] = content[ii]; + } + } + + sequence = res; + } + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence); + Elemcount deleted = 0; + /* I'm a little irritated at this. Basically, the only reasonable + thing delete-duplicates should do if handed a bit vector is return + something of maximum length two and minimum length 0 (because + that's the possible number of distinct elements if EQ is regarded + as identity, which it should be). But to support arbitrary TEST + and KEY arguments, which may be non-deterministic from our + perspective, we need the same algorithm as for vectors. */ + struct Lisp_Bit_Vector *deleting; + + len = bit_vector_length (bv); + + if (EQ (Qidentity, key)) + { + /* We know all the elements will be bits; set check_test to + reflect that. This isn't useful if KEY is not #'identity, since + it may return non-bits for the elements. */ + check_test = get_check_test_function (Qzero, &test, test_not, + Qnil, Qnil, key, + &test_not_unboundp); + } + + check_sequence_range (sequence, start, end, make_integer (len)); + + deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector) + + (sizeof (long) + * (BIT_VECTOR_LONG_STORAGE (len) + - 1))); + deleting->size = len; + memset (&(deleting->bits), 0, + sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); + + ending = min (ending, len); + + GCPRO1 (elt); + + if (NILP (from_end)) + { + for (ii = starting; ii < ending; ii++) + { + elt = KEY (key, make_int (bit_vector_bit (bv, ii))); + + for (jj = ii + 1; jj < ending; jj++) + { + if (check_test (test, key, elt, + make_int (bit_vector_bit (bv, jj))) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + } + else + { + for (ii = ending - 1; ii >= starting; ii--) + { + elt = KEY (key, make_int (bit_vector_bit (bv, ii))); + + for (jj = ii - 1; jj >= starting; jj--) + { + if (check_test (test, key, elt, + make_int (bit_vector_bit (bv, jj))) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + } + + UNGCPRO; + + if (deleted) + { + Lisp_Object res = make_bit_vector (len - deleted, Qzero); + Lisp_Bit_Vector *resbv = XBIT_VECTOR (res); + + for (ii = jj = 0; ii < len; ii++) + { + if (!bit_vector_bit (deleting, ii)) + { + set_bit_vector_bit (resbv, jj++, bit_vector_bit (bv, ii)); + } + } + + sequence = res; + } + } + + return sequence; +} + +DEFUN ("remove-duplicates", Fremove_duplicates, 1, MANY, 0, /* +Remove duplicate elements from SEQUENCE, non-destructively. + +If there are no duplicate elements in SEQUENCE, return it unmodified; +otherwise, return a new object. If SEQUENCE is a list, the new object may +share list structure with SEQUENCE. + +See `remove*' for the meaning of the keywords. + +arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence = args[0], tail = sequence, 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; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1, gcpro2, gcpro3; + + PARSE_KEYWORDS (Fremove_duplicates, nargs, args, 6, + (test, key, test_not, start, end, from_end), + (start = Qzero)); + + CHECK_SEQUENCE (sequence); + + if (!CONSP (sequence)) + { + return Fdelete_duplicates (nargs, args); + } + + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end); + } + + if (NILP (key)) + { + key = Qidentity; + } + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + if (NILP (from_end)) + { + Lisp_Object ignore = Qnil; + + GCPRO3 (tail, keyed, result); + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + { + if (starting <= ii && ii <= ending) + { + keyed = KEY (key, elt); + positioned + = list_position_cons_before (&ignore, keyed, XCDR (tail), + check_test, test_not_unboundp, + test, key, 0, + make_int (max (starting + - (ii + 1), 0)), + make_int (ending - (ii + 1))); + if (!NILP (positioned)) + { + sequence = result = result_tail = XCDR (tail); + } + else + { + break; + } + } + else + { + break; + } + + ii++; + } + } + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt0, sequence, tail, len) + { + if (!(starting <= ii && ii <= ending)) + { + ii++; + continue; + } + + /* For this algorithm, each time we encounter an object to be + removed, copy the output list from the tail beyond the last + 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); + positioned + = list_position_cons_before (&ignore, keyed, XCDR (tail), + check_test, test_not_unboundp, + test, key, 0, + make_int (max (starting - (ii + 1), + 0)), + make_int (ending - (ii + 1))); + if (!NILP (positioned)) + { + if (EQ (result, sequence)) + { + result = cons_with_shared_tail + = Fcons (XCAR (sequence), XCDR (sequence)); + } + + result_tail = cons_with_shared_tail; + cursor = XCDR (cons_with_shared_tail); + + while (!EQ (cursor, tail) && !NILP (cursor)) + { + XSETCDR (result_tail, Fcons (XCAR (cursor), Qnil)); + result_tail = XCDR (result_tail); + cursor = XCDR (cursor); + } + + XSETCDR (result_tail, XCDR (tail)); + cons_with_shared_tail = result_tail; + } + + ii++; + } + } + UNGCPRO; + + if ((ii < starting || (ii < ending && !NILP (end)))) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + } + else + { + result = list_delete_duplicates_from_end (sequence, check_test, + test_not_unboundp, test, key, + start, end, 1); + } + + return result; +} +#undef KEY + +DEFUN ("nreverse", Fnreverse, 1, 1, 0, /* +Reverse SEQUENCE, destructively. + +Return the beginning of the reversed sequence, which will be a distinct Lisp +object if SEQUENCE is a list with length greater than one. See also +`reverse', the non-destructive version of this function. +*/ + (sequence)) +{ + CHECK_SEQUENCE (sequence); + + if (CONSP (sequence)) + { + struct gcpro gcpro1, gcpro2; + Lisp_Object prev = Qnil; + Lisp_Object tail = sequence; + + /* We gcpro our args; see `nconc' */ + GCPRO2 (prev, tail); + while (!NILP (tail)) + { + REGISTER Lisp_Object next; + CONCHECK_CONS (tail); + next = XCDR (tail); + XCDR (tail) = prev; + prev = tail; + tail = next; + } + UNGCPRO; + return prev; + } + else if (VECTORP (sequence)) + { + Elemcount length = XVECTOR_LENGTH (sequence), ii = length; + Elemcount half = length / 2; + Lisp_Object swap = Qnil; + CHECK_LISP_WRITEABLE (sequence); + + while (ii > half) + { + swap = XVECTOR_DATA (sequence) [length - ii]; + XVECTOR_DATA (sequence) [length - ii] + = XVECTOR_DATA (sequence) [ii - 1]; + XVECTOR_DATA (sequence) [ii - 1] = swap; + --ii; + } + } + else if (STRINGP (sequence)) + { + Elemcount length = XSTRING_LENGTH (sequence); + Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length; + Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length; + + CHECK_LISP_WRITEABLE (sequence); + while (cursor < endp) + { + staging_end -= itext_ichar_len (cursor); + itext_copy_ichar (cursor, staging_end); + INC_IBYTEPTR (cursor); + } + + assert (staging == staging_end); + + memcpy (XSTRING_DATA (sequence), staging, length); + init_string_ascii_begin (sequence); + bump_string_modiff (sequence); + sledgehammer_check_ascii_begin (sequence); + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence); + Elemcount length = bit_vector_length (bv), ii = length; + Elemcount half = length / 2; + int swap = 0; + + CHECK_LISP_WRITEABLE (sequence); + while (ii > half) + { + swap = bit_vector_bit (bv, length - ii); + set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1)); + set_bit_vector_bit (bv, ii - 1, swap); + --ii; + } + } + else + { + assert (NILP (sequence)); + } + + return sequence; +} + +DEFUN ("reverse", Freverse, 1, 1, 0, /* +Reverse SEQUENCE, copying. Return the reversed sequence. +See also the function `nreverse', which is used more often. +*/ + (sequence)) +{ + Lisp_Object result = Qnil; + + CHECK_SEQUENCE (sequence); + + if (CONSP (sequence)) + { + EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + result = Fcons (elt, result); + } + } + else if (VECTORP (sequence)) + { + Elemcount length = XVECTOR_LENGTH (sequence), ii = length; + Lisp_Object *staging = alloca_array (Lisp_Object, length); + + while (ii > 0) + { + staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1]; + --ii; + } + + result = Fvector (length, staging); + } + else if (STRINGP (sequence)) + { + Elemcount length = XSTRING_LENGTH (sequence); + Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length; + Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length; + + while (cursor < endp) + { + staging_end -= itext_ichar_len (cursor); + itext_copy_ichar (cursor, staging_end); + INC_IBYTEPTR (cursor); + } + + assert (staging == staging_end); + + result = make_string (staging, length); + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res; + Elemcount length = bit_vector_length (bv), ii = length; + + result = make_bit_vector (length, Qzero); + res = XBIT_VECTOR (result); + + while (ii > 0) + { + set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1)); + --ii; + } + } + else + { + assert (NILP (sequence)); + } + + return result; +} + +static Lisp_Object +c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2, + Lisp_Object pred, Lisp_Object key_func) +{ + struct gcpro gcpro1; + Lisp_Object args[3]; + + /* We could use call2() and call3() here, but we're called O(nlogn) times + for a sequence of length n, it make some sense to inline them. */ + args[0] = key_func; + args[1] = obj1; + args[2] = Qnil; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + + obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + + args[1] = obj2; + obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + + args[0] = pred; + args[1] = obj1; + args[2] = obj2; + + RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args))); +} + +static Lisp_Object +c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2, + Lisp_Object pred, Lisp_Object UNUSED (key_func)) +{ + struct gcpro gcpro1; + Lisp_Object args[3]; + + /* This is (almost) the implementation of call2, it makes some sense to + inline it here. */ + args[0] = pred; + args[1] = obj1; + args[2] = obj2; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + + RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args))); +} + +Lisp_Object +list_merge (Lisp_Object org_l1, Lisp_Object org_l2, + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func) +{ + Lisp_Object value; + Lisp_Object tail; + Lisp_Object tem; + Lisp_Object l1, l2; + Lisp_Object tortoises[2]; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; + int l1_count = 0, l2_count = 0; + + l1 = org_l1; + l2 = org_l2; + tail = Qnil; + value = Qnil; + tortoises[0] = org_l1; + tortoises[1] = org_l2; + + if (NULL == c_predicate) + { + c_predicate = EQ (key_func, Qidentity) ? + c_merge_predicate_nokey : c_merge_predicate_key; + } + + /* It is sufficient to protect org_l1 and org_l2. + When l1 and l2 are updated, we copy the new values + back into the org_ vars. */ + + GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]); + gcpro5.nvars = 2; + + while (1) + { + if (NILP (l1)) + { + UNGCPRO; + if (NILP (tail)) + return l2; + Fsetcdr (tail, l2); + return value; + } + if (NILP (l2)) + { + UNGCPRO; + if (NILP (tail)) + return l1; + Fsetcdr (tail, l1); + return value; + } + + if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func))) + { + tem = l1; + l1 = Fcdr (l1); + org_l1 = l1; + + if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (l1_count & 1) + { + if (!CONSP (tortoises[0])) + { + mapping_interaction_error (Qmerge, tortoises[0]); + } + + tortoises[0] = XCDR (tortoises[0]); + } + + if (EQ (org_l1, tortoises[0])) + { + signal_circular_list_error (org_l1); + } + } + } + else + { + tem = l2; + l2 = Fcdr (l2); + org_l2 = l2; + + if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (l2_count & 1) + { + if (!CONSP (tortoises[1])) + { + mapping_interaction_error (Qmerge, tortoises[1]); + } + + tortoises[1] = XCDR (tortoises[1]); + } + + if (EQ (org_l2, tortoises[1])) + { + signal_circular_list_error (org_l2); + } + } + } + + if (NILP (tail)) + value = tem; + else + Fsetcdr (tail, tem); + + tail = tem; + } +} + +static void +array_merge (Lisp_Object *dest, Elemcount dest_len, + Lisp_Object *front, Elemcount front_len, + Lisp_Object *back, Elemcount back_len, + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func) +{ + Elemcount ii, fronting, backing; + Lisp_Object *front_staging = front; + Lisp_Object *back_staging = back; + struct gcpro gcpro1, gcpro2; + + assert (dest_len == (back_len + front_len)); + + if (0 == dest_len) + { + return; + } + + if (front >= dest && front < (dest + dest_len)) + { + front_staging = alloca_array (Lisp_Object, front_len); + + for (ii = 0; ii < front_len; ++ii) + { + front_staging[ii] = front[ii]; + } + } + + if (back >= dest && back < (dest + dest_len)) + { + back_staging = alloca_array (Lisp_Object, back_len); + + for (ii = 0; ii < back_len; ++ii) + { + back_staging[ii] = back[ii]; + } + } + + GCPRO2 (front_staging[0], back_staging[0]); + gcpro1.nvars = front_len; + gcpro2.nvars = back_len; + + for (ii = fronting = backing = 0; ii < dest_len; ++ii) + { + if (fronting >= front_len) + { + while (ii < dest_len) + { + dest[ii] = back_staging[backing]; + ++ii, ++backing; + } + UNGCPRO; + return; + } + + if (backing >= back_len) + { + while (ii < dest_len) + { + dest[ii] = front_staging[fronting]; + ++ii, ++fronting; + } + UNGCPRO; + return; + } + + if (NILP (c_predicate (back_staging[backing], front_staging[fronting], + predicate, key_func))) + { + dest[ii] = front_staging[fronting]; + ++fronting; + } + else + { + dest[ii] = back_staging[backing]; + ++backing; + } + } + + UNGCPRO; +} + +static Lisp_Object +list_array_merge_into_list (Lisp_Object list, + Lisp_Object *array, Elemcount array_len, + Lisp_Object (*c_predicate) (Lisp_Object, + Lisp_Object, + Lisp_Object, + Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func, + Boolint reverse_order) +{ + Lisp_Object tail = Qnil, value = Qnil, tortoise = list; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + Elemcount array_index = 0; + int looped = 0; + + GCPRO4 (list, tail, value, tortoise); + + while (1) + { + if (NILP (list)) + { + UNGCPRO; + + if (NILP (tail)) + { + return Flist (array_len, array); + } + + Fsetcdr (tail, Flist (array_len - array_index, array + array_index)); + return value; + } + + if (array_index >= array_len) + { + UNGCPRO; + if (NILP (tail)) + { + return list; + } + + Fsetcdr (tail, list); + return value; + } + + + if (reverse_order ? + !NILP (c_predicate (Fcar (list), array [array_index], predicate, + key_func)) : + NILP (c_predicate (array [array_index], Fcar (list), predicate, + key_func))) + { + if (NILP (tail)) + { + value = tail = list; + } + else + { + Fsetcdr (tail, list); + tail = XCDR (tail); + } + + list = Fcdr (list); + } + else + { + if (NILP (tail)) + { + value = tail = Fcons (array [array_index], Qnil); + } + else + { + Fsetcdr (tail, Fcons (array [array_index], tail)); + tail = XCDR (tail); + } + ++array_index; + } + + if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (looped & 1) + { + tortoise = XCDR (tortoise); + } + + if (EQ (list, tortoise)) + { + signal_circular_list_error (list); + } + } + } +} + +static void +list_list_merge_into_array (Lisp_Object *output, Elemcount output_len, + Lisp_Object list_one, Lisp_Object list_two, + Lisp_Object (*c_predicate) (Lisp_Object, + Lisp_Object, + Lisp_Object, + Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func) +{ + Elemcount output_index = 0; + + while (output_index < output_len) + { + if (NILP (list_one)) + { + while (output_index < output_len) + { + output [output_index] = Fcar (list_two); + list_two = Fcdr (list_two), ++output_index; + } + return; + } + + if (NILP (list_two)) + { + while (output_index < output_len) + { + output [output_index] = Fcar (list_one); + list_one = Fcdr (list_one), ++output_index; + } + return; + } + + if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate, + key_func))) + { + output [output_index] = XCAR (list_one); + list_one = XCDR (list_one); + } + else + { + output [output_index] = XCAR (list_two); + list_two = XCDR (list_two); + } + + ++output_index; + + /* No need to check for circularity. */ + } +} + +static void +list_array_merge_into_array (Lisp_Object *output, Elemcount output_len, + Lisp_Object list, + Lisp_Object *array, Elemcount array_len, + Lisp_Object (*c_predicate) (Lisp_Object, + Lisp_Object, + Lisp_Object, + Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func, + Boolint reverse_order) +{ + Elemcount output_index = 0, array_index = 0; + + while (output_index < output_len) + { + if (NILP (list)) + { + if (array_len - array_index != output_len - output_index) + { + mapping_interaction_error (Qmerge, list); + } + + while (array_index < array_len) + { + output [output_index++] = array [array_index++]; + } + + return; + } + + if (array_index >= array_len) + { + while (output_index < output_len) + { + output [output_index++] = Fcar (list); + list = Fcdr (list); + } + + return; + } + + if (reverse_order ? + !NILP (c_predicate (Fcar (list), array [array_index], predicate, + key_func)) : + NILP (c_predicate (array [array_index], Fcar (list), predicate, + key_func))) + { + output [output_index] = XCAR (list); + list = XCDR (list); + } + else + { + output [output_index] = array [array_index]; + ++array_index; + } + + ++output_index; + } +} + +#define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \ + do { \ + c_array = alloca_array (Lisp_Object, len); \ + for (counter = 0; counter < len; ++counter) \ + { \ + c_array[counter] = make_char (itext_ichar (strdata)); \ + INC_IBYTEPTR (strdata); \ + } \ + } while (0) + +#define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \ + c_array = alloca_array (Lisp_Object, len); \ + for (counter = 0; counter < len; ++counter) \ + { \ + c_array[counter] = make_int (bit_vector_bit (v, counter)); \ + } \ + } while (0) + DEFUN ("merge", Fmerge, 4, MANY, 0, /* Destructively merge SEQUENCE-ONE and SEQUENCE-TWO, producing a new sequence. ＠＠ -3944,7 +6396,7 ＠＠ int internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - if (depth > 200) + if (depth + lisp_eval_depth > max_lisp_eval_depth) stack_overflow ("Stack overflow in equal", Qunbound); QUIT; if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) ＠＠ -3989,7 +6441,7 ＠＠ int internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) { - if (depth > 200) + if (depth + lisp_eval_depth > max_lisp_eval_depth) stack_overflow ("Stack overflow in equalp", Qunbound); QUIT; ＠＠ -4065,7 +6517,7 ＠＠ static int internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - if (depth > 200) + if (depth + lisp_eval_depth > max_lisp_eval_depth) stack_overflow ("Stack overflow in equal", Qunbound); QUIT; if (HACKEQ_UNSAFE (obj1, obj2)) ＠＠ -4231,21 +6683,23 ＠＠ { Elemcount counting = 0; - EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) - { - if (counting >= starting) - { - if (counting < ending) - { - XSETCAR (tail, item); - } - else if (counting == ending) - { - break; - } - } - ++counting; - } + { + EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (counting >= starting) + { + if (counting < ending) + { + XSETCAR (tail, item); + } + else if (counting == ending) + { + break; + } + } + ++counting; + } + } if (counting < starting || (counting != ending && !NILP (end))) { ＠＠ -6079,6 +8533,8 ＠＠ *p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor; Charcount ii = 0, len1 = string_char_length (sequence1); + check_sequence_range (sequence1, start1, end1, make_int (len1)); + while (ii < starting2 && p2 < p2end) { INC_IBYTEPTR (p2); ＠＠ -6188,6 +8644,2414 ＠＠ return result; } +DEFUN ("nsubstitute", Fnsubstitute, 3, MANY, 0, /* +Substitute NEW for OLD in SEQUENCE. + +This is a destructive function; it reuses the storage of SEQUENCE whenever +possible. See `remove*' for the meaning of the keywords. + +arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil; + 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, + from_end), (start = Qzero)); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end); + } + + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (BIGNUMP (count)) + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN; + } + else + { + counting = XINT (count); + } + + if (counting <= 0) + { + return sequence; + } + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (CONSP (sequence)) + { + Lisp_Object elt; + + if (!NILP (count) && !NILP (from_end)) + { + Lisp_Object present = count_with_tail (&elt, nargs - 1, args + 1, + Qnsubstitute); + + if (ZEROP (present)) + { + return sequence; + } + + presenting = XINT (present); + presenting = presenting <= counting ? 0 : presenting - counting; + } + + GCPRO1 (tail); + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len) + { + if (!(ii < ending)) + { + break; + } + + if (starting <= ii && + check_test (test, key, item, elt) == test_not_unboundp + && (presenting ? encountered++ >= presenting +: encountered++ < counting)) + { + CHECK_LISP_WRITEABLE (tail); + XSETCAR (tail, new_); + } + else if (!presenting && encountered >= counting) + { + break; + } + + ii++; + } + } + UNGCPRO; + + if ((ii < starting || (ii < ending && !NILP (end))) + && encountered < counting) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + } + else if (STRINGP (sequence)) + { + Ibyte *staging, new_bytes[MAX_ICHAR_LEN], *staging_cursor; + Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp; + Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence); + Bytecount new_len; + Lisp_Object character; + + CHECK_CHAR_COERCE_INT (new_); + + new_len = set_itext_ichar (new_bytes, XCHAR (new_)); + + /* Worst case scenario; new char is four octets long, all the old ones + were one octet long, all the old ones match. */ + staging = alloca_ibytes (XSTRING_LENGTH (sequence) * new_len); + staging_cursor = staging; + + if (!NILP (count) && !NILP (from_end)) + { + Lisp_Object present = count_with_tail (&character, nargs - 1, + args + 1, Qnsubstitute); + + if (ZEROP (present)) + { + return sequence; + } + + presenting = XINT (present); + + /* If there are fewer items in the string than we have + permission to change, we don't need to differentiate + between the :from-end nil and :from-end t + cases. Otherwise, presenting is the number of matching + items we need to ignore before we start to change. */ + presenting = presenting <= counting ? 0 : presenting - counting; + } + + ii = 0; + while (cursor_offset < byte_len && ii < ending) + { + if (ii >= starting) + { + character = make_char (itext_ichar (cursor)); + + if ((check_test (test, key, item, character) + == test_not_unboundp) + && (presenting ? encountered++ >= presenting : + encountered++ < counting)) + { + staging_cursor + += itext_copy_ichar (new_bytes, staging_cursor); + } + else + { + staging_cursor + += itext_copy_ichar (cursor, staging_cursor); + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qnsubstitute, sequence); + } + } + else + { + staging_cursor += itext_copy_ichar (cursor, staging_cursor); + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + + if (0 != encountered) + { + CHECK_LISP_WRITEABLE (sequence); + replace_string_range (sequence, Qzero, make_int (ii), + staging, staging_cursor); + } + } + else + { + Elemcount positioning; + Lisp_Object object = Qnil; + + len = XINT (Flength (sequence)); + check_sequence_range (sequence, start, end, make_int (len)); + + position0 = position (&object, item, sequence, check_test, + test_not_unboundp, test, key, start, end, from_end, + Qnil, Qnsubstitute); + + if (NILP (position0)) + { + return sequence; + } + + positioning = XINT (position0); + ending = min (len, ending); + + Faset (sequence, position0, new_); + encountered = 1; + + if (NILP (from_end)) + { + for (ii = positioning + 1; ii < ending; ii++) + { + object_ = Faref (sequence, make_int (ii)); + + if (check_test (test, key, item, object_) == test_not_unboundp + && encountered++ < counting) + { + Faset (sequence, make_int (ii), new_); + } + else if (encountered == counting) + { + break; + } + } + } + else + { + for (ii = positioning - 1; ii >= starting; ii--) + { + object_ = Faref (sequence, make_int (ii)); + + if (check_test (test, key, item, object_) == test_not_unboundp + && encountered++ < counting) + { + Faset (sequence, make_int (ii), new_); + } + else if (encountered == counting) + { + break; + } + } + } + } + + return sequence; +} + +DEFUN ("substitute", Fsubstitute, 3, MANY, 0, /* +Substitute NEW for OLD in SEQUENCE. + +This is a non-destructive function; it makes a copy of SEQUENCE if necessary +to avoid corrupting the original SEQUENCE. + +See `remove*' for the meaning of the keywords. + +arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) COUNT) +*/ + (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 object, position0, matched_count; + 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 (Fsubstitute, nargs, args, 9, + (test, if_, if_not, test_not, key, start, end, count, + from_end), (start = Qzero, count = Qunbound)); + + CHECK_SEQUENCE (sequence); + + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end); + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (!UNBOUNDP (count)) + { + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (BIGNUMP (count)) + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN; + } + else + { + counting = XINT (count); + } + + if (counting <= 0) + { + return sequence; + } + } + } + + if (!CONSP (sequence)) + { + position0 = position (&object, item, sequence, check_test, + test_not_unboundp, test, key, start, end, from_end, + Qnil, Qsubstitute); + + if (NILP (position0)) + { + return sequence; + } + else + { + args[2] = Fcopy_sequence (sequence); + return Fnsubstitute (nargs, args); + } + } + + matched_count = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute); + + if (ZEROP (matched_count)) + { + return sequence; + } + + if (!NILP (count) && !NILP (from_end)) + { + presenting = XINT (matched_count); + presenting = presenting <= counting ? 0 : presenting - counting; + } + + GCPRO1 (tailing); + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tailing, len) + { + if (EQ (tail, tailing)) + { + if (NILP (result)) + { + RETURN_UNGCPRO (XCDR (tail)); + } + + XSETCDR (result_tail, XCDR (tail)); + RETURN_UNGCPRO (result); + } + else if (starting <= ii && ii < ending && + (check_test (test, key, item, elt) == test_not_unboundp) + && (presenting ? encountered++ >= presenting +: encountered++ < counting)) + { + if (NILP (result)) + { + result = result_tail = Fcons (new_, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (new_, Qnil)); + result_tail = XCDR (result_tail); + } + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + + if (ii == ending) + { + break; + } + + ii++; + } + } + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + + return result; +} + +static Lisp_Object +subst (Lisp_Object new_, Lisp_Object old, Lisp_Object tree, int depth) +{ + if (depth + lisp_eval_depth > max_lisp_eval_depth) + { + stack_overflow ("Stack overflow in subst", tree); + } + + if (EQ (tree, old)) + { + return new_; + } + else if (CONSP (tree)) + { + Lisp_Object aa = subst (new_, old, XCAR (tree), depth + 1); + Lisp_Object dd = subst (new_, old, XCDR (tree), depth + 1); + + if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree))) + { + return tree; + } + else + { + return Fcons (aa, dd); + } + } + else + { + return tree; + } +} + +static Lisp_Object +sublis (Lisp_Object alist, Lisp_Object tree, + 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; + + 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) + { + tailed = tail; + + if (check_test (test, key, elt_car, 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)); + } + } + } + if (!CONSP (tree)) + { + RETURN_UNGCPRO (tree); + } + + aa = sublis (alist, XCAR (tree), check_test, test_not_unboundp, test, key, + depth + 1); + dd = sublis (alist, XCDR (tree), check_test, test_not_unboundp, test, key, + depth + 1); + + if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree))) + { + RETURN_UNGCPRO (tree); + } + + RETURN_UNGCPRO (Fcons (aa, dd)); +} + +DEFUN ("sublis", Fsublis, 2, MANY, 0, /* +Perform substitutions indicated by ALIST in TREE (non-destructively). +Return a copy of TREE with all matching elements replaced. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object alist = args[0], tree = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fsublis, nargs, args, 5, (test, if_, test_not, if_not, key), + (key = Qidentity)); + + if (NILP (key)) + { + key = Qidentity; + } + + get_check_match_function (&test, test_not, if_, if_not, + /* sublis() is going to apply the key, don't ask + for a match function that will do it for + us. */ + Qidentity, &test_not_unboundp, &check_test); + + if (CONSP (alist) && NILP (XCDR (alist)) && CONSP (XCAR (alist)) + && EQ (key, Qidentity) && 1 == test_not_unboundp + && (check_eq_nokey == check_test || + (check_eql_nokey == check_test && + !NON_FIXNUM_NUMBER_P (XCAR (XCAR (alist)))))) + { + /* #'subst with #'eq is very cheap indeed; call it. */ + return subst (XCDR (XCAR (alist)), XCAR (XCAR (alist)), tree, 0); + } + + return sublis (alist, tree, check_test, test_not_unboundp, test, key, 0); +} + +static Lisp_Object +nsublis (Lisp_Object alist, Lisp_Object tree, + check_test_func_t check_test, + 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; + int count = 0; + + if (depth + lisp_eval_depth > max_lisp_eval_depth) + { + stack_overflow ("Stack overflow in nsublis", tree); + } + + GCPRO4 (tailed, alist, tree_saved, keyed); + + while (CONSP (tree)) + { + Boolint replaced = 0; + keyed = KEY (key, XCAR (tree)); + + { + EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail) + { + tailed = tail; + + if (check_test (test, key, elt_car, keyed) == test_not_unboundp) + { + CHECK_LISP_WRITEABLE (tree); + /* See comment in sublis() on using elt_cdr. */ + XSETCAR (tree, XCDR (elt)); + replaced = 1; + break; + } + } + } + + if (!replaced) + { + if (CONSP (XCAR (tree))) + { + nsublis (alist, XCAR (tree), check_test, test_not_unboundp, + test, key, depth + 1); + } + } + + keyed = KEY (key, XCDR (tree)); + replaced = 0; + + { + EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail) + { + tailed = tail; + + if (check_test (test, key, elt_car, keyed) == test_not_unboundp) + { + CHECK_LISP_WRITEABLE (tree); + /* See comment in sublis() on using elt_cdr. */ + XSETCDR (tree, XCDR (elt)); + tree = Qnil; + break; + } + } + } + + if (!NILP (tree)) + { + tree = XCDR (tree); + } + + if (++count > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (count & 1) + { + tortoise = XCDR (tortoise); + } + + if (EQ (tortoise, tree)) + { + signal_circular_list_error (tree); + } + } + } + + RETURN_UNGCPRO (tree_saved); +} + +DEFUN ("nsublis", Fnsublis, 2, MANY, 0, /* +Perform substitutions indicated by ALIST in TREE (destructively). +Any matching element of TREE is changed via a call to `setcar'. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object alist = args[0], tree = args[1], tailed = Qnil, keyed = Qnil; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Fnsublis, nargs, args, 5, (test, if_, test_not, if_not, key), + (key = Qidentity)); + + if (NILP (key)) + { + key = Qidentity; + } + + get_check_match_function (&test, test_not, if_, if_not, + /* nsublis() is going to apply the key, don't ask + for a match function that will do it for + us. */ + Qidentity, &test_not_unboundp, &check_test); + + GCPRO2 (tailed, keyed); + + keyed = KEY (key, tree); + + { + /* 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) + { + tailed = tail; + + if (check_test (test, key, elt_car, keyed) == test_not_unboundp) + { + /* See comment in sublis() on using elt_cdr. */ + RETURN_UNGCPRO (XCDR (elt)); + } + } + } + + UNGCPRO; + + return nsublis (alist, tree, check_test, test_not_unboundp, test, key, 0); +} + +DEFUN ("subst", Fsubst, 3, MANY, 0, /* +Substitute NEW for OLD everywhere in TREE (non-destructively). + +Return a copy of TREE with all elements `eql' to OLD replaced by NEW. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]), + Qnil); + args[1] = alist; + result = Fsublis (nargs - 1, args + 1); + free_cons (XCAR (alist)); + free_cons (alist); + + return result; +} + +DEFUN ("nsubst", Fnsubst, 3, MANY, 0, /* +Substitute NEW for OLD everywhere in TREE (destructively). + +Any element of TREE which is `eql' to OLD is changed to NEW (via a call to +`setcar'). + +See `member*' for the meaning of the keywords. + +arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]), + Qnil); + args[1] = alist; + result = Fnsublis (nargs - 1, args + 1); + free_cons (XCAR (alist)); + free_cons (alist); + + return result; +} + +static Boolint +tree_equal (Lisp_Object tree1, Lisp_Object tree2, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, int depth) +{ + Lisp_Object tortoise1 = tree1, tortoise2 = tree2; + struct gcpro gcpro1, gcpro2; + int count = 0; + Boolint result; + + if (depth + lisp_eval_depth > max_lisp_eval_depth) + { + stack_overflow ("Stack overflow in tree-equal", tree1); + } + + GCPRO2 (tree1, tree2); + + while (CONSP (tree1) && CONSP (tree2) + && tree_equal (XCAR (tree1), XCAR (tree2), check_test, + test_not_unboundp, test, key, depth + 1)) + { + tree1 = XCDR (tree1); + tree2 = XCDR (tree2); + + if (++count > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (count & 1) + { + tortoise1 = XCDR (tortoise1); + tortoise2 = XCDR (tortoise2); + } + + if (EQ (tortoise1, tree1)) + { + signal_circular_list_error (tree1); + } + + if (EQ (tortoise2, tree2)) + { + signal_circular_list_error (tree2); + } + } + } + + if (CONSP (tree1) || CONSP (tree2)) + { + UNGCPRO; + return 0; + } + + result = check_test (test, key, tree1, tree2) == test_not_unboundp; + UNGCPRO; + + return result; +} + +DEFUN ("tree-equal", Ftree_equal, 2, MANY, 0, /* +Return t if TREE1 and TREE2 have `eql' leaves. + +Atoms are compared by `eql', unless another test is specified using +:test; cons cells are compared recursively. + +See `union' for the meaning of :test, :test-not and :key. + +arguments: (TREE1 TREE2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object tree1 = args[0], tree2 = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Ftree_equal, nargs, args, 3, (test, key, test_not), + (key = Qidentity)); + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + return tree_equal (tree1, tree2, check_test, test_not_unboundp, test, key, + 0) ? Qt : Qnil; +} + +static Lisp_Object +mismatch_from_end (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1, + Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint UNUSED (return_sequence1_index)) +{ + Elemcount sequence1_len = XINT (Flength (sequence1)); + Elemcount sequence2_len = XINT (Flength (sequence2)), ii = 0; + Elemcount starting1, ending1, starting2, ending2; + Lisp_Object *sequence1_storage = NULL, *sequence2_storage = NULL; + struct gcpro gcpro1, gcpro2; + + check_sequence_range (sequence1, start1, end1, make_int (sequence1_len)); + starting1 = XINT (start1); + ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX; + ending1 = min (ending1, sequence1_len); + + check_sequence_range (sequence2, start2, end2, make_int (sequence2_len)); + starting2 = XINT (start2); + ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX; + ending2 = min (ending2, sequence2_len); + + if (LISTP (sequence1)) + { + Lisp_Object *saving; + sequence1_storage = saving + = alloca_array (Lisp_Object, ending1 - starting1); + + { + EXTERNAL_LIST_LOOP_2 (elt, sequence1) + { + if (starting1 <= ii && ii < ending1) + { + *saving++ = elt; + } + else if (ii == ending1) + { + break; + } + + ++ii; + } + } + } + else if (STRINGP (sequence1)) + { + const Ibyte *cursor = string_char_addr (sequence1, starting1); + + STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence1_storage, ii, + ending1 - starting1); + + } + else if (BIT_VECTORP (sequence1)) + { + Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence1); + sequence1_storage = alloca_array (Lisp_Object, ending1 - starting1); + for (ii = starting1; ii < ending1; ++ii) + { + sequence1_storage[ii - starting1] + = make_int (bit_vector_bit (vv, ii)); + } + } + else + { + sequence1_storage = XVECTOR_DATA (sequence1) + starting1; + } + + ii = 0; + + if (LISTP (sequence2)) + { + Lisp_Object *saving; + sequence2_storage = saving + = alloca_array (Lisp_Object, ending2 - starting2); + + { + EXTERNAL_LIST_LOOP_2 (elt, sequence2) + { + if (starting2 <= ii && ii < ending2) + { + *saving++ = elt; + } + else if (ii == ending2) + { + break; + } + + ++ii; + } + } + } + else if (STRINGP (sequence2)) + { + const Ibyte *cursor = string_char_addr (sequence2, starting2); + + STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence2_storage, ii, + ending2 - starting2); + + } + else if (BIT_VECTORP (sequence2)) + { + Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence2); + sequence2_storage = alloca_array (Lisp_Object, ending2 - starting2); + for (ii = starting2; ii < ending2; ++ii) + { + sequence2_storage[ii - starting2] + = make_int (bit_vector_bit (vv, ii)); + } + } + else + { + sequence2_storage = XVECTOR_DATA (sequence2) + starting2; + } + + GCPRO2 (sequence1_storage[0], sequence2_storage[0]); + gcpro1.nvars = ending1 - starting1; + gcpro2.nvars = ending2 - starting2; + + while (ending1 > starting1 && ending2 > starting2) + { + --ending1; + --ending2; + + if (check_match (test, key, sequence1_storage[ending1 - starting1], + sequence2_storage[ending2 - starting2]) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (ending1 + 1); + } + } + + UNGCPRO; + + if (ending1 > starting1 || ending2 > starting2) + { + return make_integer (ending1); + } + + return Qnil; +} + +static Lisp_Object +mismatch_list_list (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1, + Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint UNUSED (return_list_index)) +{ + Lisp_Object sequence1_tortoise = sequence1, sequence2_tortoise = sequence2; + Lisp_Object orig_sequence1 = sequence1, orig_sequence2 = sequence2; + Elemcount ending1 = EMACS_INT_MAX, ending2 = EMACS_INT_MAX; + Elemcount starting1, starting2, counting, startcounting; + Elemcount shortest_len = 0; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX; + starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX; + + if (!NILP (end1)) + { + ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX; + } + + if (!NILP (end2)) + { + ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX; + } + + if (!ZEROP (start1)) + { + sequence1 = Fnthcdr (start1, sequence1); + + if (NILP (sequence1)) + { + check_sequence_range (sequence1_tortoise, start1, end1, + Flength (sequence1_tortoise)); + /* Give up early here. */ + return Qnil; + } + + ending1 -= starting1; + starting1 = 0; + sequence1_tortoise = sequence1; + } + + if (!ZEROP (start2)) + { + sequence2 = Fnthcdr (start2, sequence2); + + if (NILP (sequence2)) + { + check_sequence_range (sequence2_tortoise, start2, end2, + Flength (sequence2_tortoise)); + return Qnil; + } + + ending2 -= starting2; + starting2 = 0; + sequence2_tortoise = sequence2; + } + + GCPRO4 (sequence1, sequence2, sequence1_tortoise, sequence2_tortoise); + + counting = startcounting = min (ending1, ending2); + + while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2)) + { + if (check_match (test, key, + CONSP (sequence1) ? XCAR (sequence1) +: Fcar (sequence1), + CONSP (sequence2) ? XCAR (sequence2) +: Fcar (sequence2) ) != test_not_unboundp) + { + UNGCPRO; + return make_integer (XINT (start1) + shortest_len); + } + + sequence1 = CONSP (sequence1) ? XCDR (sequence1) : Fcdr (sequence1); + sequence2 = CONSP (sequence2) ? XCDR (sequence2) : Fcdr (sequence2); + + shortest_len++; + + if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (counting & 1) + { + sequence1_tortoise = XCDR (sequence1_tortoise); + sequence2_tortoise = XCDR (sequence2_tortoise); + } + + if (EQ (sequence1, sequence1_tortoise)) + { + signal_circular_list_error (sequence1); + } + + if (EQ (sequence2, sequence2_tortoise)) + { + signal_circular_list_error (sequence2); + } + } + } + + UNGCPRO; + + if (NILP (sequence1)) + { + Lisp_Object args[] = { start1, make_int (shortest_len) }; + check_sequence_range (orig_sequence1, start1, end1, + Fplus (countof (args), args)); + } + + if (NILP (sequence2)) + { + Lisp_Object args[] = { start2, make_int (shortest_len) }; + check_sequence_range (orig_sequence2, start2, end2, + Fplus (countof (args), args)); + } + + if ((!NILP (end1) && shortest_len != ending1 - starting1) || + (!NILP (end2) && shortest_len != ending2 - starting2)) + { + return make_integer (XINT (start1) + shortest_len); + } + + if ((NILP (end1) && CONSP (sequence1)) || (NILP (end2) && CONSP (sequence2))) + { + return make_integer (XINT (start1) + shortest_len); + } + + return Qnil; +} + +static Lisp_Object +mismatch_list_string (Lisp_Object list, Lisp_Object list_start, + Lisp_Object list_end, + Lisp_Object string, Lisp_Object string_start, + Lisp_Object string_end, + check_test_func_t check_match, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint return_list_index) +{ + Ibyte *string_data = XSTRING_DATA (string), *startp = string_data; + Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string); + Elemcount char_count = 0, list_starting, list_ending; + Elemcount string_starting, string_ending; + Lisp_Object character, orig_list = list; + struct gcpro gcpro1; + + list_ending = INTP (list_end) ? XINT (list_end) : 1 + EMACS_INT_MAX; + list_starting = INTP (list_start) ? XINT (list_start) : 1 + EMACS_INT_MAX; + + string_ending = INTP (string_end) ? XINT (string_end) : 1 + EMACS_INT_MAX; + string_starting + = INTP (string_start) ? XINT (string_start) : 1 + EMACS_INT_MAX; + + while (char_count < string_starting && string_offset < string_len) + { + INC_IBYTEPTR (string_data); + string_offset = string_data - startp; + char_count++; + } + + if (!ZEROP (list_start)) + { + list = Fnthcdr (list_start, list); + if (NILP (list)) + { + check_sequence_range (orig_list, list_start, list_end, + Flength (orig_list)); + return Qnil; + } + + list_ending -= list_starting; + list_starting = 0; + } + + GCPRO1 (list); + + while (list_starting < list_ending && string_starting < string_ending + && string_offset < string_len && !NILP (list)) + { + character = make_char (itext_ichar (string_data)); + + if (return_list_index) + { + if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list), + character) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (XINT (list_start) + char_count); + } + } + else + { + if (check_match (test, key, character, + CONSP (list) ? XCAR (list) : Fcar (list)) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (char_count); + } + } + + list = CONSP (list) ? XCDR (list) : Fcdr (list); + + startp = XSTRING_DATA (string); + string_data = startp + string_offset; + if (string_len != XSTRING_LENGTH (string) + || !valid_ibyteptr_p (string_data)) + { + mapping_interaction_error (Qmismatch, string); + } + + list_starting++; + string_starting++; + char_count++; + INC_IBYTEPTR (string_data); + string_offset = string_data - startp; + } + + UNGCPRO; + + if (NILP (list)) + { + Lisp_Object args[] = { list_start, make_int (char_count) }; + check_sequence_range (orig_list, list_start, list_end, + Fplus (countof (args), args)); + } + + if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string)) + { + check_sequence_range (string, string_start, string_end, + make_int (char_count)); + } + + if ((NILP (string_end) ? + string_offset < string_len : string_starting < string_ending) || + (NILP (list_end) ? !NILP (list) : list_starting < list_ending)) + { + return make_integer (return_list_index ? XINT (list_start) + char_count : + char_count); + } + + return Qnil; +} + +static Lisp_Object +mismatch_list_array (Lisp_Object list, Lisp_Object list_start, + Lisp_Object list_end, + Lisp_Object array, Lisp_Object array_start, + Lisp_Object array_end, + check_test_func_t check_match, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint return_list_index) +{ + Elemcount ii = 0, list_starting, list_ending; + Elemcount array_starting, array_ending, array_len; + Lisp_Object orig_list = list; + struct gcpro gcpro1; + + list_ending = INTP (list_end) ? XINT (list_end) : 1 + EMACS_INT_MAX; + list_starting = INTP (list_start) ? XINT (list_start) : 1 + EMACS_INT_MAX; + + array_ending = INTP (array_end) ? XINT (array_end) : 1 + EMACS_INT_MAX; + array_starting = INTP (array_start) ? XINT (array_start) : 1 + EMACS_INT_MAX; + array_len = XINT (Flength (array)); + + array_ending = min (array_ending, array_len); + + check_sequence_range (array, array_start, array_end, make_int (array_len)); + + if (!ZEROP (list_start)) + { + list = Fnthcdr (list_start, list); + if (NILP (list)) + { + check_sequence_range (orig_list, list_start, list_end, + Flength (orig_list)); + return Qnil; + } + + list_ending -= list_starting; + list_starting = 0; + } + + GCPRO1 (list); + + while (list_starting < list_ending && array_starting < array_ending + && !NILP (list)) + { + if (return_list_index) + { + if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list), + Faref (array, make_int (array_starting))) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (XINT (list_start) + ii); + } + } + else + { + if (check_match (test, key, Faref (array, make_int (array_starting)), + CONSP (list) ? XCAR (list) : Fcar (list)) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (array_starting); + } + } + + list = CONSP (list) ? XCDR (list) : Fcdr (list); + list_starting++; + array_starting++; + ii++; + } + + UNGCPRO; + + if (NILP (list)) + { + Lisp_Object args[] = { list_start, make_int (ii) }; + check_sequence_range (orig_list, list_start, list_end, + Fplus (countof (args), args)); + } + + if (array_starting < array_ending || + (NILP (list_end) ? !NILP (list) : list_starting < list_ending)) + { + return make_integer (return_list_index ? XINT (list_start) + ii : + array_starting); + } + + return Qnil; +} + +static Lisp_Object +mismatch_string_array (Lisp_Object string, Lisp_Object string_start, + Lisp_Object string_end, + Lisp_Object array, Lisp_Object array_start, + Lisp_Object array_end, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint return_string_index) +{ + Ibyte *string_data = XSTRING_DATA (string), *startp = string_data; + Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string); + Elemcount char_count = 0, array_starting, array_ending, array_length; + Elemcount string_starting, string_ending; + Lisp_Object character; + + array_starting = INTP (array_start) ? XINT (array_start) : 1 + EMACS_INT_MAX; + array_ending = INTP (array_end) ? XINT (array_end) : 1 + EMACS_INT_MAX; + array_length = XINT (Flength (array)); + check_sequence_range (array, array_start, array_end, make_int (array_length)); + array_ending = min (array_ending, array_length); + + string_ending = INTP (string_end) ? XINT (string_end) : 1 + EMACS_INT_MAX; + string_starting + = INTP (string_start) ? XINT (string_start) : 1 + EMACS_INT_MAX; + + while (char_count < string_starting && string_offset < string_len) + { + INC_IBYTEPTR (string_data); + string_offset = string_data - startp; + char_count++; + } + + while (array_starting < array_ending && string_starting < string_ending + && string_offset < string_len) + { + character = make_char (itext_ichar (string_data)); + + if (return_string_index) + { + if (check_match (test, key, character, + Faref (array, make_int (array_starting))) + != test_not_unboundp) + { + return make_integer (char_count); + } + } + else + { + if (check_match (test, key, + Faref (array, make_int (array_starting)), + character) + != test_not_unboundp) + { + return make_integer (XINT (array_start) + char_count); + } + } + + startp = XSTRING_DATA (string); + string_data = startp + string_offset; + if (string_len != XSTRING_LENGTH (string) + || !valid_ibyteptr_p (string_data)) + { + mapping_interaction_error (Qmismatch, string); + } + + array_starting++; + string_starting++; + char_count++; + INC_IBYTEPTR (string_data); + string_offset = string_data - startp; + } + + if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string)) + { + check_sequence_range (string, string_start, string_end, + make_int (char_count)); + } + + if ((NILP (string_end) ? + string_offset < string_len : string_starting < string_ending) || + (NILP (array_end) ? !NILP (array) : array_starting < array_ending)) + { + return make_integer (return_string_index ? char_count : + XINT (array_start) + char_count); + } + + return Qnil; +} + +static Lisp_Object +mismatch_string_string (Lisp_Object string1, + Lisp_Object string1_start, Lisp_Object string1_end, + Lisp_Object string2, Lisp_Object string2_start, + Lisp_Object string2_end, + check_test_func_t check_match, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint UNUSED (return_string1_index)) +{ + Ibyte *string1_data = XSTRING_DATA (string1), *startp1 = string1_data; + Bytecount string1_offset = 0, string1_len = XSTRING_LENGTH (string1); + Ibyte *string2_data = XSTRING_DATA (string2), *startp2 = string2_data; + Bytecount string2_offset = 0, string2_len = XSTRING_LENGTH (string2); + Elemcount char_count1 = 0, string1_starting, string1_ending; + Elemcount char_count2 = 0, string2_starting, string2_ending; + Lisp_Object character1, character2; + + string1_ending = INTP (string1_end) ? XINT (string1_end) : 1 + EMACS_INT_MAX; + string1_starting + = INTP (string1_start) ? XINT (string1_start) : 1 + EMACS_INT_MAX; + + string2_starting + = INTP (string2_start) ? XINT (string2_start) : 1 + EMACS_INT_MAX; + string2_ending = INTP (string2_end) ? XINT (string2_end) : 1 + EMACS_INT_MAX; + + while (char_count1 < string1_starting && string1_offset < string1_len) + { + INC_IBYTEPTR (string1_data); + string1_offset = string1_data - startp1; + char_count1++; + } + + while (char_count2 < string2_starting && string2_offset < string2_len) + { + INC_IBYTEPTR (string2_data); + string2_offset = string2_data - startp2; + char_count2++; + } + + while (string2_starting < string2_ending && string1_starting < string1_ending + && string1_offset < string1_len && string2_offset < string2_len) + { + character1 = make_char (itext_ichar (string1_data)); + character2 = make_char (itext_ichar (string2_data)); + + if (check_match (test, key, character1, character2) + != test_not_unboundp) + { + return make_integer (char_count1); + } + + startp1 = XSTRING_DATA (string1); + string1_data = startp1 + string1_offset; + if (string1_len != XSTRING_LENGTH (string1) + || !valid_ibyteptr_p (string1_data)) + { + mapping_interaction_error (Qmismatch, string1); + } + + startp2 = XSTRING_DATA (string2); + string2_data = startp2 + string2_offset; + if (string2_len != XSTRING_LENGTH (string2) + || !valid_ibyteptr_p (string2_data)) + { + mapping_interaction_error (Qmismatch, string2); + } + + string2_starting++; + string1_starting++; + char_count1++; + char_count2++; + INC_IBYTEPTR (string1_data); + string1_offset = string1_data - startp1; + INC_IBYTEPTR (string2_data); + string2_offset = string2_data - startp2; + } + + if (string1_data == XSTRING_DATA (string1) + XSTRING_LENGTH (string1)) + { + check_sequence_range (string1, string1_start, string1_end, + make_int (char_count1)); + } + + if (string2_data == XSTRING_DATA (string2) + XSTRING_LENGTH (string2)) + { + check_sequence_range (string2, string2_start, string2_end, + make_int (char_count2)); + } + + if ((!NILP (string1_end) && string1_starting < string1_ending) || + (!NILP (string2_end) && string2_starting < string2_ending)) + { + return make_integer (char_count1); + } + + if ((NILP (string1_end) && string1_data + < (XSTRING_DATA (string1) + XSTRING_LENGTH (string1))) || + (NILP (string2_end) && string2_data + < (XSTRING_DATA (string2) + XSTRING_LENGTH (string2)))) + { + return make_integer (char_count1); + } + + return Qnil; +} + +static Lisp_Object +mismatch_array_array (Lisp_Object array1, Lisp_Object start1, Lisp_Object end1, + Lisp_Object array2, Lisp_Object start2, Lisp_Object end2, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint UNUSED (return_array1_index)) +{ + Elemcount len1 = XINT (Flength (array1)), len2 = XINT (Flength (array2)); + Elemcount ending1 = EMACS_INT_MAX, ending2 = EMACS_INT_MAX; + Elemcount starting1, starting2; + + check_sequence_range (array1, start1, end1, make_int (len1)); + check_sequence_range (array2, start2, end2, make_int (len2)); + + starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX; + starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX; + + if (!NILP (end1)) + { + ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX; + } + + if (!NILP (end2)) + { + ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX; + } + + ending1 = min (ending1, len1); + ending2 = min (ending2, len2); + + while (starting1 < ending1 && starting2 < ending2) + { + if (check_match (test, key, Faref (array1, make_int (starting1)), + Faref (array2, make_int (starting2))) + != test_not_unboundp) + { + return make_integer (starting1); + } + starting1++; + starting2++; + } + + if (starting1 < ending1 || starting2 < ending2) + { + return make_integer (starting1); + } + + return Qnil; +} + +typedef Lisp_Object +(*mismatch_func_t) (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1, + Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint return_list_index); + +static mismatch_func_t +get_mismatch_func (Lisp_Object sequence1, Lisp_Object sequence2, + Lisp_Object from_end, Boolint *return_sequence1_index_out) +{ + CHECK_SEQUENCE (sequence1); + CHECK_SEQUENCE (sequence2); + + if (!NILP (from_end)) + { + *return_sequence1_index_out = 1; + return mismatch_from_end; + } + + if (LISTP (sequence1)) + { + if (LISTP (sequence2)) + { + *return_sequence1_index_out = 1; + return mismatch_list_list; + } + + if (STRINGP (sequence2)) + { + *return_sequence1_index_out = 1; + return mismatch_list_string; + } + + *return_sequence1_index_out = 1; + return mismatch_list_array; + } + + if (STRINGP (sequence1)) + { + if (STRINGP (sequence2)) + { + *return_sequence1_index_out = 1; + return mismatch_string_string; + } + + if (LISTP (sequence2)) + { + *return_sequence1_index_out = 0; + return mismatch_list_string; + } + + *return_sequence1_index_out = 1; + return mismatch_string_array; + } + + if (ARRAYP (sequence1)) + { + if (STRINGP (sequence2)) + { + *return_sequence1_index_out = 0; + return mismatch_string_array; + } + + if (LISTP (sequence2)) + { + *return_sequence1_index_out = 0; + return mismatch_list_array; + } + + *return_sequence1_index_out = 1; + return mismatch_array_array; + } + + RETURN_NOT_REACHED (NULL); + return NULL; +} + +DEFUN ("mismatch", Fmismatch, 2, MANY, 0, /* +Compare SEQUENCE1 with SEQUENCE2, return index of first mismatching element. + +Return nil if the sequences match. If one sequence is a prefix of the +other, the return value indicates the end of the shorter sequence. A +non-nil return value always reflects an index into SEQUENCE1. + +See `search' for the meaning of the keywords." + +arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence1 = args[0], sequence2 = args[1]; + Boolint test_not_unboundp = 1, return_first_index = 0; + check_test_func_t check_match = NULL; + mismatch_func_t mismatch = NULL; + + PARSE_KEYWORDS (Fmismatch, nargs, args, 8, + (test, key, from_end, start1, end1, start2, end2, test_not), + (start1 = start2 = Qzero)); + + CHECK_SEQUENCE (sequence1); + CHECK_SEQUENCE (sequence2); + + CHECK_NATNUM (start1); + CHECK_NATNUM (start2); + + if (!NILP (end1)) + { + CHECK_NATNUM (end1); + } + + if (!NILP (end2)) + { + CHECK_NATNUM (end2); + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, NULL); + mismatch = get_mismatch_func (sequence1, sequence2, from_end, + &return_first_index); + + if (return_first_index) + { + return mismatch (sequence1, start1, end1, sequence2, start2, end2, + check_match, test_not_unboundp, test, key, 1); + } + + return mismatch (sequence2, start2, end2, sequence1, start1, end1, + check_match, test_not_unboundp, test, key, 0); +} + +DEFUN ("search", Fsearch, 2, MANY, 0, /* +Search for SEQUENCE1 as a subsequence of SEQUENCE2. + +Return the index of the leftmost element of the first match found; return +nil if there are no matches. + +In this function, :start1 and :end1 specify a subsequence of SEQUENCE1, and +:start2 and :end2 specify a subsequence of SEQUENCE2. See `remove*' for +details of the other keywords. + +arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence1 = args[0], sequence2 = args[1], position0 = Qnil; + Boolint test_not_unboundp = 1, return_first = 0; + check_test_func_t check_test = NULL, check_match = NULL; + mismatch_func_t mismatch = NULL; + Elemcount starting1 = 0, ending1 = 1 + EMACS_INT_MAX, starting2 = 0; + Elemcount ending2 = 1 + EMACS_INT_MAX, ii = 0; + Elemcount length1; + Lisp_Object object = Qnil; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Fsearch, nargs, args, 8, + (test, key, from_end, start1, end1, start2, end2, test_not), + (start1 = start2 = Qzero)); + + CHECK_SEQUENCE (sequence1); + CHECK_SEQUENCE (sequence2); + CHECK_KEY_ARGUMENT (key); + + CHECK_NATNUM (start1); + starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX; + CHECK_NATNUM (start2); + starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX; + + if (!NILP (end1)) + { + Lisp_Object len1 = Flength (sequence1); + + CHECK_NATNUM (end1); + check_sequence_range (sequence1, start1, end1, len1); + ending1 = min (XINT (end1), XINT (len1)); + } + else + { + end1 = Flength (sequence1); + check_sequence_range (sequence1, start1, end1, end1); + ending1 = XINT (end1); + } + + length1 = ending1 - starting1; + + if (!NILP (end2)) + { + Lisp_Object len2 = Flength (sequence2); + + CHECK_NATNUM (end2); + check_sequence_range (sequence2, start2, end2, len2); + ending2 = min (XINT (end2), XINT (len2)); + } + else + { + end2 = Flength (sequence2); + check_sequence_range (sequence2, start2, end2, end2); + ending2 = XINT (end2); + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + mismatch = get_mismatch_func (sequence1, sequence2, from_end, &return_first); + + if (bytecode_arithcompare (start1, make_integer (ending1)) >= 0) + { + if (NILP (from_end)) + { + return start2; + } + + if (NILP (end2)) + { + return Flength (sequence2); + } + + return end2; + } + + if (NILP (from_end)) + { + Lisp_Object mismatch_start1 = Fadd1 (start1); + Lisp_Object first = KEY (key, Felt (sequence1, start1)); + GCPRO2 (first, mismatch_start1); + + ii = starting2; + while (ii < ending2) + { + position0 = position (&object, first, sequence2, check_test, + test_not_unboundp, test, key, make_int (ii), + end2, Qnil, Qnil, Qsearch); + if (NILP (position0)) + { + UNGCPRO; + return Qnil; + } + + if (length1 + XINT (position0) <= ending2 && + (return_first ? + NILP (mismatch (sequence1, mismatch_start1, end1, + sequence2, + make_int (1 + XINT (position0)), + make_int (length1 + XINT (position0)), + check_match, test_not_unboundp, test, key, 1)) : + NILP (mismatch (sequence2, + make_int (1 + XINT (position0)), + make_int (length1 + XINT (position0)), + sequence1, mismatch_start1, end1, + check_match, test_not_unboundp, test, key, 0)))) + + + { + UNGCPRO; + return position0; + } + + ii = XINT (position0) + 1; + } + + UNGCPRO; + } + else + { + Lisp_Object mismatch_end1 = make_integer (ending1 - 1); + Lisp_Object last = KEY (key, Felt (sequence1, mismatch_end1)); + GCPRO2 (last, mismatch_end1); + + ii = ending2; + while (ii > starting2) + { + position0 = position (&object, last, sequence2, check_test, + test_not_unboundp, test, key, start2, + make_int (ii), Qt, Qnil, Qsearch); + + if (NILP (position0)) + { + UNGCPRO; + return Qnil; + } + + if (XINT (position0) - length1 + 1 >= starting2 && + (return_first ? + NILP (mismatch (sequence1, start1, mismatch_end1, + sequence2, + make_int (XINT (position0) - length1 + 1), + make_int (XINT (position0)), + check_match, test_not_unboundp, test, key, 1)) : + NILP (mismatch (sequence2, + make_int (XINT (position0) - length1 + 1), + make_int (XINT (position0)), + sequence1, start1, mismatch_end1, + check_match, test_not_unboundp, test, key, 0)))) + { + UNGCPRO; + return make_int (XINT (position0) - length1 + 1); + } + + ii = XINT (position0); + } + + UNGCPRO; + } + + return Qnil; +} + +/* These two functions do set operations, those that can be visualised with + Venn diagrams. */ +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 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; + + PARSE_KEYWORDS_8 (caller, nargs, args, 4, (test, key, test_not, stable), + NULL, 2, 0); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt1) && intersectionp) + { + return Qnil; + } + + if (NILP (liszt2)) + { + return intersectionp ? Qnil : liszt1; + } + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + GCPRO3 (tail, keyed, result); + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil)) + != intersectionp) + { + if (EQ (Qsubsetp, caller)) + { + result = Qnil; + break; + } + else if (NILP (stable)) + { + result = Fcons (elt, result); + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + } + } + } + + UNGCPRO; + + return result; +} + +static Lisp_Object +nvenn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp) +{ + Lisp_Object liszt1 = args[0], liszt2 = args[1], tortoise_elt, ignore = Qnil; + Lisp_Object elt = Qnil, tail = Qnil, keyed = Qnil, prev_tail = Qnil; + Elemcount count; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1, gcpro2, gcpro3; + + PARSE_KEYWORDS_8 (caller, nargs, args, 3, (test, key, test_not), + NULL, 2, 0); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt1) && intersectionp) + { + return Qnil; + } + + if (NILP (liszt2)) + { + return intersectionp ? Qnil : liszt1; + } + + 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; + + while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 : + (signal_malformed_list_error (liszt1), 0)) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil)) + == intersectionp) + { + if (NILP (prev_tail)) + { + liszt1 = XCDR (tail); + } + else + { + XSETCDR (prev_tail, XCDR (tail)); + } + + tail = XCDR (tail); + /* List is definitely not circular now! */ + count = 0; + } + else + { + prev_tail = tail; + tail = XCDR (tail); + } + + if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + { + tortoise_elt = XCDR (tortoise_elt); + } + + if (EQ (elt, tortoise_elt)) + { + signal_circular_list_error (liszt1); + } + } + + UNGCPRO; + + return liszt1; +} + +DEFUN ("intersection", Fintersection, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-intersection operation. + +The result list contains all items that appear in both LIST1 and LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. + +A non-nil value for the :stable keyword, not specified by Common Lisp, means +return the items in the order they appear in LIST1. + +See `union' for the meaning of :test, :test-not and :key." + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE) +*/ + (int nargs, Lisp_Object *args)) +{ + return venn (Qintersection, nargs, args, 1); +} + +DEFUN ("nintersection", Fnintersection, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-intersection operation. + +The result list contains all items that appear in both LIST1 and LIST2. +This is a destructive function; it reuses the storage of LIST1 whenever +possible. + +See `union' for the meaning of :test, :test-not and :key." + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + return nvenn (Qnintersection, nargs, args, 1); +} + +DEFUN ("subsetp", Fsubsetp, 2, MANY, 0, /* +Return non-nil if every element of LIST1 also appears in LIST2. + +See `union' for the meaning of the keyword arguments. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + return venn (Qsubsetp, nargs, args, 0); +} + +DEFUN ("set-difference", Fset_difference, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-difference operation. + +The result list contains all items that appear in LIST1 but not LIST2. This +is a non-destructive function; it makes a copy of the data if necessary to +avoid corrupting the original LIST1 and LIST2. + +See `union' for the meaning of :test, :test-not and :key. + +A non-nil value for the :stable keyword, not specified by Common Lisp, means +return the items in the order they appear in LIST1. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE) +*/ + (int nargs, Lisp_Object *args)) +{ + return venn (Qset_difference, nargs, args, 0); +} + +DEFUN ("nset-difference", Fnset_difference, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-difference operation. + +The result list contains all items that appear in LIST1 but not LIST2. This +is a destructive function; it reuses the storage of LIST1 whenever possible. + +See `union' for the meaning of :test, :test-not and :key." + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + return nvenn (Qnset_difference, nargs, args, 0); +} + +DEFUN ("nunion", Fnunion, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-union operation. +The result list contains all items that appear in either LIST1 or LIST2. + +This is a destructive function, it reuses the storage of LIST1 whenever +possible. + +See `union' for the meaning of :test, :test-not and :key. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + args[0] = nvenn (Qnunion, nargs, args, 0); + return bytecode_nconc2 (args); +} + +DEFUN ("union", Funion, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-union operation. +The result list contains all items that appear in either LIST1 or LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. + +The keywords :test and :test-not specify two-argument test and negated-test +predicates, respectively; :test defaults to `eql'. See `member*' for more +information. + +:key specifies a one-argument function that transforms elements of LIST1 +and LIST2 into \"comparison keys\" before the test predicate is applied. +For example, if :key is #'car, then the car of elements from LIST1 is +compared with the car of elements from LIST2. The :key function, however, +does not affect the elements in the returned list, which are taken directly +from the elements in LIST1 and LIST2. + +A non-nil value for the :stable keyword, not specified by Common Lisp, means +return the items of LIST1 in order, followed by the remaining items of LIST2 +in the order they occur in LIST2. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE) +*/ + (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; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL, check_match = NULL; + struct gcpro gcpro1, gcpro2, gcpro3; + + PARSE_KEYWORDS (Funion, nargs, args, 4, (test, key, test_not, stable), NULL); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt1)) + { + return liszt2; + } + + if (NILP (liszt2)) + { + return liszt1; + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + GCPRO3 (tail, keyed, result); + + if (NILP (stable)) + { + result = liszt2; + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil))) + { + /* The Lisp version of #'union used to check which list was + longer, and use that as the tail of the constructed + list. That fails when the order of arguments to TEST is + specified, as is the case for these functions. We could + pass the reverse_check argument to + list_position_cons_before, but that means any key argument + is called an awful lot more, so it's a space win but not + a time win. */ + result = Fcons (elt, result); + } + } + } + } + else + { + result = result_tail = Qnil; + + /* The standard `union' doesn't produce a "stable" union -- it + iterates over the second list instead of the first one, and returns + the values in backwards order. According to the CLTL2 + documentation, `union' is not required to preserve the ordering of + 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) + { + if (NILP (list_position_cons_before (&ignore, elt, liszt1, + check_match, test_not_unboundp, + test, key, 1, Qzero, Qnil))) + { + if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + } + } + } + + result = NILP (result) ? liszt1 : nconc2 (Fcopy_list (liszt1), result); + } + + UNGCPRO; + + return result; +} + +DEFUN ("set-exclusive-or", Fset_exclusive_or, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-exclusive-or operation. + +The result list contains all items that appear in exactly one of LIST1, LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. + +See `union' for the meaning of :test, :test-not and :key. + +A non-nil value for the :stable keyword, not specified by Common Lisp, means +return the items in the order they appear in LIST1, followed by the +remaining items in the order they appear in LIST2. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil; + 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; + + PARSE_KEYWORDS (Fset_exclusive_or, nargs, args, 4, + (test, key, test_not, stable), NULL); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt2)) + { + return liszt1; + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + GCPRO3 (tail, keyed, result); + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil))) + { + if (NILP (stable)) + { + result = Fcons (elt, result); + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + } + } + } + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt2, tail, len) + { + if (NILP (list_position_cons_before (&ignore, elt, liszt1, + check_match, test_not_unboundp, + test, key, 1, Qzero, Qnil))) + { + if (NILP (stable)) + { + result = Fcons (elt, result); + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + } + } + } + UNGCPRO; + + return result; +} + +DEFUN ("nset-exclusive-or", Fnset_exclusive_or, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-exclusive-or operation. + +The result list contains all items that appear in exactly one of LIST1 and +LIST2. This is a destructive function; it reuses the storage of LIST1 and +LIST2 whenever possible. + +See `union' for the meaning of :test, :test-not and :key. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil; + Lisp_Object result = Qnil, tortoise_elt = Qnil, keyed = Qnil, swap; + Lisp_Object prev_tail = Qnil, ignore = Qnil; + Elemcount count; + Boolint test_not_unboundp = 1; + check_test_func_t check_match = NULL, check_test = NULL; + struct gcpro gcpro1, gcpro2, gcpro3; + + PARSE_KEYWORDS (Fnset_exclusive_or, nargs, args, 4, + (test, key, test_not, stable), NULL); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt2)) + { + return liszt1; + } + + 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; + + while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 : + (signal_malformed_list_error (liszt1), 0)) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil))) + { + swap = XCDR (tail); + + if (NILP (prev_tail)) + { + liszt1 = XCDR (tail); + } + else + { + XSETCDR (prev_tail, swap); + } + + XSETCDR (tail, result); + result = tail; + tail = swap; + + /* List is definitely not circular now! */ + count = 0; + } + else + { + prev_tail = tail; + tail = XCDR (tail); + } + + if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + { + tortoise_elt = XCDR (tortoise_elt); + } + + if (EQ (elt, tortoise_elt)) + { + signal_circular_list_error (liszt1); + } + } + + tortoise_elt = tail = liszt2, count = 0; + + while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 : + (signal_malformed_list_error (liszt2), 0)) + { + /* Need to leave the key calculation to list_position_cons_before(). */ + if (NILP (list_position_cons_before (&ignore, elt, liszt1, + check_match, test_not_unboundp, + test, key, 1, Qzero, Qnil))) + { + swap = XCDR (tail); + XSETCDR (tail, result); + result = tail; + tail = swap; + count = 0; + } + else + { + tail = XCDR (tail); + } + + if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + { + tortoise_elt = XCDR (tortoise_elt); + } + + if (EQ (elt, tortoise_elt)) + { + signal_circular_list_error (liszt1); + } + } + + UNGCPRO; + + return result; +} + + Lisp_Object add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string) { ＠＠ -6203,7 +11067,6 ＠＠ Fsymbol_name (symbol)), Qnil); } - /* #### this function doesn't belong in this file! */ ＠＠ -6821,7 +11684,6 ＠＠ INIT_LISP_OBJECT (bit_vector); DEFSYMBOL (Qstring_lessp); - DEFSYMBOL (Qsort); DEFSYMBOL (Qmerge); DEFSYMBOL (Qfill); DEFSYMBOL (Qidentity); ＠＠ -6833,6 +11695,10 ＠＠ defsymbol (&QsortX, "sort*"); DEFSYMBOL (Qreduce); DEFSYMBOL (Qreplace); + DEFSYMBOL (Qposition); + DEFSYMBOL (Qfind); + defsymbol (&QdeleteX, "delete*"); + defsymbol (&QremoveX, "remove*"); DEFSYMBOL (Qmapconcat); defsymbol (&QmapcarX, "mapcar*"); ＠＠ -6846,6 +11712,19 ＠＠ DEFSYMBOL (Qmaplist); DEFSYMBOL (Qmapl); DEFSYMBOL (Qmapcon); + DEFSYMBOL (Qnsubstitute); + DEFSYMBOL (Qdelete_duplicates); + DEFSYMBOL (Qsubstitute); + DEFSYMBOL (Qmismatch); + DEFSYMBOL (Qintersection); + DEFSYMBOL (Qnintersection); + DEFSYMBOL (Qsubsetp); + DEFSYMBOL (Qset_difference); + DEFSYMBOL (Qnset_difference); + DEFSYMBOL (Qnunion); + DEFSYMBOL (Qnintersection); + DEFSYMBOL (Qset_difference); + DEFSYMBOL (Qnset_difference); DEFKEYWORD (Q_from_end); DEFKEYWORD (Q_initial_value); ＠＠ -6853,6 +11732,11 ＠＠ DEFKEYWORD (Q_start2); DEFKEYWORD (Q_end1); DEFKEYWORD (Q_end2); + defkeyword (&Q_if_, ":if"); + DEFKEYWORD (Q_if_not); + DEFKEYWORD (Q_test_not); + DEFKEYWORD (Q_count); + DEFKEYWORD (Q_stable); DEFSYMBOL (Qyes_or_no_p); ＠＠ -6863,6 +11747,7 ＠＠ DEFSUBR (Flength); DEFSUBR (Fsafe_length); DEFSUBR (Flist_length); + DEFSUBR (Fcount); DEFSUBR (Fstring_equal); DEFSUBR (Fcompare_strings); DEFSUBR (Fstring_lessp); ＠＠ -6886,6 +11771,8 ＠＠ DEFSUBR (Fold_member); DEFSUBR (Fmemq); DEFSUBR (Fold_memq); + DEFSUBR (FmemberX); + DEFSUBR (Fadjoin); DEFSUBR (Fassoc); DEFSUBR (Fold_assoc); DEFSUBR (Fassq); ＠＠ -6894,18 +11781,25 ＠＠ DEFSUBR (Fold_rassoc); DEFSUBR (Frassq); DEFSUBR (Fold_rassq); + + DEFSUBR (Fposition); + DEFSUBR (Ffind); + DEFSUBR (Fdelete); DEFSUBR (Fold_delete); DEFSUBR (Fdelq); DEFSUBR (Fold_delq); + DEFSUBR (FdeleteX); + DEFSUBR (FremoveX); DEFSUBR (Fremassoc); DEFSUBR (Fremassq); DEFSUBR (Fremrassoc); DEFSUBR (Fremrassq); + DEFSUBR (Fdelete_duplicates); + DEFSUBR (Fremove_duplicates); DEFSUBR (Fnreverse); DEFSUBR (Freverse); DEFSUBR (FsortX); - Ffset (intern ("sort"), QsortX); DEFSUBR (Fmerge); DEFSUBR (Fplists_eq); DEFSUBR (Fplists_equal); ＠＠ -6933,7 +11827,9 ＠＠ DEFSUBR (Fequalp); DEFSUBR (Fold_equal); DEFSUBR (Ffill); - Ffset (intern ("fillarray"), Qfill); + + DEFSUBR (FassocX); + DEFSUBR (FrassocX); DEFSUBR (Fnconc); DEFSUBR (FmapcarX); ＠＠ -6945,8 +11841,8 ＠＠ DEFSUBR (Fmap_into); DEFSUBR (Fsome); DEFSUBR (Fevery); - Ffset (intern ("mapc-internal"), Fsymbol_function (intern ("mapc"))); - Ffset (intern ("mapcar"), Fsymbol_function (intern ("mapcar*"))); + Ffset (intern ("mapc-internal"), Qmapc); + Ffset (intern ("mapcar"), QmapcarX); DEFSUBR (Fmaplist); DEFSUBR (Fmapl); DEFSUBR (Fmapcon); ＠＠ -6954,6 +11850,25 ＠＠ DEFSUBR (Freduce); DEFSUBR (Freplace_list); DEFSUBR (Freplace); + DEFSUBR (Fsubsetp); + DEFSUBR (Fnsubstitute); + DEFSUBR (Fsubstitute); + DEFSUBR (Fsublis); + DEFSUBR (Fnsublis); + DEFSUBR (Fsubst); + DEFSUBR (Fnsubst); + DEFSUBR (Ftree_equal); + DEFSUBR (Fmismatch); + DEFSUBR (Fsearch); + DEFSUBR (Funion); + DEFSUBR (Fnunion); + DEFSUBR (Fintersection); + DEFSUBR (Fnintersection); + DEFSUBR (Fset_difference); + DEFSUBR (Fnset_difference); + DEFSUBR (Fset_exclusive_or); + DEFSUBR (Fnset_exclusive_or); + DEFSUBR (Fload_average); DEFSUBR (Ffeaturep); DEFSUBR (Frequire); -- “Apart from the nine-banded armadillo, man is the only natural host of Mycobacterium leprae, although it can be grown in the footpads of mice.” -- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches

1 participants
1 comments

[COMMIT] Provide #'device-x-display, as documented in Lispref; thanks, Jeff Mincy. 13 years, 12 months

Aidan Kehoe

Running through some old workspaces on my hard drive and came across this; thanks, Jeff. APPROVE COMMIT NOTE; This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1293716810 0 # Node ID d0bb90d90736edce79c191c51c5592f8ee49ced7 # Parent f87bb35a6b94954e154e89f9138c6dd6487377cc Provide #'device-x-display, as documented in Lispref; thanks, Jeff Mincy. lisp/ChangeLog addition: 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> * x-misc.el (device-x-display): Provide this function, documented in the Lispref for years, but not existing previously. Thank you Julian Bradfield, thank you Jeff Mincy. diff -r f87bb35a6b94 -r d0bb90d90736 lisp/ChangeLog --- a/lisp/ChangeLog Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/ChangeLog Thu Dec 30 13:46:50 2010 +0000 ＠＠ -1,3 +1,10 ＠＠ +2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> + + * x-misc.el (device-x-display): + Provide this function, documented in the Lispref for years, but + not existing previously. Thank you Julian Bradfield, thank you + Jeff Mincy. + 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> * simple.el (assoc-ignore-case): Remove a duplicate definition of diff -r f87bb35a6b94 -r d0bb90d90736 lisp/x-misc.el --- a/lisp/x-misc.el Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/x-misc.el Thu Dec 30 13:46:50 2010 +0000 ＠＠ -86,4 +86,10 ＠＠ (x-bogosity-check-resource name class type)) (x-get-resource name class type locale nil 'warn)) +(defun device-x-display (&optional device) + "If DEVICE is an X11 device, return its DISPLAY. + +DEVICE defaults to the selected device." + (and (eq 'x (device-type device)) (device-connection device))) + ;;; x-misc.el ends here -- “Apart from the nine-banded armadillo, man is the only natural host of Mycobacterium leprae, although it can be grown in the footpads of mice.” -- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

commit: Provide #'device-x-display, as documented in Lispref; thanks, Jeff Mincy. 13 years, 12 months

Aidan Kehoe

changeset: 5324:d0bb90d90736 tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net> date: Thu Dec 30 13:46:50 2010 +0000 files: lisp/ChangeLog lisp/x-misc.el description: Provide #'device-x-display, as documented in Lispref; thanks, Jeff Mincy. lisp/ChangeLog addition: 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> * x-misc.el (device-x-display): Provide this function, documented in the Lispref for years, but not existing previously. Thank you Julian Bradfield, thank you Jeff Mincy. diff -r f87bb35a6b94 -r d0bb90d90736 lisp/ChangeLog --- a/lisp/ChangeLog Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/ChangeLog Thu Dec 30 13:46:50 2010 +0000 ＠＠ -1,3 +1,10 ＠＠ +2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> + + * x-misc.el (device-x-display): + Provide this function, documented in the Lispref for years, but + not existing previously. Thank you Julian Bradfield, thank you + Jeff Mincy. + 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> * simple.el (assoc-ignore-case): Remove a duplicate definition of diff -r f87bb35a6b94 -r d0bb90d90736 lisp/x-misc.el --- a/lisp/x-misc.el Thu Dec 30 01:14:13 2010 +0000 +++ b/lisp/x-misc.el Thu Dec 30 13:46:50 2010 +0000 ＠＠ -86,4 +86,10 ＠＠ (x-bogosity-check-resource name class type)) (x-get-resource name class type locale nil 'warn)) +(defun device-x-display (&optional device) + "If DEVICE is an X11 device, return its DISPLAY. + +DEVICE defaults to the selected device." + (and (eq 'x (device-type device)) (device-connection device))) + ;;; x-misc.el ends here _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

[COMMIT] Test sanity-checking of :start, :end keyword arguments when appropriate. 13 years, 12 months

Aidan Kehoe

APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1293671653 0 # Node ID f87bb35a6b94954e154e89f9138c6dd6487377cc # Parent df125a42c50cdcfa85a5cceae8256cbeb842cac4 Test sanity-checking of :start, :end keyword arguments when appropriate. 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> * automated/lisp-tests.el (wrong-type-argument): Add a missing parenthesis here. Make sure #'count #'position #'find #'delete* #'remove* #'reduce #'delete-duplicates #'remove-duplicates #'replace #'mismatch #'search sanity check their :start and :end keyword arguments. diff -r df125a42c50c -r f87bb35a6b94 tests/ChangeLog --- a/tests/ChangeLog Thu Dec 30 01:04:38 2010 +0000 +++ b/tests/ChangeLog Thu Dec 30 01:14:13 2010 +0000 ＠＠ -1,3 +1,11 ＠＠ +2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net> + + * automated/lisp-tests.el (wrong-type-argument): Add a missing + parenthesis here. + Make sure #'count #'position #'find #'delete* #'remove* #'reduce + #'delete-duplicates #'remove-duplicates #'replace #'mismatch + #'search sanity check their :start and :end keyword arguments. + 2010-11-20 Aidan Kehoe <kehoea(a)parhasard.net> * automated/lisp-tests.el: diff -r df125a42c50c -r f87bb35a6b94 tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Thu Dec 30 01:04:38 2010 +0000 +++ b/tests/automated/lisp-tests.el Thu Dec 30 01:14:13 2010 +0000 ＠＠ -2549,7 +2549,7 ＠＠ (Check-Error wrong-type-argument (fill "1 2 3 4 5" ?1 :start (float most-positive-fixnum))) (Check-Error wrong-type-argument - (fill #*10101010 1 :start (float most-positive-fixnum)) + (fill #*10101010 1 :start (float most-positive-fixnum))) (Check-Error wrong-type-argument (fill '(1 2 3 4 5) 1 :end (float most-positive-fixnum))) (Check-Error wrong-type-argument ＠＠ -2669,4 +2669,125 ＠＠ (replace '(1 2 3 4 5) [5 4 3 2 1] :end2 (1+ most-positive-fixnum)))) +(symbol-macrolet + ((list-length 2048) (vector-length 512) (string-length (* 8192 2))) + (let ((list + ;; CIRCULAR_LIST_SUSPICION_LENGTH is 1024, it's helpful if this list + ;; is longer than that. + (make-list list-length 'make-list)) + (vector (make-vector vector-length 'make-vector)) + (bit-vector (make-bit-vector vector-length 1)) + (string (make-string string-length + (or (decode-char 'ucs #x20ac) ?\xFF))) + (item 'cons)) + (dolist (function '(count position find delete* remove* reduce)) + (Check-Error args-out-of-range + (funcall function item list +:start (1+ list-length) :end (1+ list-length))) + (Check-Error wrong-type-argument + (funcall function item list +:start -1 :end list-length)) + (Check-Error args-out-of-range + (funcall function item list :end (* 2 list-length))) + (Check-Error args-out-of-range + (funcall function item vector +:start (1+ vector-length) :end (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function item vector :start -1)) + (Check-Error args-out-of-range + (funcall function item vector :end (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function item bit-vector +:start (1+ vector-length) :end (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function item bit-vector :start -1)) + (Check-Error args-out-of-range + (funcall function item bit-vector :end (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function item string +:start (1+ string-length) :end (1+ string-length))) + (Check-Error wrong-type-argument + (funcall function item string :start -1)) + (Check-Error args-out-of-range + (funcall function item string :end (* 2 string-length)))) + (dolist (function '(delete-duplicates remove-duplicates)) + (Check-Error args-out-of-range + (funcall function (copy-sequence list) +:start (1+ list-length) :end (1+ list-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence list) +:start -1 :end list-length)) + (Check-Error args-out-of-range + (funcall function (copy-sequence list) +:end (* 2 list-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence vector) +:start (1+ vector-length) :end (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence vector) :start -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence vector) +:end (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence bit-vector) +:start (1+ vector-length) :end (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence bit-vector) :start -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence bit-vector) +:end (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence string) +:start (1+ string-length) :end (1+ string-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence string) :start -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence string) +:end (* 2 string-length)))) + (dolist (function '(replace mismatch search)) + (Check-Error args-out-of-range + (funcall function (copy-sequence list) (copy-sequence list) +:start1 (1+ list-length) :end1 (1+ list-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence list) (copy-sequence list) +:start1 -1 :end1 list-length)) + (Check-Error args-out-of-range + (funcall function (copy-sequence list) (copy-sequence list) +:end1 (* 2 list-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence vector) + (copy-sequence vector) :start1 (1+ vector-length) +:end1 (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence vector) + (copy-sequence vector) :start1 -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence vector) + (copy-sequence vector) +:end1 (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence bit-vector) + (copy-sequence bit-vector) +:start1 (1+ vector-length) +:end1 (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence bit-vector) + (copy-sequence bit-vector) :start1 -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence bit-vector) + (copy-sequence bit-vector) +:end1 (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence string) + (copy-sequence string) +:start1 (1+ string-length) +:end1 (1+ string-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence string) + (copy-sequence string) :start1 -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence string) + (copy-sequence string) +:end1 (* 2 string-length)))))) + ;;; end of lisp-tests.el -- “Apart from the nine-banded armadillo, man is the only natural host of Mycobacterium leprae, although it can be grown in the footpads of mice.” -- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

XEmacs-Patches December 2010