[COMMIT] Add some missing #includes, termcap.c, hopefully fixing Adam Sjoegren's build.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284818634 -3600
# Node ID dd2976af8783fb6a2dead2e09ede9e6bc9aec617
# Parent 5a9aa6c40c9b682671c25ae15f004d12ab9278f9
Add some missing #includes, termcap.c, hopefully fixing Adam Sjoegren's build.
2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
* termcap.c:
Add a couple of missing includes here, which should fix builds
that use this file. (I have no access to such builds, but Mats'
buildbot shows output that indicates they fail at link time since
DEVICE_BAUD_RATE and IS_DIRECTORY_SEP are available.)
diff -r 5a9aa6c40c9b -r dd2976af8783 src/ChangeLog
--- a/src/ChangeLog Sat Sep 18 14:54:45 2010 +0100
+++ b/src/ChangeLog Sat Sep 18 15:03:54 2010 +0100
＠＠ -1,3 +1,11 ＠＠
+2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * termcap.c:
+ Add a couple of missing includes here, which should fix builds
+ that use this file. (I have no access to such builds, but Mats'
+ buildbot shows output that indicates they fail at link time since
+ DEVICE_BAUD_RATE and IS_DIRECTORY_SEP are available.)
+
2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freduce):
diff -r 5a9aa6c40c9b -r dd2976af8783 src/termcap.c
--- a/src/termcap.c Sat Sep 18 14:54:45 2010 +0100
+++ b/src/termcap.c Sat Sep 18 15:03:54 2010 +0100
＠＠ -25,7 +25,10 ＠＠
#ifdef emacs
#include <config.h>
#include "lisp.h" /* For encapsulated open, close, read */
-#include "device.h" /* For DEVICE_BAUD_RATE */
+#include "device.h"
+#include "device-impl.h" /* For DEVICE_BAUD_RATE */
+#include "sysfile.h"
+#include "process.h"
#else /* not emacs */
#include <stdlib.h>
--
“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://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Add some missing #includes, termcap.c, hopefully fixing Adam Sjoegren's build.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5276:dd2976af8783
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sat Sep 18 15:03:54 2010 +0100
files: src/ChangeLog src/termcap.c
description:
Add some missing #includes, termcap.c, hopefully fixing Adam Sjoegren's build.
2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
* termcap.c:
Add a couple of missing includes here, which should fix builds
that use this file. (I have no access to such builds, but Mats'
buildbot shows output that indicates they fail at link time since
DEVICE_BAUD_RATE and IS_DIRECTORY_SEP are available.)
diff -r 5a9aa6c40c9b -r dd2976af8783 src/ChangeLog
--- a/src/ChangeLog Sat Sep 18 14:54:45 2010 +0100
+++ b/src/ChangeLog Sat Sep 18 15:03:54 2010 +0100
＠＠ -1,3 +1,11 ＠＠
+2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * termcap.c:
+ Add a couple of missing includes here, which should fix builds
+ that use this file. (I have no access to such builds, but Mats'
+ buildbot shows output that indicates they fail at link time since
+ DEVICE_BAUD_RATE and IS_DIRECTORY_SEP are available.)
+
2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freduce):
diff -r 5a9aa6c40c9b -r dd2976af8783 src/termcap.c
--- a/src/termcap.c Sat Sep 18 14:54:45 2010 +0100
+++ b/src/termcap.c Sat Sep 18 15:03:54 2010 +0100
＠＠ -25,7 +25,10 ＠＠
#ifdef emacs
#include <config.h>
#include "lisp.h" /* For encapsulated open, close, read */
-#include "device.h" /* For DEVICE_BAUD_RATE */
+#include "device.h"
+#include "device-impl.h" /* For DEVICE_BAUD_RATE */
+#include "sysfile.h"
+#include "process.h"
#else /* not emacs */
#include <stdlib.h>
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Avoid statement-before-declaration problems with strict C89 builds, fns.c
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284818085 -3600
# Node ID 5a9aa6c40c9b682671c25ae15f004d12ab9278f9
# Parent ecdd1daab44709b5ea768d3e5900406c0bc078ce
Avoid statement-before-declaration problems with strict C89 builds, fns.c
src/ChangeLog addition:
2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freduce):
Move statements outside of the braces surrounding the
EXTERNAL_LIST_LOOP_3 macro, fixing strict C89 builds. Thank you
for the report, Vin!
diff -r ecdd1daab447 -r 5a9aa6c40c9b src/ChangeLog
--- a/src/ChangeLog Thu Sep 16 21:00:17 2010 +0100
+++ b/src/ChangeLog Sat Sep 18 14:54:45 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Freduce):
+ Move statements outside of the braces surrounding the
+ EXTERNAL_LIST_LOOP_3 macro, fixing strict C89 builds. Thank you
+ for the report, Vin!
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Flist_length): New, moved here from cl-extra.el, needed
diff -r ecdd1daab447 -r 5a9aa6c40c9b src/fns.c
--- a/src/fns.c Thu Sep 16 21:00:17 2010 +0100
+++ b/src/fns.c Sat Sep 18 14:54:45 2010 +0100
＠＠ -5248,7 +5248,6 ＠＠
}
else if (ending - starting)
{
- ii = 0;
EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
{
/* KEY may amputate the list behind us; make sure what
＠＠ -5264,10 +5263,10 ＠＠
}
}
+ ii = 0;
+
if (ending - starting)
{
- ii = 0;
-
EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
{
/* KEY or FUNCTION may amputate the list behind us; make
--
“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://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Avoid statement-before-declaration problems with strict C89 builds, fns.c
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5275:5a9aa6c40c9b
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sat Sep 18 14:54:45 2010 +0100
files: src/ChangeLog src/fns.c
description:
Avoid statement-before-declaration problems with strict C89 builds, fns.c
src/ChangeLog addition:
2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freduce):
Move statements outside of the braces surrounding the
EXTERNAL_LIST_LOOP_3 macro, fixing strict C89 builds. Thank you
for the report, Vin!
diff -r ecdd1daab447 -r 5a9aa6c40c9b src/ChangeLog
--- a/src/ChangeLog Thu Sep 16 21:00:17 2010 +0100
+++ b/src/ChangeLog Sat Sep 18 14:54:45 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-18 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Freduce):
+ Move statements outside of the braces surrounding the
+ EXTERNAL_LIST_LOOP_3 macro, fixing strict C89 builds. Thank you
+ for the report, Vin!
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Flist_length): New, moved here from cl-extra.el, needed
diff -r ecdd1daab447 -r 5a9aa6c40c9b src/fns.c
--- a/src/fns.c Thu Sep 16 21:00:17 2010 +0100
+++ b/src/fns.c Sat Sep 18 14:54:45 2010 +0100
＠＠ -5248,7 +5248,6 ＠＠
}
else if (ending - starting)
{
- ii = 0;
EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
{
/* KEY may amputate the list behind us; make sure what
＠＠ -5264,10 +5263,10 ＠＠
}
}
+ ii = 0;
+
if (ending - starting)
{
- ii = 0;
-
EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
{
/* KEY or FUNCTION may amputate the list behind us; make
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[PATCH] add vcard to mail-lib
14 years, 3 months
Mike Kupfer
Mike Kupfer
I never got a response to my mail of 2010-07-24 to Simon Josefsson, the
mail-lib maintainer, about moving vcard.el from gnus to mail-lib and
updating it to a more current version.
I've done some light testing with the new vcard and not found any
problems. IIRC, others have had problems getting a response from
Simon.
Would it be possible for someone else to apply this patch? I can remove
the old vcard.el from gnus once this patch has been applied.
thanks,
mike
ChangeLog entry:
2010-08-19 Mike Kupfer <mike.kupfer(a)xemacs.org>
* vcard.el: New, from vm-8.1.90a.
* Makefile (ELCS): Add vcard.elc
diff -r fb89e36970c4 xemacs-packages/mail-lib/Makefile
--- a/xemacs-packages/mail-lib/Makefile Mon Apr 27 15:42:29 2009 -0700
+++ b/xemacs-packages/mail-lib/Makefile Thu Sep 16 15:40:17 2010 -0700
＠＠ -31,7 +31,7 ＠＠
mail-abbrevs.elc mail-extr.elc \
mail-utils.elc mailheader.elc reporter.elc rfc2104.elc rfc822.elc \
rmail-mini.elc rmailout.elc sendmail.elc smtpmail.elc pop3.elc \
- starttls.elc base64.elc netrc.elc tls.elc
+ starttls.elc base64.elc netrc.elc tls.elc vcard.elc
EXPLICIT_DOCS = smtpmail.texi
diff -r fb89e36970c4 xemacs-packages/mail-lib/vcard.el
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/xemacs-packages/mail-lib/vcard.el Thu Sep 16 15:40:17 2010 -0700
＠＠ -0,0 +1,707 ＠＠
+;;; vcard.el --- vcard parsing and display routines
+;;;
+;;; This file is not part of VM; it is a utility used there.
+;;
+;; Copyright (C) 1997, 1999, 2000 Noah S. Friedman
+
+;; Author: Noah Friedman <friedman(a)splode.com>
+;; Maintainer: friedman(a)splode.com
+;; Keywords: vcard, mail, news
+;; Created: 1997-09-27
+
+;; $Id: vcard.el,v 1.11 2000/06/29 17:07:55 friedman Exp $
+
+;; 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.,
+;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+;;; Commentary:
+
+;; Unformatted vcards are just plain ugly. But if you live in the MIME
+;; world, they are a better way of exchanging contact information than
+;; freeform signatures since the former can be automatically parsed and
+;; stored in a searchable index.
+;;
+;; This library of routines provides the back end necessary for parsing
+;; vcards so that they can eventually go into an address book like BBDB
+;; (although this library does not implement that itself). Also included
+;; is a sample pretty-printer which MUAs can use which do not provide their
+;; own vcard formatters.
+
+;; This library does not interface directly with any mail user agents. For
+;; an example of bindings for the VM MUA, see vm-vcard.el available from
+;;
+;; http://www.splode.com/~friedman/software/emacs-lisp/index.html#mail
+;;
+;; Updates to vcard.el should be available there too.
+
+;; The main entry point to this package is `vcard-pretty-print' although
+;; any documented variable or function is considered part of the API for
+;; operating on vcard data.
+
+;; The vcard 2.1 format is defined by the versit consortium.
+;; See http://www.imc.org/pdi/vcard-21.ps
+;;
+;; RFC 2426 defines the vcard 3.0 format.
+;; See ftp://ftp.rfc-editor.org/in-notes/rfc2426.txt
+
+;; A parsed vcard is a list of attributes of the form
+;;
+;; (proplist value1 value2 ...)
+;;
+;; Where proplist is a list of property names and parameters, e.g.
+;;
+;; (property1 (property2 . parameter2) ...)
+;;
+;; Each property has an associated implicit or explicit parameter value
+;; (not to be confused with attribute values; in general this API uses
+;; `parameter' to refer to property values and `value' to refer to attribute
+;; values to avoid confusion). If a property has no explicit parameter value,
+;; the parameter value is considered to be `t'. Any property which does not
+;; exist for an attribute is considered to have a nil parameter.
+
+;; TODO:
+;; * Finish supporting the 3.0 extensions.
+;; Currently, only the 2.1 standard is supported.
+;; * Handle nested vcards and grouped attributes?
+;; (I've never actually seen one of these in use.)
+;; * Handle multibyte charsets.
+;; * Inverse of vcard-parse-string: write .VCF files from alist
+;; * Implement a vcard address book? Or is using BBDB preferable?
+;; * Improve the sample formatter.
+
+;;; Code:
+
+(defgroup vcard nil
+ "Support for the vCard electronic business card format."
+:group 'vcard
+:group 'mail
+:group 'news)
+
+;;;###autoload
+(defcustom vcard-pretty-print-function 'vcard-format-sample-box
+ "*Formatting function used by `vcard-pretty-print'."
+:type 'function
+:group 'vcard)
+
+;;;###autoload
+(defcustom vcard-standard-filters
+ '(vcard-filter-html
+ vcard-filter-adr-newlines
+ vcard-filter-tel-normalize
+ vcard-filter-textprop-cr)
+ "*Standard list of filters to apply to parsed vcard data.
+These filters are applied sequentially to vcard attributes when
+the function `vcard-standard-filter' is supplied as the second argument to
+`vcard-parse'."
+:type 'hook
+:group 'vcard)
+
+
+;;; No user-settable options below.
+
+;; XEmacs 21 ints and chars are disjoint types.
+;; For all else, treat them as the same.
+(defalias 'vcard-char-to-int
+ (if (fboundp 'char-to-int) 'char-to-int 'identity))
+
+;; This is just the version number for this package; it does not refer to
+;; the vcard format specification. Currently, this package does not yet
+;; support the full vcard 3.0 specification.
+;;
+;; Whenever any part of the API defined in this package change in a way
+;; that is not backward-compatible, the major version number here should be
+;; incremented. Backward-compatible additions to the API should be
+;; indicated by increasing the minor version number.
+(defconst vcard-api-version "2.0")
+
+;; The vcard standards allow specifying the encoding for an attribute using
+;; these values as immediate property names, rather than parameters of the
+;; `encoding' property. If these are encountered while parsing, associate
+;; them as parameters of the `encoding' property in the returned structure.
+(defvar vcard-encoding-tags
+ '("quoted-printable" "base64" "8bit" "7bit"))
+
+;; The vcard parser will auto-decode these encodings when they are
+;; encountered. These methods are invoked via vcard-parse-region-value.
+(defvar vcard-region-decoder-methods
+ '(("quoted-printable" . vcard-region-decode-quoted-printable)
+ ("base64" . vcard-region-decode-base64)))
+
+;; This is used by vcard-region-decode-base64
+(defvar vcard-region-decode-base64-table
+ (let* ((a "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+ (len (length a))
+ (tbl (make-vector 123 nil))
+ (i 0))
+ (while (< i len)
+ (aset tbl (vcard-char-to-int (aref a i)) i)
+ (setq i (1+ i)))
+ tbl))
+
+
+;;; This function can be used generically by applications to obtain
+;;; a printable representation of a vcard.
+
+;;;###autoload
+(defun vcard-pretty-print (vcard)
+ "Format VCARD into a string suitable for display to user.
+VCARD can be an unparsed string containing raw VCF vcard data
+or a parsed vcard alist as returned by `vcard-parse-string'.
+
+The result is a string with formatted vcard information suitable for
+insertion into a mime presentation buffer.
+
+The function specified by the variable `vcard-pretty-print-function'
+actually performs the formatting. That function will always receive a
+parsed vcard alist."
+ (and (stringp vcard)
+ (setq vcard (vcard-parse-string vcard)))
+ (funcall vcard-pretty-print-function vcard))
+
+
+;;; Parsing routines
+
+;;;###autoload
+(defun vcard-parse-string (raw &optional filter)
+ "Parse RAW vcard data as a string, and return an alist representing data.
+
+If the optional function FILTER is specified, apply that filter to each
+attribute. If no filter is specified, `vcard-standard-filter' is used.
+
+Filters should accept two arguments: the property list and the value list.
+Modifying in place the property or value list will affect the resulting
+attribute in the vcard alist.
+
+Vcard data is normally in the form
+
+ begin: vcard
+ prop1a: value1a
+ prop2a;prop2b;prop2c=param2c: value2a
+ prop3a;prop3b: value3a;value3b;value3c
+ end: vcard
+
+\(Whitespace around the `:' separating properties and values is optional.\)
+If supplied to this function an alist of the form
+
+ \(\(\(\"prop1a\"\) \"value1a\"\)
+ \(\(\"prop2a\" \"prop2b\" \(\"prop2c\" . \"param2c\"\)\) \"value2a\"\)
+ \(\(\"prop3a\" \"prop3b\"\) \"value3a\" \"value3b\" \"value3c\"\)\)
+
+would be returned."
+ (let ((vcard nil)
+ (buf (generate-new-buffer " *vcard parser work*")))
+ (unwind-protect
+ (save-excursion
+ (set-buffer buf)
+ ;; Make sure last line is newline-terminated.
+ ;; An extra trailing newline is harmless.
+ (insert raw "\n")
+ (setq vcard (vcard-parse-region (point-min) (point-max) filter)))
+ (kill-buffer buf))
+ vcard))
+
+;;;###autoload
+(defun vcard-parse-region (beg end &optional filter)
+ "Parse the raw vcard data in region, and return an alist representing data.
+This function is just like `vcard-parse-string' except that it operates on
+a region of the current buffer rather than taking a string as an argument.
+
+Note: this function modifies the buffer!"
+ (or filter
+ (setq filter 'vcard-standard-filter))
+ (let ((case-fold-search t)
+ (vcard-data nil)
+ (pos (make-marker))
+ (newpos (make-marker))
+ properties value)
+ (save-restriction
+ (narrow-to-region beg end)
+ (save-match-data
+ ;; Unfold folded lines and delete naked carriage returns
+ (goto-char (point-min))
+ (while (re-search-forward "\r$\\|\n[ \t]" nil t)
+ (goto-char (match-beginning 0))
+ (delete-char 1))
+
+ (goto-char (point-min))
+ (re-search-forward "^begin:[ \t]*vcard[ \t]*\n")
+ (set-marker pos (point))
+ (while (and (not (looking-at "^end[ \t]*:[ \t]*vcard[ \t]*$"))
+ (re-search-forward ":[ \t]*" nil t))
+ (set-marker newpos (match-end 0))
+ (setq properties
+ (vcard-parse-region-properties pos (match-beginning 0)))
+ (set-marker pos (marker-position newpos))
+ (re-search-forward "[ \t]*\n")
+ (set-marker newpos (match-end 0))
+ (setq value
+ (vcard-parse-region-value properties pos (match-beginning 0)))
+ (set-marker pos (marker-position newpos))
+ (goto-char pos)
+ (funcall filter properties value)
+ (setq vcard-data (cons (cons properties value) vcard-data)))))
+ (nreverse vcard-data)))
+
+(defun vcard-parse-region-properties (beg end)
+ (downcase-region beg end)
+ (let* ((proplist (vcard-split-string (buffer-substring beg end) ";"))
+ (props proplist)
+ split)
+ (save-match-data
+ (while props
+ (cond ((string-match "=" (car props))
+ (setq split (vcard-split-string (car props) "=" 2))
+ (setcar props (cons (car split) (car (cdr split)))))
+ ((member (car props) vcard-encoding-tags)
+ (setcar props (cons "encoding" (car props)))))
+ (setq props (cdr props))))
+ proplist))
+
+(defun vcard-parse-region-value (proplist beg end)
+ (let* ((encoding (vcard-get-property proplist "encoding"))
+ (decoder (cdr (assoc encoding vcard-region-decoder-methods)))
+ result pos match-beg match-end)
+ (save-restriction
+ (narrow-to-region beg end)
+ (cond (decoder
+ ;; Each `;'-separated field needs to be decoded and saved
+ ;; separately; if the entire region were decoded at once, we
+ ;; would not be able to distinguish between the original `;'
+ ;; chars and those which were encoded in order to quote them
+ ;; against being treated as field separators.
+ (goto-char beg)
+ (setq pos (set-marker (make-marker) (point)))
+ (setq match-beg (make-marker))
+ (setq match-end (make-marker))
+ (save-match-data
+ (while (< pos (point-max))
+ (cond ((search-forward ";" nil t)
+ (set-marker match-beg (match-beginning 0))
+ (set-marker match-end (match-end 0)))
+ (t
+ (set-marker match-beg (point-max))
+ (set-marker match-end (point-max))))
+ (funcall decoder pos match-beg)
+ (setq result (cons (buffer-substring pos match-beg) result))
+ (if (= match-beg match-end)
+ (setq pos (point-max))
+ (set-marker pos (marker-position match-end)))))
+ (setq result (nreverse result))
+ (vcard-set-property proplist "encoding" nil))
+ (t
+ (setq result (vcard-split-string (buffer-string) ";")))))
+ (goto-char (point-max))
+ result))
+
+
+;;; Functions for retrieving property or value information from parsed
+;;; vcard attributes.
+
+(defun vcard-values (vcard have-props &optional non-props limit)
+ "Return the values in VCARD.
+This function is like `vcard-ref' and takes the same arguments, but return
+only the values, not the associated property lists."
+ (mapcar 'cdr (vcard-ref vcard have-props non-props limit)))
+
+(defun vcard-ref (vcard have-props &optional non-props limit)
+ "Return the attributes in VCARD with HAVE-PROPS properties.
+Optional arg NON-PROPS is a list of properties which candidate attributes
+must not have.
+Optional arg LIMIT means return no more than that many attributes.
+
+The attributes in VCARD which have all properties specified by HAVE-PROPS
+but not having any specified by NON-PROPS are returned. The first element
+of each attribute is the actual property list; the remaining elements are
+the values.
+
+If a specific property has an associated parameter \(e.g. an encoding\),
+use the syntax \(\"property\" . \"parameter\"\) to specify it. If property
+parameter is not important or it has no specific parameter, just specify
+the property name as a string."
+ (let ((attrs vcard)
+ (result nil)
+ (count 0))
+ (while (and attrs (or (null limit) (< count limit)))
+ (and (vcard-proplist-all-properties (car (car attrs)) have-props)
+ (not (vcard-proplist-any-properties (car (car attrs)) non-props))
+ (setq result (cons (car attrs) result)
+ count (1+ count)))
+ (setq attrs (cdr attrs)))
+ (nreverse result)))
+
+(defun vcard-proplist-all-properties (proplist props)
+ "Returns nil unless PROPLIST contains all properties specified in PROPS."
+ (let ((result t))
+ (while (and result props)
+ (or (vcard-get-property proplist (car props))
+ (setq result nil))
+ (setq props (cdr props)))
+ result))
+
+(defun vcard-proplist-any-properties (proplist props)
+ "Returns `t' if PROPLIST contains any of the properties specified in PROPS."
+ (let ((result nil))
+ (while (and (not result) props)
+ (and (vcard-get-property proplist (car props))
+ (setq result t))
+ (setq props (cdr props)))
+ result))
+
+(defun vcard-get-property (proplist property)
+ "Return the value from PROPLIST of PROPERTY.
+PROPLIST is a vcard attribute property list, which is normally the first
+element of each attribute entry in a vcard."
+ (or (and (member property proplist) t)
+ (cdr (assoc property proplist))))
+
+(defun vcard-set-property (proplist property value)
+ "In PROPLIST, set PROPERTY to VALUE.
+PROPLIST is a vcard attribute property list.
+If VALUE is nil, PROPERTY is deleted."
+ (let (elt)
+ (cond ((null value)
+ (vcard-delete-property proplist property))
+ ((setq elt (member property proplist))
+ (and value (not (eq value t))
+ (setcar elt (cons property value))))
+ ((setq elt (assoc property proplist))
+ (cond ((eq value t)
+ (setq elt (memq elt proplist))
+ (setcar elt property))
+ (t
+ (setcdr elt value))))
+ ((eq value t)
+ (nconc proplist (cons property nil)))
+ (t
+ (nconc proplist (cons (cons property value) nil))))))
+
+(defun vcard-delete-property (proplist property)
+ "Delete from PROPLIST the specified property PROPERTY.
+This will not succeed in deleting the first member of the proplist, but
+that element should never be deleted since it is the primary key."
+ (let (elt)
+ (cond ((setq elt (member property proplist))
+ (delq (car elt) proplist))
+ ((setq elt (assoc property proplist))
+ (delq (car (memq elt proplist)) proplist)))))
+
+
+;;; Vcard data filters.
+;;;
+;;; Filters receive both the property list and value list and may modify
+;;; either in-place. The return value from the filters are ignored.
+;;;
+;;; These filters can be used for purposes such as removing HTML tags or
+;;; normalizing phone numbers into a standard form.
+
+(defun vcard-standard-filter (proplist values)
+ "Apply filters in `vcard-standard-filters' to attributes."
+ (vcard-filter-apply-filter-list vcard-standard-filters proplist values))
+
+;; This function could be used to dispatch other filter lists.
+(defun vcard-filter-apply-filter-list (filter-list proplist values)
+ (while filter-list
+ (funcall (car filter-list) proplist values)
+ (setq filter-list (cdr filter-list))))
+
+;; Some lusers put HTML (or even javascript!) in their vcards under the
+;; misguided notion that it's a standard feature of vcards just because
+;; Netscape supports this feature. That is wrong; the vcard specification
+;; does not define any html content semantics and most MUAs cannot do
+;; anything with html text except display them unparsed, which is ugly.
+;;
+;; Thank Netscape for abusing the standard and damned near rendering it
+;; useless for interoperability between MUAs.
+;;
+;; This filter does a very rudimentary job.
+(defun vcard-filter-html (proplist values)
+ "Remove HTML tags from attribute values."
+ (save-match-data
+ (while values
+ (while (string-match "<[^<>\n]+>" (car values))
+ (setcar values (replace-match "" t t (car values))))
+ (setq values (cdr values)))))
+
+(defun vcard-filter-adr-newlines (proplist values)
+ "Replace newlines with \"; \" in `adr' values."
+ (and (vcard-get-property proplist "adr")
+ (save-match-data
+ (while values
+ (while (string-match "[\r\n]+" (car values))
+ (setcar values (replace-match "; " t t (car values))))
+ (setq values (cdr values))))))
+
+(defun vcard-filter-tel-normalize (proplist values)
+ "Normalize telephone numbers in `tel' values.
+Spaces and hyphens are replaced with `.'.
+US domestic telephone numbers are replaced with international format."
+ (and (vcard-get-property proplist "tel")
+ (save-match-data
+ (while values
+ (while (string-match "[\t._-]+" (car values))
+ (setcar values (replace-match " " t t (car values))))
+ (and (string-match "^(?\\(\\S-\\S-\\S-\\))? ?\
+\\(\\S-\\S-\\S- \\S-\\S-\\S-\\S-\\)"
+ (car values))
+ (setcar values
+ (replace-match "+1 \\1 \\2" t nil (car values))))
+ (setq values (cdr values))))))
+
+(defun vcard-filter-textprop-cr (proplist values)
+ "Strip carriage returns from text values."
+ (and (vcard-proplist-any-properties
+ proplist '("adr" "email" "fn" "label" "n" "org" "tel" "title" "url"))
+ (save-match-data
+ (while values
+ (while (string-match "\r+" (car values))
+ (setcar values (replace-match "" t t (car values))))
+ (setq values (cdr values))))))
+
+
+;;; Decoding methods.
+
+(defmacro vcard-hexstring-to-ascii (s)
+ (if (string-lessp emacs-version "20")
+ `(format "%c" (car (read-from-string (format "?\\x%s" ,s))))
+ `(format "%c" (string-to-number ,s 16))))
+
+(defun vcard-region-decode-quoted-printable (&optional beg end)
+ (save-excursion
+ (save-restriction
+ (save-match-data
+ (narrow-to-region (or beg (point-min)) (or end (point-max)))
+ (goto-char (point-min))
+ (while (re-search-forward "=\n" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ (goto-char (point-min))
+ (while (re-search-forward "=[0-9A-Za-z][0-9A-Za-z]" nil t)
+ (let ((s (buffer-substring (1+ (match-beginning 0)) (match-end 0))))
+ (replace-match (vcard-hexstring-to-ascii s) t t)))))))
+
+(defun vcard-region-decode-base64 (&optional beg end)
+ (save-restriction
+ (narrow-to-region (or beg (point-min)) (or end (point-max)))
+ (save-match-data
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t\r\n]+" nil t)
+ (delete-region (match-beginning 0) (match-end 0))))
+ (goto-char (point-min))
+ (let ((count 0)
+ (n 0)
+ (c nil))
+ (while (not (eobp))
+ (setq c (char-after (point)))
+ (delete-char 1)
+ (cond ((char-equal c ?=)
+ (if (= count 2)
+ (insert (lsh n -10))
+ ;; count must be 3
+ (insert (lsh n -16) (logand 255 (lsh n -8))))
+ (delete-region (point) (point-max)))
+ (t
+ (setq n (+ n (aref vcard-region-decode-base64-table
+ (vcard-char-to-int c))))
+ (setq count (1+ count))
+ (cond ((= count 4)
+ (insert (logand 255 (lsh n -16))
+ (logand 255 (lsh n -8))
+ (logand 255 n))
+ (setq n 0 count 0))
+ (t
+ (setq n (lsh n 6))))))))))
+
+
+(defun vcard-split-string (string &optional separator limit)
+ "Split STRING at occurences of SEPARATOR. Return a list of substrings.
+Optional argument SEPARATOR can be any regexp, but anything matching the
+ separator will never appear in any of the returned substrings.
+ If not specified, SEPARATOR defaults to \"[ \\f\\t\\n\\r\\v]+\".
+If optional arg LIMIT is specified, split into no more than that many
+ fields \(though it may split into fewer\)."
+ (or separator (setq separator "[ \f\t\n\r\v]+"))
+ (let ((string-list nil)
+ (len (length string))
+ (pos 0)
+ (splits 0)
+ str)
+ (save-match-data
+ (while (<= pos len)
+ (setq splits (1+ splits))
+ (cond ((and limit
+ (>= splits limit))
+ (setq str (substring string pos))
+ (setq pos (1+ len)))
+ ((string-match separator string pos)
+ (setq str (substring string pos (match-beginning 0)))
+ (setq pos (match-end 0)))
+ (t
+ (setq str (substring string pos))
+ (setq pos (1+ len))))
+ (setq string-list (cons str string-list))))
+ (nreverse string-list)))
+
+(defun vcard-copy-tree (tree)
+ "Make a deep copy of nested conses."
+ (cond
+ ((consp tree)
+ (cons (vcard-copy-tree (car tree))
+ (vcard-copy-tree (cdr tree))))
+ (t tree)))
+
+(defun vcard-flatten (l)
+ (if (consp l)
+ (apply 'nconc (mapcar 'vcard-flatten l))
+ (list l)))
+
+
+;;; Sample formatting routines.
+
+(defun vcard-format-sample-box (vcard)
+ "Like `vcard-format-sample-string', but put an ascii box around text."
+ (let* ((lines (vcard-format-sample-lines vcard))
+ (len (vcard-format-sample-max-length lines))
+ (edge (concat "\n+" (make-string (+ len 2) ?-) "+\n"))
+ (line-fmt (format "| %%-%ds |" len))
+ (formatted-lines
+ (mapconcat (function (lambda (s) (format line-fmt s))) lines "\n")))
+ (if (string= formatted-lines "")
+ formatted-lines
+ (concat edge formatted-lines edge))))
+
+(defun vcard-format-sample-string (vcard)
+ "Format VCARD into a string suitable for display to user.
+VCARD should be a parsed vcard alist. The result is a string
+with formatted vcard information which can be inserted into a mime
+presentation buffer."
+ (mapconcat 'identity (vcard-format-sample-lines vcard) "\n"))
+
+(defun vcard-format-sample-lines (vcard)
+ (let* ((name (vcard-format-sample-get-name vcard))
+ (title (vcard-format-sample-values-concat vcard '("title") 1 "; "))
+ (org (vcard-format-sample-values-concat vcard '("org") 1 "; "))
+ (addr (vcard-format-sample-get-address vcard))
+ (tel (vcard-format-sample-get-telephone vcard))
+ (lines (delete nil (vcard-flatten (list name title org addr))))
+ (col-template (format "%%-%ds%%s"
+ (vcard-format-sample-offset lines tel)))
+ (l lines))
+ (while tel
+ (setcar l (format col-template (car l) (car tel)))
+ ;; If we stripped away too many nil slots from l, add empty strings
+ ;; back in so setcar above will work on next iteration.
+ (and (cdr tel)
+ (null (cdr l))
+ (setcdr l (cons "" nil)))
+ (setq l (cdr l))
+ (setq tel (cdr tel)))
+ lines))
+
+(defun vcard-format-sample-get-name (vcard)
+ (let ((name (car (car (vcard-values vcard '("fn") nil 1))))
+ (email (car (vcard-format-sample-values
+ vcard '((("email" "pref"))
+ (("email" "internet"))
+ (("email"))) 1))))
+ (cond ((and name email)
+ (format "%s <%s>" name email))
+ (email)
+ (name)
+ (""))))
+
+(defun vcard-format-sample-get-telephone (vcard)
+ (let ((fields '(("Work: "
+ (("tel" "work" "pref") . ("fax" "pager" "cell"))
+ (("tel" "work" "voice") . ("fax" "pager" "cell"))
+ (("tel" "work") . ("fax" "pager" "cell")))
+ ("Home: "
+ (("tel" "home" "pref") . ("fax" "pager" "cell"))
+ (("tel" "home" "voice") . ("fax" "pager" "cell"))
+ (("tel" "home") . ("fax" "pager" "cell"))
+ (("tel") . ("fax" "pager" "cell" "work")))
+ ("Cell: "
+ (("tel" "cell" "pref"))
+ (("tel" "cell")))
+ ("Fax: "
+ (("tel" "pref" "fax"))
+ (("tel" "work" "fax"))
+ (("tel" "home" "fax"))
+ (("tel" "fax")))))
+ (phones nil)
+ result)
+ (while fields
+ (setq result (vcard-format-sample-values vcard (cdr (car fields))))
+ (while result
+ (setq phones
+ (cons (concat (car (car fields)) (car (car result))) phones))
+ (setq result (cdr result)))
+ (setq fields (cdr fields)))
+ (nreverse phones)))
+
+(defun vcard-format-sample-get-address (vcard)
+ (let* ((addr (vcard-format-sample-values vcard '((("adr" "pref" "work"))
+ (("adr" "pref"))
+ (("adr" "work"))
+ (("adr"))) 1))
+ (street (delete "" (list (nth 0 addr) (nth 1 addr) (nth 2 addr))))
+ (city-list (delete "" (nthcdr 3 addr)))
+ (city (cond ((null (car city-list)) nil)
+ ((cdr city-list)
+ (format "%s, %s"
+ (car city-list)
+ (mapconcat 'identity (cdr city-list) " ")))
+ (t (car city-list)))))
+ (delete nil (if city
+ (append street (list city))
+ street))))
+
+(defun vcard-format-sample-values-concat (vcard have-props limit sep)
+ (let ((l (car (vcard-values vcard have-props nil limit))))
+ (and l (mapconcat 'identity (delete "" (vcard-copy-tree l)) sep))))
+
+(defun vcard-format-sample-values (vcard proplists &optional limit)
+ (let ((result (vcard-format-sample-ref vcard proplists limit)))
+ (if (equal limit 1)
+ (cdr result)
+ (mapcar 'cdr result))))
+
+(defun vcard-format-sample-ref (vcard proplists &optional limit)
+ (let ((result nil))
+ (while (and (null result) proplists)
+ (setq result (vcard-ref vcard
+ (car (car proplists))
+ (cdr (car proplists))
+ limit))
+ (setq proplists (cdr proplists)))
+ (if (equal limit 1)
+ (vcard-copy-tree (car result))
+ (vcard-copy-tree result))))
+
+(defun vcard-format-sample-offset (row1 row2 &optional maxwidth)
+ (or maxwidth (setq maxwidth (frame-width)))
+ (let ((max1 (vcard-format-sample-max-length row1))
+ (max2 (vcard-format-sample-max-length row2)))
+ (if (zerop max1)
+ 0
+ (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2))))))))
+
+(defun vcard-format-sample-max-length (strings)
+ (let ((maxlen 0))
+ (while strings
+ (setq maxlen (max maxlen (length (car strings))))
+ (setq strings (cdr strings)))
+ maxlen))
+
+(provide 'vcard)
+
+;;; vcard.el ends here.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Add an omitted comma, Check-Message, test-harness.el.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
The bug this fixes is visible in the buildbot’s logs, because advice.el is
not available there. Thank you for the buildbot, Mats!
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284667217 -3600
# Node ID ecdd1daab44709b5ea768d3e5900406c0bc078ce
# Parent 799742b751c8b146dd4fcb0d6be6be141341693c
Add an omitted comma, Check-Message, test-harness.el.
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
diff -r 799742b751c8 -r ecdd1daab447 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 20:34:49 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 21:00:17 2010 +0100
＠＠ -1,3 +1,8 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * test-harness.el (Check-Message):
+ Add an omitted comma here, thank you the buildbot.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
diff -r 799742b751c8 -r ecdd1daab447 lisp/test-harness.el
--- a/lisp/test-harness.el Thu Sep 16 20:34:49 2010 +0100
+++ b/lisp/test-harness.el Thu Sep 16 21:00:17 2010 +0100
＠＠ -502,7 +502,7 ＠＠
`(quote ,(car body))
`(quote (progn ,＠body)))))
`(Skip-Test-Unless (fboundp 'defadvice) "can't defadvice"
- expected-message-regexp
+ ,expected-message-regexp
(let ((messages ""))
(defadvice message (around collect activate)
(defvar messages)
--
“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://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Add an omitted comma, Check-Message, test-harness.el.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5274:ecdd1daab447
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 21:00:17 2010 +0100
files: lisp/ChangeLog lisp/test-harness.el
description:
Add an omitted comma, Check-Message, test-harness.el.
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
diff -r 799742b751c8 -r ecdd1daab447 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 20:34:49 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 21:00:17 2010 +0100
＠＠ -1,3 +1,8 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * test-harness.el (Check-Message):
+ Add an omitted comma here, thank you the buildbot.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
diff -r 799742b751c8 -r ecdd1daab447 lisp/test-harness.el
--- a/lisp/test-harness.el Thu Sep 16 20:34:49 2010 +0100
+++ b/lisp/test-harness.el Thu Sep 16 21:00:17 2010 +0100
＠＠ -502,7 +502,7 ＠＠
`(quote ,(car body))
`(quote (progn ,＠body)))))
`(Skip-Test-Unless (fboundp 'defadvice) "can't defadvice"
- expected-message-regexp
+ ,expected-message-regexp
(let ((messages ""))
(defadvice message (around collect activate)
(defvar messages)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Accept circular lists where that is useful in #'mapcar* and friends.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
Circular lists aren’t the best thing in the world ever, and we don’t yet
have *print-circle*, as do GNU and Common Lisp. But this is a linear
improvement over what was there before.
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284665689 -3600
# Node ID 799742b751c8b146dd4fcb0d6be6be141341693c
# Parent 66dbef5f8076a746857e90e0201fe3b8962c515f
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
src/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Flist_length): New, moved here from cl-extra.el, needed
by the next function.
(shortest_length_among_sequences): New.
(Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap)
(Fmap_into, Fsome, Fevery):
Use shortest_length_among_sequences() when working out how many
iterations to do, only giving circular list errors if all
arguments are circular.
diff -r 66dbef5f8076 -r 799742b751c8 lisp/cl-extra.el
--- a/lisp/cl-extra.el Thu Sep 16 18:46:05 2010 +0100
+++ b/lisp/cl-extra.el Thu Sep 16 20:34:49 2010 +0100
＠＠ -405,13 +405,6 ＠＠
"Equivalent to (nconc (nreverse X) Y)."
(nconc (nreverse x) y))
-(defun list-length (list)
- "Return the length of LIST. Return nil if LIST is circular."
- (if (listp list)
- (condition-case nil (length list) (circular-list))
- ;; Error on not-a-list:
- (car list)))
-
(defun tailp (sublist list)
"Return true if SUBLIST is a tail of LIST."
(while (and (consp list) (not (eq sublist list)))
diff -r 66dbef5f8076 -r 799742b751c8 src/ChangeLog
--- a/src/ChangeLog Thu Sep 16 18:46:05 2010 +0100
+++ b/src/ChangeLog Thu Sep 16 20:34:49 2010 +0100
＠＠ -1,3 +1,14 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Flist_length): New, moved here from cl-extra.el, needed
+ by the next function.
+ (shortest_length_among_sequences): New.
+ (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap)
+ (Fmap_into, Fsome, Fevery):
+ Use shortest_length_among_sequences() when working out how many
+ iterations to do, only giving circular list errors if all
+ arguments are circular.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Fsubseq):
diff -r 66dbef5f8076 -r 799742b751c8 src/fns.c
--- a/src/fns.c Thu Sep 16 18:46:05 2010 +0100
+++ b/src/fns.c Thu Sep 16 20:34:49 2010 +0100
＠＠ -339,6 +339,29 ＠＠
return make_int (len);
}
+/* This is almost the above, but is defined by Common Lisp. We need it in C
+ for shortest_length_among_sequences(), below, for the various sequence
+ functions that can usefully operate on circular lists. */
+
+DEFUN ("list-length", Flist_length, 1, 1, 0, /*
+Return the length of LIST. Return nil if LIST is circular.
+*/
+ (list))
+{
+ Lisp_Object hare, tortoise;
+ Elemcount len;
+
+ for (hare = tortoise = list, len = 0;
+ CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
+ hare = XCDR (hare), len++)
+ {
+ if (len & 1)
+ tortoise = XCDR (tortoise);
+ }
+
+ return EQ (hare, tortoise) && len != 0 ? Qnil : make_int (len);
+}
+
/*** string functions. ***/
DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
＠＠ -4458,6 +4481,42 ＠＠
UNGCPRO;
}
+/* Given NSEQUENCES objects at the address pointed to by SEQUENCES, return
+ the length of the shortest sequence. Error if all are circular, or if any
+ one of them is not a sequence. */
+static Elemcount
+shortest_length_among_sequences (int nsequences, Lisp_Object *sequences)
+{
+ Elemcount len = EMACS_INT_MAX;
+ Lisp_Object length;
+ int i;
+
+ for (i = 0; i < nsequences; ++i)
+ {
+ if (CONSP (sequences[i]))
+ {
+ length = Flist_length (sequences[i]);
+ if (!NILP (length))
+ {
+ len = min (len, XINT (length));
+ }
+ }
+ else
+ {
+ CHECK_SEQUENCE (sequences[i]);
+ length = Flength (sequences[i]);
+ len = min (len, XINT (length));
+ }
+ }
+
+ if (NILP (length))
+ {
+ signal_circular_list_error (sequences[0]);
+ }
+
+ return len;
+}
+
DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /*
Call FUNCTION on each element of SEQUENCE, and concat results to a string.
Between each pair of results, insert SEPARATOR.
＠＠ -4485,11 +4544,7 ＠＠
args[2] = sequence;
args[1] = separator;
- for (i = 2; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- len = min (len, XINT (Flength (args[i])));
- }
+ len = shortest_length_among_sequences (nargs - 2, args + 2);
if (len == 0) return build_ascstring ("");
＠＠ -4536,15 +4591,8 ＠＠
(int nargs, Lisp_Object *args))
{
Lisp_Object function = args[0];
- Elemcount len = EMACS_INT_MAX;
+ Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
Lisp_Object *args0;
- int i;
-
- for (i = 1; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- len = min (len, XINT (Flength (args[i])));
- }
args0 = alloca_array (Lisp_Object, len);
mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX);
＠＠ -4567,18 +4615,10 ＠＠
(int nargs, Lisp_Object *args))
{
Lisp_Object function = args[0];
- Elemcount len = EMACS_INT_MAX;
- Lisp_Object result;
- struct gcpro gcpro1;
- int i;
-
- for (i = 1; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- len = min (len, XINT (Flength (args[i])));
- }
-
- result = make_vector (len, Qnil);
+ Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
+ Lisp_Object result = make_vector (len, Qnil);
+
+ struct gcpro gcpro1;
GCPRO1 (result);
/* Don't pass result as the lisp_object argument, we want mapcarX to protect
a single list argument's elements from being garbage-collected. */
＠＠ -4602,21 +4642,13 ＠＠
*/
(int nargs, Lisp_Object *args))
{
- Lisp_Object function = args[0], *result;
- Elemcount result_len = EMACS_INT_MAX;
- int i;
-
- for (i = 1; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- result_len = min (result_len, XINT (Flength (args[i])));
- }
-
- result = alloca_array (Lisp_Object, result_len);
- mapcarX (result_len, result, Qnil, function, nargs - 1, args + 1, Qmapcan);
+ Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
+ Lisp_Object function = args[0], *result = alloca_array (Lisp_Object, len);
+
+ mapcarX (len, result, Qnil, function, nargs - 1, args + 1, Qmapcan);
/* #'nconc GCPROs its args in case of signals and error. */
- return Fnconc (result_len, result);
+ return Fnconc (len, result);
}
DEFUN ("mapc", Fmapc, 2, MANY, 0, /*
＠＠ -4637,17 +4669,9 ＠＠
*/
(int nargs, Lisp_Object *args))
{
- Elemcount len = EMACS_INT_MAX;
+ Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
Lisp_Object sequence = args[1];
struct gcpro gcpro1;
- int i;
-
- for (i = 1; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- len = min (len, XINT (Flength (args[i])));
- }
-
/* We need to GCPRO sequence, because mapcarX will modify the
elements of the args array handed to it, and this may involve
elements of sequence getting garbage collected. */
＠＠ -4677,15 +4701,8 ＠＠
Lisp_Object function = args[1];
Lisp_Object result = Qnil;
Lisp_Object *args0 = NULL;
- Elemcount len = EMACS_INT_MAX;
- int i;
- struct gcpro gcpro1;
-
- for (i = 2; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- len = min (len, XINT (Flength (args[i])));
- }
+ Elemcount len = shortest_length_among_sequences (nargs - 2, args + 2);
+ struct gcpro gcpro1;
if (!NILP (type))
{
＠＠ -4742,19 +4759,14 ＠＠
*/
(int nargs, Lisp_Object *args))
{
- Elemcount len = EMACS_INT_MAX;
+ Elemcount len;
Lisp_Object result_sequence = args[0];
Lisp_Object function = args[1];
- int i;
args[0] = function;
args[1] = result_sequence;
- for (i = 1; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- len = min (len, XINT (Flength (args[i])));
- }
+ len = shortest_length_among_sequences (nargs - 1, args + 1);
mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2,
Qmap_into);
＠＠ -4776,14 +4788,7 ＠＠
{
Lisp_Object result = Qnil,
result_ptr = STORE_VOID_IN_LISP ((void *) &result);
- Elemcount len = EMACS_INT_MAX;
- int i;
-
- for (i = 1; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- len = min (len, XINT (Flength (args[i])));
- }
+ Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome);
＠＠ -4803,14 +4808,7 ＠＠
(int nargs, Lisp_Object *args))
{
Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result);
- Elemcount len = EMACS_INT_MAX;
- int i;
-
- for (i = 1; i < nargs; ++i)
- {
- CHECK_SEQUENCE (args[i]);
- len = min (len, XINT (Flength (args[i])));
- }
+ Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery);
＠＠ -6683,6 +6681,7 ＠＠
DEFSUBR (Frandom);
DEFSUBR (Flength);
DEFSUBR (Fsafe_length);
+ DEFSUBR (Flist_length);
DEFSUBR (Fstring_equal);
DEFSUBR (Fcompare_strings);
DEFSUBR (Fstring_lessp);
--
“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://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284659165 -3600
# Node ID 66dbef5f8076a746857e90e0201fe3b8962c515f
# Parent 2def0d83a5e3d71e94169949edcc4c8ebbcdea63
Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Fsubseq):
Change the string code to better fit in with the rest of this
function (it still uses get_string_range_char(), though, which *may*
diverge algorithmically from what we're doing).
If dealing with a cons, only call #'length if we have reason to
believe that the START and END arguments are badly specified, and
check for circular lists ourselves when that's appropriate.
If dealing with a vector, call Fvector() on the appropriate subset
of the old vector's data directly, don't initialise the result
with nil and then copy.
(Ffill):
Only check the range arguments for a cons SEQUENCE if we have good
reason to think they were badly specified.
(Freduce):
Handle multiple values properly. Add bounds checking to this
function, as specificied by ANSI Common Lisp.
diff -r 2def0d83a5e3 -r 66dbef5f8076 src/ChangeLog
--- a/src/ChangeLog Thu Sep 16 16:46:27 2010 +0100
+++ b/src/ChangeLog Thu Sep 16 18:46:05 2010 +0100
＠＠ -1,3 +1,26 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Fsubseq):
+ Change the string code to better fit in with the rest of this
+ function (it still uses get_string_range_char(), though, which *may*
+ diverge algorithmically from what we're doing).
+
+ If dealing with a cons, only call #'length if we have reason to
+ believe that the START and END arguments are badly specified, and
+ check for circular lists ourselves when that's appropriate.
+
+ If dealing with a vector, call Fvector() on the appropriate subset
+ of the old vector's data directly, don't initialise the result
+ with nil and then copy.
+
+ (Ffill):
+ Only check the range arguments for a cons SEQUENCE if we have good
+ reason to think they were badly specified.
+
+ (Freduce):
+ Handle multiple values properly. Add bounds checking to this
+ function, as specificied by ANSI Common Lisp.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* eval.c (Ffunction, Fquote):
diff -r 2def0d83a5e3 -r 66dbef5f8076 src/fns.c
--- a/src/fns.c Thu Sep 16 16:46:27 2010 +0100
+++ b/src/fns.c Thu Sep 16 18:46:05 2010 +0100
＠＠ -1011,7 +1011,9 ＠＠
DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
Return the subsequence of SEQUENCE starting at START and ending before END.
END may be omitted; then the subsequence runs to the end of SEQUENCE.
-If START or END is negative, it counts from the end.
+
+If START or END is negative, it counts from the end, in contravention of
+Common Lisp.
The returned subsequence is always of the same type as SEQUENCE.
If SEQUENCE is a string, relevant parts of the string-extent-data
are copied to the new string.
＠＠ -1021,95 +1023,139 ＠＠
*/
(sequence, start, end))
{
- EMACS_INT len, s, e;
+ Elemcount len, ss, ee = EMACS_INT_MAX, ii;
+ Lisp_Object result = Qnil;
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_INT (start);
+ ss = XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_INT (end);
+ ee = XINT (end);
+ }
if (STRINGP (sequence))
{
- Charcount ccstart, ccend;
Bytecount bstart, blen;
- Lisp_Object val;
-
- CHECK_INT (start);
- get_string_range_char (sequence, start, end, &ccstart, &ccend,
+
+ get_string_range_char (sequence, start, end, &ss, &ee,
GB_HISTORICAL_STRING_BEHAVIOR);
- bstart = string_index_char_to_byte (sequence, ccstart);
- blen = string_offset_char_to_byte_len (sequence, bstart, ccend - ccstart);
- val = make_string (XSTRING_DATA (sequence) + bstart, blen);
+ bstart = string_index_char_to_byte (sequence, ss);
+ blen = string_offset_char_to_byte_len (sequence, bstart, ee - ss);
+
+ result = make_string (XSTRING_DATA (sequence) + bstart, blen);
/* Copy any applicable extent information into the new string. */
- copy_string_extents (val, sequence, 0, bstart, blen);
- return val;
- }
-
- CHECK_SEQUENCE (sequence);
-
- len = XINT (Flength (sequence));
-
- CHECK_INT (start);
- s = XINT (start);
- if (s < 0)
- s = len + s;
-
- if (NILP (end))
- e = len;
- else
- {
- CHECK_INT (end);
- e = XINT (end);
- if (e < 0)
- e = len + e;
- }
-
- check_sequence_range (sequence, make_int (s), make_int (e),
- make_int (len));
-
- if (VECTORP (sequence))
- {
- Lisp_Object result = make_vector (e - s, Qnil);
- EMACS_INT i;
- Lisp_Object *in_elts = XVECTOR_DATA (sequence);
- Lisp_Object *out_elts = XVECTOR_DATA (result);
-
- for (i = s; i < e; i++)
- out_elts[i - s] = in_elts[i];
- return result;
- }
- else if (LISTP (sequence))
- {
- Lisp_Object result = Qnil, result_tail;
- EMACS_INT i;
-
- sequence = Fnthcdr (make_int (s), sequence);
-
- if (s < e)
- {
+ copy_string_extents (result, sequence, 0, bstart, blen);
+ }
+ else if (CONSP (sequence))
+ {
+ Lisp_Object result_tail, saved = sequence;
+
+ if (ss < 0 || ee < 0)
+ {
+ len = XINT (Flength (sequence));
+ if (ss < 0)
+ {
+ ss = len + ss;
+ start = make_integer (ss);
+ }
+
+ if (ee < 0)
+ {
+ ee = len + ee;
+ end = make_integer (ee);
+ }
+ else
+ {
+ ee = min (ee, len);
+ }
+ }
+
+ if (0 != ss)
+ {
+ sequence = Fnthcdr (make_int (ss), sequence);
+ }
+
+ if (ss < ee && !NILP (sequence))
+ {
result = result_tail = Fcons (Fcar (sequence), Qnil);
sequence = Fcdr (sequence);
- for (i = s + 1; i < e; i++)
- {
- XSETCDR (result_tail, Fcons (Fcar (sequence), Qnil));
- sequence = Fcdr (sequence);
- result_tail = XCDR (result_tail);
- }
- }
-
- return result;
- }
- else if (BIT_VECTORP (sequence))
- {
- Lisp_Object result = make_bit_vector (e - s, Qzero);
- EMACS_INT i;
-
- for (i = s; i < e; i++)
- set_bit_vector_bit (XBIT_VECTOR (result), i - s,
- bit_vector_bit (XBIT_VECTOR (sequence), i));
- return result;
- }
- else
- {
- ABORT (); /* unreachable, since CHECK_SEQUENCE (sequence) did not
- error */
- return Qnil;
- }
+ ii = ss + 1;
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence)
+ {
+ if (!(ii < ee))
+ {
+ break;
+ }
+
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ ii++;
+ }
+ }
+ }
+
+ if (NILP (result) || (ii < ee && !NILP (end)))
+ {
+ /* We were handed a cons, which definitely has elements. nil
+ result means either ss >= ee or SEQUENCE was nil after the
+ nthcdr; in both cases that means START and END were incorrectly
+ specified for this sequence. ii < ee with a non-nil end means
+ the user handed us a bogus end value. */
+ check_sequence_range (saved, start, end, Flength (saved));
+ }
+ }
+ else
+ {
+ len = XINT (Flength (sequence));
+ if (ss < 0)
+ {
+ ss = len + ss;
+ start = make_integer (ss);
+ }
+
+ if (ee < 0)
+ {
+ ee = len + ee;
+ end = make_integer (ee);
+ }
+ else
+ {
+ ee = min (len, ee);
+ }
+
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ if (VECTORP (sequence))
+ {
+ result = Fvector (ee - ss, XVECTOR_DATA (sequence) + ss);
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ result = make_bit_vector (ee - ss, Qzero);
+
+ for (ii = ss; ii < ee; ii++)
+ {
+ set_bit_vector_bit (XBIT_VECTOR (result), ii - ss,
+ bit_vector_bit (XBIT_VECTOR (sequence), ii));
+ }
+ }
+ else if (NILP (sequence))
+ {
+ DO_NOTHING;
+ }
+ else
+ {
+ /* Won't happen, since CHECK_SEQUENCE didn't error. */
+ ABORT ();
+ }
+ }
+
+ return result;
}
DEFUN ("substring-no-properties", Fsubstring_no_properties, 1, 3, 0, /*
＠＠ -4005,9 +4051,9 ＠＠
++counting;
}
- if (counting != ending)
- {
- check_sequence_range (sequence, start, end, Flength (sequence));
+ if (counting < starting || (counting != ending && !NILP (end)))
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
}
}
else
＠＠ -4970,7 +5016,10 ＠＠
CHECK_KEY_ARGUMENT (key);
-#define KEY(key, item) (EQ (key, Qidentity) ? item : call1 (key, item))
+#define KEY(key, item) (EQ (Qidentity, key) ? item : \
+ IGNORE_MULTIPLE_VALUES (call1 (key, item)))
+#define CALL2(function, accum, item) \
+ IGNORE_MULTIPLE_VALUES (call2 (function, accum, item))
starting = XINT (start);
if (!NILP (end))
＠＠ -4979,16 +5028,24 ＠＠
ending = XINT (end);
}
+ if (!(starting <= ending))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+
if (VECTORP (sequence))
{
Lisp_Vector *vv = XVECTOR (sequence);
+
+ check_sequence_range (sequence, start, end, make_int (vv->size));
+
ending = min (ending, vv->size);
if (!UNBOUNDP (initial_value))
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
+ else if (ending - starting)
{
if (NILP (from_end))
{
＠＠ -5006,14 +5063,14 ＠＠
{
for (ii = starting; ii < ending; ++ii)
{
- accum = call2 (function, accum, KEY (key, vv->contents[ii]));
+ accum = CALL2 (function, accum, KEY (key, vv->contents[ii]));
}
}
else
{
for (ii = ending - 1; ii >= starting; --ii)
{
- accum = call2 (function, KEY (key, vv->contents[ii]), accum);
+ accum = CALL2 (function, KEY (key, vv->contents[ii]), accum);
}
}
}
＠＠ -5021,13 +5078,15 ＠＠
{
Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
+ check_sequence_range (sequence, start, end, make_int (bv->size));
+
ending = min (ending, bv->size);
if (!UNBOUNDP (initial_value))
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
+ else if (ending - starting)
{
if (NILP (from_end))
{
＠＠ -5045,7 +5104,7 ＠＠
{
for (ii = starting; ii < ending; ++ii)
{
- accum = call2 (function, accum,
+ accum = CALL2 (function, accum,
KEY (key, make_int (bit_vector_bit (bv, ii))));
}
}
＠＠ -5053,13 +5112,12 ＠＠
{
for (ii = ending - 1; ii >= starting; --ii)
{
- accum = call2 (function, KEY (key,
+ accum = CALL2 (function, KEY (key,
make_int (bit_vector_bit (bv,
ii))),
accum);
}
}
-
}
else if (STRINGP (sequence))
{
＠＠ -5080,7 +5138,7 ＠＠
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
+ else if (ending - starting)
{
accum = KEY (key, make_char (itext_ichar (cursor)));
starting++;
＠＠ -5097,9 +5155,9 ＠＠
cursor_offset = cursor - startp;
}
- while (cursor_offset < byte_len && starting < ending)
- {
- accum = call2 (function, accum,
+ while (cursor_offset < byte_len && ii < ending)
+ {
+ accum = CALL2 (function, accum,
KEY (key, make_char (itext_ichar (cursor))));
startp = XSTRING_DATA (sequence);
＠＠ -5113,8 +5171,14 ＠＠
INC_IBYTEPTR (cursor);
cursor_offset = cursor - startp;
- ++starting;
- }
+ ++ii;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ ABORT ();
+ }
}
else
{
＠＠ -5122,6 +5186,8 ＠＠
Bytecount cursor_offset, byte_len = XSTRING_LENGTH (sequence);
const Ibyte *cursor;
+ check_sequence_range (sequence, start, end, make_int (len));
+
ending = min (ending, len);
cursor = string_char_addr (sequence, ending - 1);
cursor_offset = cursor - XSTRING_DATA (sequence);
＠＠ -5130,7 +5196,7 ＠＠
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
+ else if (ending - starting)
{
accum = KEY (key, make_char (itext_ichar (cursor)));
ending--;
＠＠ -5150,7 +5216,7 ＠＠
for (ii = ending - 1; ii >= starting; --ii)
{
- accum = call2 (function, KEY (key,
+ accum = CALL2 (function, KEY (key,
make_char (itext_ichar (cursor))),
accum);
if (ii > 0)
＠＠ -5182,27 +5248,27 ＠＠
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
- {
- Elemcount counting = 0;
+ else if (ending - starting)
+ {
+ ii = 0;
EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
{
/* KEY may amputate the list behind us; make sure what
remains to be processed is still reachable. */
tailed = tail;
- if (counting == starting)
+ if (ii == starting)
{
accum = KEY (key, elt);
starting++;
break;
}
- ++counting;
- }
- }
-
- if (ending - starting && starting < ending)
- {
- Elemcount counting = 0;
+ ++ii;
+ }
+ }
+
+ if (ending - starting)
+ {
+ ii = 0;
EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
{
＠＠ -5210,22 +5276,28 ＠＠
sure what remains to be processed is still
reachable. */
tailed = tail;
- if (counting >= starting)
- {
- if (counting < ending)
+ if (ii >= starting)
+ {
+ if (ii < ending)
{
- accum = call2 (function, accum, KEY (key, elt));
+ accum = CALL2 (function, accum, KEY (key, elt));
}
- else if (counting == ending)
+ else if (ii == ending)
{
break;
}
}
- ++counting;
+ ++ii;
}
}
UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ ABORT ();
+ }
}
else
{
＠＠ -5234,11 +5306,9 ＠＠
Elemcount counting = 0, len = 0;
struct gcpro gcpro1;
- if (ending - starting && starting < ending
- && EMACS_INT_MAX == ending)
- {
- ending = XINT (Flength (sequence));
- }
+ len = XINT (Flength (sequence));
+ check_sequence_range (sequence, start, end, make_int (len));
+ ending = min (ending, len);
/* :from-end with a list; make an alloca copy of the relevant list
data, attempting to go backwards isn't worth the trouble. */
＠＠ -5295,7 +5365,7 ＠＠
for (ii = len; ii != 0;)
{
--ii;
- accum = call2 (function, KEY (key, subsequence[ii]), accum);
+ accum = CALL2 (function, KEY (key, subsequence[ii]), accum);
}
if (subsequence != NULL)
＠＠ -5310,7 +5380,7 ＠＠
arguments. */
if (UNBOUNDP (accum))
{
- accum = call0 (function);
+ accum = IGNORE_MULTIPLE_VALUES (call0 (function));
}
return accum;
＠＠ -5470,7 +5540,7 ＠＠
Lisp_Object sequence1 = args[0], sequence2 = args[1],
result = sequence1;
Elemcount starting1, ending1 = EMACS_INT_MAX, starting2;
- Elemcount ending2 = EMACS_INT_MAX, counting, startcounting;
+ Elemcount ending2 = EMACS_INT_MAX, counting = 0, startcounting;
Boolint sequence1_listp, sequence2_listp,
overwriting = EQ (sequence1, sequence2);
＠＠ -5516,32 +5586,30 ＠＠
if (sequence1_listp && !ZEROP (start1))
{
- Lisp_Object nthcdrd = Fnthcdr (start1, sequence1);
-
- if (NILP (nthcdrd))
- {
- check_sequence_range (sequence1, start1, end1, Flength (sequence1));
+ sequence1 = Fnthcdr (start1, sequence1);
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (args[0], start1, end1, Flength (args[0]));
/* Give up early here. */
return result;
}
- sequence1 = nthcdrd;
ending1 -= starting1;
starting1 = 0;
}
if (sequence2_listp && !ZEROP (start2))
{
- Lisp_Object nthcdrd = Fnthcdr (start2, sequence2);
-
- if (NILP (nthcdrd))
- {
- check_sequence_range (sequence1, start1, end1, Flength (sequence1));
+ sequence2 = Fnthcdr (start2, sequence2);
+
+ if (NILP (sequence2))
+ {
+ check_sequence_range (args[1], start1, end1, Flength (args[1]));
/* Nothing available to replace sequence1's contents. */
return result;
}
- sequence2 = nthcdrd;
ending2 -= starting2;
starting2 = 0;
}
＠＠ -5560,7 +5628,7 ＠＠
Elemcount len = XINT (Flength (sequence2));
Lisp_Object *subsequence
= alloca_array (Lisp_Object, min (ending2, len));
- Elemcount counting = 0, ii = 0;
+ Elemcount ii = 0;
LIST_LOOP_2 (elt, sequence2)
{
--
“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://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5272:66dbef5f8076
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 18:46:05 2010 +0100
files: src/ChangeLog src/fns.c
description:
Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Fsubseq):
Change the string code to better fit in with the rest of this
function (it still uses get_string_range_char(), though, which *may*
diverge algorithmically from what we're doing).
If dealing with a cons, only call #'length if we have reason to
believe that the START and END arguments are badly specified, and
check for circular lists ourselves when that's appropriate.
If dealing with a vector, call Fvector() on the appropriate subset
of the old vector's data directly, don't initialise the result
with nil and then copy.
(Ffill):
Only check the range arguments for a cons SEQUENCE if we have good
reason to think they were badly specified.
(Freduce):
Handle multiple values properly. Add bounds checking to this
function, as specificied by ANSI Common Lisp.
diff -r 2def0d83a5e3 -r 66dbef5f8076 src/ChangeLog
--- a/src/ChangeLog Thu Sep 16 16:46:27 2010 +0100
+++ b/src/ChangeLog Thu Sep 16 18:46:05 2010 +0100
＠＠ -1,3 +1,26 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Fsubseq):
+ Change the string code to better fit in with the rest of this
+ function (it still uses get_string_range_char(), though, which *may*
+ diverge algorithmically from what we're doing).
+
+ If dealing with a cons, only call #'length if we have reason to
+ believe that the START and END arguments are badly specified, and
+ check for circular lists ourselves when that's appropriate.
+
+ If dealing with a vector, call Fvector() on the appropriate subset
+ of the old vector's data directly, don't initialise the result
+ with nil and then copy.
+
+ (Ffill):
+ Only check the range arguments for a cons SEQUENCE if we have good
+ reason to think they were badly specified.
+
+ (Freduce):
+ Handle multiple values properly. Add bounds checking to this
+ function, as specificied by ANSI Common Lisp.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* eval.c (Ffunction, Fquote):
diff -r 2def0d83a5e3 -r 66dbef5f8076 src/fns.c
--- a/src/fns.c Thu Sep 16 16:46:27 2010 +0100
+++ b/src/fns.c Thu Sep 16 18:46:05 2010 +0100
＠＠ -1011,7 +1011,9 ＠＠
DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
Return the subsequence of SEQUENCE starting at START and ending before END.
END may be omitted; then the subsequence runs to the end of SEQUENCE.
-If START or END is negative, it counts from the end.
+
+If START or END is negative, it counts from the end, in contravention of
+Common Lisp.
The returned subsequence is always of the same type as SEQUENCE.
If SEQUENCE is a string, relevant parts of the string-extent-data
are copied to the new string.
＠＠ -1021,95 +1023,139 ＠＠
*/
(sequence, start, end))
{
- EMACS_INT len, s, e;
+ Elemcount len, ss, ee = EMACS_INT_MAX, ii;
+ Lisp_Object result = Qnil;
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_INT (start);
+ ss = XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_INT (end);
+ ee = XINT (end);
+ }
if (STRINGP (sequence))
{
- Charcount ccstart, ccend;
Bytecount bstart, blen;
- Lisp_Object val;
-
- CHECK_INT (start);
- get_string_range_char (sequence, start, end, &ccstart, &ccend,
+
+ get_string_range_char (sequence, start, end, &ss, &ee,
GB_HISTORICAL_STRING_BEHAVIOR);
- bstart = string_index_char_to_byte (sequence, ccstart);
- blen = string_offset_char_to_byte_len (sequence, bstart, ccend - ccstart);
- val = make_string (XSTRING_DATA (sequence) + bstart, blen);
+ bstart = string_index_char_to_byte (sequence, ss);
+ blen = string_offset_char_to_byte_len (sequence, bstart, ee - ss);
+
+ result = make_string (XSTRING_DATA (sequence) + bstart, blen);
/* Copy any applicable extent information into the new string. */
- copy_string_extents (val, sequence, 0, bstart, blen);
- return val;
- }
-
- CHECK_SEQUENCE (sequence);
-
- len = XINT (Flength (sequence));
-
- CHECK_INT (start);
- s = XINT (start);
- if (s < 0)
- s = len + s;
-
- if (NILP (end))
- e = len;
- else
- {
- CHECK_INT (end);
- e = XINT (end);
- if (e < 0)
- e = len + e;
- }
-
- check_sequence_range (sequence, make_int (s), make_int (e),
- make_int (len));
-
- if (VECTORP (sequence))
- {
- Lisp_Object result = make_vector (e - s, Qnil);
- EMACS_INT i;
- Lisp_Object *in_elts = XVECTOR_DATA (sequence);
- Lisp_Object *out_elts = XVECTOR_DATA (result);
-
- for (i = s; i < e; i++)
- out_elts[i - s] = in_elts[i];
- return result;
- }
- else if (LISTP (sequence))
- {
- Lisp_Object result = Qnil, result_tail;
- EMACS_INT i;
-
- sequence = Fnthcdr (make_int (s), sequence);
-
- if (s < e)
- {
+ copy_string_extents (result, sequence, 0, bstart, blen);
+ }
+ else if (CONSP (sequence))
+ {
+ Lisp_Object result_tail, saved = sequence;
+
+ if (ss < 0 || ee < 0)
+ {
+ len = XINT (Flength (sequence));
+ if (ss < 0)
+ {
+ ss = len + ss;
+ start = make_integer (ss);
+ }
+
+ if (ee < 0)
+ {
+ ee = len + ee;
+ end = make_integer (ee);
+ }
+ else
+ {
+ ee = min (ee, len);
+ }
+ }
+
+ if (0 != ss)
+ {
+ sequence = Fnthcdr (make_int (ss), sequence);
+ }
+
+ if (ss < ee && !NILP (sequence))
+ {
result = result_tail = Fcons (Fcar (sequence), Qnil);
sequence = Fcdr (sequence);
- for (i = s + 1; i < e; i++)
- {
- XSETCDR (result_tail, Fcons (Fcar (sequence), Qnil));
- sequence = Fcdr (sequence);
- result_tail = XCDR (result_tail);
- }
- }
-
- return result;
- }
- else if (BIT_VECTORP (sequence))
- {
- Lisp_Object result = make_bit_vector (e - s, Qzero);
- EMACS_INT i;
-
- for (i = s; i < e; i++)
- set_bit_vector_bit (XBIT_VECTOR (result), i - s,
- bit_vector_bit (XBIT_VECTOR (sequence), i));
- return result;
- }
- else
- {
- ABORT (); /* unreachable, since CHECK_SEQUENCE (sequence) did not
- error */
- return Qnil;
- }
+ ii = ss + 1;
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence)
+ {
+ if (!(ii < ee))
+ {
+ break;
+ }
+
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ ii++;
+ }
+ }
+ }
+
+ if (NILP (result) || (ii < ee && !NILP (end)))
+ {
+ /* We were handed a cons, which definitely has elements. nil
+ result means either ss >= ee or SEQUENCE was nil after the
+ nthcdr; in both cases that means START and END were incorrectly
+ specified for this sequence. ii < ee with a non-nil end means
+ the user handed us a bogus end value. */
+ check_sequence_range (saved, start, end, Flength (saved));
+ }
+ }
+ else
+ {
+ len = XINT (Flength (sequence));
+ if (ss < 0)
+ {
+ ss = len + ss;
+ start = make_integer (ss);
+ }
+
+ if (ee < 0)
+ {
+ ee = len + ee;
+ end = make_integer (ee);
+ }
+ else
+ {
+ ee = min (len, ee);
+ }
+
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ if (VECTORP (sequence))
+ {
+ result = Fvector (ee - ss, XVECTOR_DATA (sequence) + ss);
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ result = make_bit_vector (ee - ss, Qzero);
+
+ for (ii = ss; ii < ee; ii++)
+ {
+ set_bit_vector_bit (XBIT_VECTOR (result), ii - ss,
+ bit_vector_bit (XBIT_VECTOR (sequence), ii));
+ }
+ }
+ else if (NILP (sequence))
+ {
+ DO_NOTHING;
+ }
+ else
+ {
+ /* Won't happen, since CHECK_SEQUENCE didn't error. */
+ ABORT ();
+ }
+ }
+
+ return result;
}
DEFUN ("substring-no-properties", Fsubstring_no_properties, 1, 3, 0, /*
＠＠ -4005,9 +4051,9 ＠＠
++counting;
}
- if (counting != ending)
- {
- check_sequence_range (sequence, start, end, Flength (sequence));
+ if (counting < starting || (counting != ending && !NILP (end)))
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
}
}
else
＠＠ -4970,7 +5016,10 ＠＠
CHECK_KEY_ARGUMENT (key);
-#define KEY(key, item) (EQ (key, Qidentity) ? item : call1 (key, item))
+#define KEY(key, item) (EQ (Qidentity, key) ? item : \
+ IGNORE_MULTIPLE_VALUES (call1 (key, item)))
+#define CALL2(function, accum, item) \
+ IGNORE_MULTIPLE_VALUES (call2 (function, accum, item))
starting = XINT (start);
if (!NILP (end))
＠＠ -4979,16 +5028,24 ＠＠
ending = XINT (end);
}
+ if (!(starting <= ending))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+
if (VECTORP (sequence))
{
Lisp_Vector *vv = XVECTOR (sequence);
+
+ check_sequence_range (sequence, start, end, make_int (vv->size));
+
ending = min (ending, vv->size);
if (!UNBOUNDP (initial_value))
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
+ else if (ending - starting)
{
if (NILP (from_end))
{
＠＠ -5006,14 +5063,14 ＠＠
{
for (ii = starting; ii < ending; ++ii)
{
- accum = call2 (function, accum, KEY (key, vv->contents[ii]));
+ accum = CALL2 (function, accum, KEY (key, vv->contents[ii]));
}
}
else
{
for (ii = ending - 1; ii >= starting; --ii)
{
- accum = call2 (function, KEY (key, vv->contents[ii]), accum);
+ accum = CALL2 (function, KEY (key, vv->contents[ii]), accum);
}
}
}
＠＠ -5021,13 +5078,15 ＠＠
{
Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
+ check_sequence_range (sequence, start, end, make_int (bv->size));
+
ending = min (ending, bv->size);
if (!UNBOUNDP (initial_value))
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
+ else if (ending - starting)
{
if (NILP (from_end))
{
＠＠ -5045,7 +5104,7 ＠＠
{
for (ii = starting; ii < ending; ++ii)
{
- accum = call2 (function, accum,
+ accum = CALL2 (function, accum,
KEY (key, make_int (bit_vector_bit (bv, ii))));
}
}
＠＠ -5053,13 +5112,12 ＠＠
{
for (ii = ending - 1; ii >= starting; --ii)
{
- accum = call2 (function, KEY (key,
+ accum = CALL2 (function, KEY (key,
make_int (bit_vector_bit (bv,
ii))),
accum);
}
}
-
}
else if (STRINGP (sequence))
{
＠＠ -5080,7 +5138,7 ＠＠
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
+ else if (ending - starting)
{
accum = KEY (key, make_char (itext_ichar (cursor)));
starting++;
＠＠ -5097,9 +5155,9 ＠＠
cursor_offset = cursor - startp;
}
- while (cursor_offset < byte_len && starting < ending)
- {
- accum = call2 (function, accum,
+ while (cursor_offset < byte_len && ii < ending)
+ {
+ accum = CALL2 (function, accum,
KEY (key, make_char (itext_ichar (cursor))));
startp = XSTRING_DATA (sequence);
＠＠ -5113,8 +5171,14 ＠＠
INC_IBYTEPTR (cursor);
cursor_offset = cursor - startp;
- ++starting;
- }
+ ++ii;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ ABORT ();
+ }
}
else
{
＠＠ -5122,6 +5186,8 ＠＠
Bytecount cursor_offset, byte_len = XSTRING_LENGTH (sequence);
const Ibyte *cursor;
+ check_sequence_range (sequence, start, end, make_int (len));
+
ending = min (ending, len);
cursor = string_char_addr (sequence, ending - 1);
cursor_offset = cursor - XSTRING_DATA (sequence);
＠＠ -5130,7 +5196,7 ＠＠
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
+ else if (ending - starting)
{
accum = KEY (key, make_char (itext_ichar (cursor)));
ending--;
＠＠ -5150,7 +5216,7 ＠＠
for (ii = ending - 1; ii >= starting; --ii)
{
- accum = call2 (function, KEY (key,
+ accum = CALL2 (function, KEY (key,
make_char (itext_ichar (cursor))),
accum);
if (ii > 0)
＠＠ -5182,27 +5248,27 ＠＠
{
accum = initial_value;
}
- else if (ending - starting && starting < ending)
- {
- Elemcount counting = 0;
+ else if (ending - starting)
+ {
+ ii = 0;
EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
{
/* KEY may amputate the list behind us; make sure what
remains to be processed is still reachable. */
tailed = tail;
- if (counting == starting)
+ if (ii == starting)
{
accum = KEY (key, elt);
starting++;
break;
}
- ++counting;
- }
- }
-
- if (ending - starting && starting < ending)
- {
- Elemcount counting = 0;
+ ++ii;
+ }
+ }
+
+ if (ending - starting)
+ {
+ ii = 0;
EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
{
＠＠ -5210,22 +5276,28 ＠＠
sure what remains to be processed is still
reachable. */
tailed = tail;
- if (counting >= starting)
- {
- if (counting < ending)
+ if (ii >= starting)
+ {
+ if (ii < ending)
{
- accum = call2 (function, accum, KEY (key, elt));
+ accum = CALL2 (function, accum, KEY (key, elt));
}
- else if (counting == ending)
+ else if (ii == ending)
{
break;
}
}
- ++counting;
+ ++ii;
}
}
UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ ABORT ();
+ }
}
else
{
＠＠ -5234,11 +5306,9 ＠＠
Elemcount counting = 0, len = 0;
struct gcpro gcpro1;
- if (ending - starting && starting < ending
- && EMACS_INT_MAX == ending)
- {
- ending = XINT (Flength (sequence));
- }
+ len = XINT (Flength (sequence));
+ check_sequence_range (sequence, start, end, make_int (len));
+ ending = min (ending, len);
/* :from-end with a list; make an alloca copy of the relevant list
data, attempting to go backwards isn't worth the trouble. */
＠＠ -5295,7 +5365,7 ＠＠
for (ii = len; ii != 0;)
{
--ii;
- accum = call2 (function, KEY (key, subsequence[ii]), accum);
+ accum = CALL2 (function, KEY (key, subsequence[ii]), accum);
}
if (subsequence != NULL)
＠＠ -5310,7 +5380,7 ＠＠
arguments. */
if (UNBOUNDP (accum))
{
- accum = call0 (function);
+ accum = IGNORE_MULTIPLE_VALUES (call0 (function));
}
return accum;
＠＠ -5470,7 +5540,7 ＠＠
Lisp_Object sequence1 = args[0], sequence2 = args[1],
result = sequence1;
Elemcount starting1, ending1 = EMACS_INT_MAX, starting2;
- Elemcount ending2 = EMACS_INT_MAX, counting, startcounting;
+ Elemcount ending2 = EMACS_INT_MAX, counting = 0, startcounting;
Boolint sequence1_listp, sequence2_listp,
overwriting = EQ (sequence1, sequence2);
＠＠ -5516,32 +5586,30 ＠＠
if (sequence1_listp && !ZEROP (start1))
{
- Lisp_Object nthcdrd = Fnthcdr (start1, sequence1);
-
- if (NILP (nthcdrd))
- {
- check_sequence_range (sequence1, start1, end1, Flength (sequence1));
+ sequence1 = Fnthcdr (start1, sequence1);
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (args[0], start1, end1, Flength (args[0]));
/* Give up early here. */
return result;
}
- sequence1 = nthcdrd;
ending1 -= starting1;
starting1 = 0;
}
if (sequence2_listp && !ZEROP (start2))
{
- Lisp_Object nthcdrd = Fnthcdr (start2, sequence2);
-
- if (NILP (nthcdrd))
- {
- check_sequence_range (sequence1, start1, end1, Flength (sequence1));
+ sequence2 = Fnthcdr (start2, sequence2);
+
+ if (NILP (sequence2))
+ {
+ check_sequence_range (args[1], start1, end1, Flength (args[1]));
/* Nothing available to replace sequence1's contents. */
return result;
}
- sequence2 = nthcdrd;
ending2 -= starting2;
starting2 = 0;
}
＠＠ -5560,7 +5628,7 ＠＠
Elemcount len = XINT (Flength (sequence2));
Lisp_Object *subsequence
= alloca_array (Lisp_Object, min (ending2, len));
- Elemcount counting = 0, ii = 0;
+ Elemcount ii = 0;
LIST_LOOP_2 (elt, sequence2)
{
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments