[COMPILE] Warn at compile time, error at runtime, with (quote X Y), (function X Y).
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 1284642644 -3600
# Node ID 5663ae9a89895c1f42a18d6e3d3bf08f6a5fdc55
# Parent 0d43872986b6e54e666d9e4f30da5a2c9c6ce423
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
src/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* eval.c (Ffunction, Fquote):
Add argument information in the arguments: () format for these two
special operators.
diff -r 0d43872986b6 -r 5663ae9a8989 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 13:51:49 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 14:10:44 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el (byte-compile-function-form, byte-compile-quote)
+ (byte-compile-quote-form):
+ Warn at compile time, and error at runtime, if a (quote ...) or a
+ (function ...) form attempts to quote more than one object.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
diff -r 0d43872986b6 -r 5663ae9a8989 lisp/bytecomp.el
--- a/lisp/bytecomp.el Thu Sep 16 13:51:49 2010 +0100
+++ b/lisp/bytecomp.el Thu Sep 16 14:10:44 2010 +0100
＠＠ -3581,10 +3581,13 ＠＠
;; and (funcall (function foo)) will lose with autoloads.
(defun byte-compile-function-form (form)
- (byte-compile-constant
- (cond ((symbolp (nth 1 form))
- (nth 1 form))
- ((byte-compile-lambda (nth 1 form))))))
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(function ,(length (cdr form)))))
+ (byte-compile-constant
+ (cond ((symbolp (nth 1 form))
+ (nth 1 form))
+ ((byte-compile-lambda (nth 1 form)))))))
(defun byte-compile-insert (form)
(cond ((null (cdr form))
＠＠ -3714,11 +3717,16 ＠＠
(defun byte-compile-quote (form)
- (byte-compile-constant (car (cdr form))))
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(quote ,(length (cdr form)))))
+ (byte-compile-constant (car (cdr form)))))
(defun byte-compile-quote-form (form)
- (byte-compile-constant (byte-compile-top-level (nth 1 form))))
-
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(quote ,(length (cdr form)))))
+ (byte-compile-constant (byte-compile-top-level (nth 1 form)))))
;;; control structures
diff -r 0d43872986b6 -r 5663ae9a8989 src/ChangeLog
--- a/src/ChangeLog Thu Sep 16 13:51:49 2010 +0100
+++ b/src/ChangeLog Thu Sep 16 14:10:44 2010 +0100
＠＠ -1,3 +1,9 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * eval.c (Ffunction, Fquote):
+ Add argument information in the arguments: () format for these two
+ special operators.
+
2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freplace):
diff -r 0d43872986b6 -r 5663ae9a8989 src/eval.c
--- a/src/eval.c Thu Sep 16 13:51:49 2010 +0100
+++ b/src/eval.c Thu Sep 16 14:10:44 2010 +0100
＠＠ -1270,6 +1270,8 ＠＠
object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all
contexts. A print function may use either. Internally the expression is
represented as `(quote x)').
+
+arguments: (OBJECT)
*/
(args))
{
＠＠ -1350,6 +1352,8 ＠＠
object preceded by `#''. Thus, #'x is equivalent to (function x), in all
contexts. A print function may use either. Internally the expression is
represented as `(function x)').
+
+arguments: (SYMBOL-OR-LAMBDA)
*/
(args))
{
--
“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: Warn at compile time, error at runtime, with (quote X Y), (function X Y).
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5265:5663ae9a8989
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 14:10:44 2010 +0100
files: lisp/ChangeLog lisp/bytecomp.el src/ChangeLog src/eval.c
description:
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
src/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* eval.c (Ffunction, Fquote):
Add argument information in the arguments: () format for these two
special operators.
diff -r 0d43872986b6 -r 5663ae9a8989 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 13:51:49 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 14:10:44 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el (byte-compile-function-form, byte-compile-quote)
+ (byte-compile-quote-form):
+ Warn at compile time, and error at runtime, if a (quote ...) or a
+ (function ...) form attempts to quote more than one object.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
diff -r 0d43872986b6 -r 5663ae9a8989 lisp/bytecomp.el
--- a/lisp/bytecomp.el Thu Sep 16 13:51:49 2010 +0100
+++ b/lisp/bytecomp.el Thu Sep 16 14:10:44 2010 +0100
＠＠ -3581,10 +3581,13 ＠＠
;; and (funcall (function foo)) will lose with autoloads.
(defun byte-compile-function-form (form)
- (byte-compile-constant
- (cond ((symbolp (nth 1 form))
- (nth 1 form))
- ((byte-compile-lambda (nth 1 form))))))
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(function ,(length (cdr form)))))
+ (byte-compile-constant
+ (cond ((symbolp (nth 1 form))
+ (nth 1 form))
+ ((byte-compile-lambda (nth 1 form)))))))
(defun byte-compile-insert (form)
(cond ((null (cdr form))
＠＠ -3714,11 +3717,16 ＠＠
(defun byte-compile-quote (form)
- (byte-compile-constant (car (cdr form))))
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(quote ,(length (cdr form)))))
+ (byte-compile-constant (car (cdr form)))))
(defun byte-compile-quote-form (form)
- (byte-compile-constant (byte-compile-top-level (nth 1 form))))
-
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(quote ,(length (cdr form)))))
+ (byte-compile-constant (byte-compile-top-level (nth 1 form)))))
;;; control structures
diff -r 0d43872986b6 -r 5663ae9a8989 src/ChangeLog
--- a/src/ChangeLog Thu Sep 16 13:51:49 2010 +0100
+++ b/src/ChangeLog Thu Sep 16 14:10:44 2010 +0100
＠＠ -1,3 +1,9 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * eval.c (Ffunction, Fquote):
+ Add argument information in the arguments: () format for these two
+ special operators.
+
2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freplace):
diff -r 0d43872986b6 -r 5663ae9a8989 src/eval.c
--- a/src/eval.c Thu Sep 16 13:51:49 2010 +0100
+++ b/src/eval.c Thu Sep 16 14:10:44 2010 +0100
＠＠ -1270,6 +1270,8 ＠＠
object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all
contexts. A print function may use either. Internally the expression is
represented as `(quote x)').
+
+arguments: (OBJECT)
*/
(args))
{
＠＠ -1350,6 +1352,8 ＠＠
object preceded by `#''. Thus, #'x is equivalent to (function x), in all
contexts. A print function may use either. Internally the expression is
represented as `(function x)').
+
+arguments: (SYMBOL-OR-LAMBDA)
*/
(args))
{
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Change (apply 'nconc (mapcar ...)) to (mapcan ...); warn about first form.
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 1284641509 -3600
# Node ID 0d43872986b6e54e666d9e4f30da5a2c9c6ce423
# Parent 0d436a78c514cca5bc27c840366a2fa9b927fc00
Change (apply 'nconc (mapcar ...)) to (mapcan ...); warn about first form.
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
diff -r 0d436a78c514 -r 0d43872986b6 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 13:51:49 2010 +0100
＠＠ -1,3 +1,22 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
+ (mapcar ...)) to (mapcan ...); warn about use of the first idiom.
+
+ * update-elc.el (do-autoload-commands):
+ * packages.el (packages-find-package-library-path):
+ * frame.el (frame-list):
+ * extents.el (extent-descendants):
+ * etags.el (buffer-tag-table-files):
+ * dumped-lisp.el (preloaded-file-list):
+ * device.el (device-list):
+ * bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
+ Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
+
+ * bytecomp-runtime.el (eval-when-compile, eval-and-compile):
+ In passing, mention that these macros also evaluate the body when
+ interpreted.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (the): Add a docstring and an implementation for this
diff -r 0d436a78c514 -r 0d43872986b6 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/byte-optimize.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -1119,17 +1119,26 ＠＠
;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...).
(let ((fn (nth 1 form))
(last (nth (1- (length form)) form))) ; I think this really is fastest
- (or (if (or (null last)
- (eq (car-safe last) 'quote))
- (if (listp (nth 1 last))
- (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
- (nconc (list 'funcall fn) butlast
- (mapcar #'(lambda (x) (list 'quote x)) (nth 1 last))))
- (byte-compile-warn
- "last arg to apply can't be a literal atom: %s"
- (prin1-to-string last))
- nil))
- form)))
+ (if (and (eq last (third form))
+ (consp last)
+ (eq 'mapcar (car last))
+ (equal fn ''nconc))
+ (progn
+ (byte-compile-warn
+ "(apply 'nconc (mapcar ..)), use #'mapcan instead: %s" last)
+ (cons 'mapcan (cdr last)))
+ (or (if (or (null last)
+ (eq (car-safe last) 'quote))
+ (if (listp (nth 1 last))
+ (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
+ (nconc (list 'funcall fn) butlast
+ (mapcar #'(lambda (x) (list 'quote x))
+ (nth 1 last))))
+ (byte-compile-warn
+ "last arg to apply can't be a literal atom: %s"
+ (prin1-to-string last))
+ nil))
+ form))))
(put 'funcall 'byte-optimizer 'byte-optimize-funcall)
(put 'apply 'byte-optimizer 'byte-optimize-apply)
diff -r 0d436a78c514 -r 0d43872986b6 lisp/bytecomp-runtime.el
--- a/lisp/bytecomp-runtime.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/bytecomp-runtime.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -53,30 +53,26 ＠＠
"Cause the named functions to be open-coded when called from compiled code.
They will only be compiled open-coded when `byte-optimize' is true."
(cons 'eval-and-compile
- (apply
- 'nconc
- (mapcar
- #'(lambda (x)
- `((or (memq (get ',x 'byte-optimizer)
- '(nil byte-compile-inline-expand))
- (error
- "%s already has a byte-optimizer, can't make it inline"
- ',x))
- (put ',x 'byte-optimizer 'byte-compile-inline-expand)))
- fns))))
+ (mapcan
+ #'(lambda (x)
+ `((or (memq (get ',x 'byte-optimizer)
+ '(nil byte-compile-inline-expand))
+ (error
+ "%s already has a byte-optimizer, can't make it inline"
+ ',x))
+ (put ',x 'byte-optimizer 'byte-compile-inline-expand)))
+ fns)))
(defmacro proclaim-notinline (&rest fns)
"Cause the named functions to no longer be open-coded."
(cons 'eval-and-compile
- (apply
- 'nconc
- (mapcar
- #'(lambda (x)
- `((if (eq (get ',x 'byte-optimizer)
- 'byte-compile-inline-expand)
- (put ',x 'byte-optimizer nil))))
- fns))))
+ (mapcan
+ #'(lambda (x)
+ `((if (eq (get ',x 'byte-optimizer)
+ 'byte-compile-inline-expand)
+ (put ',x 'byte-optimizer nil))))
+ fns)))
;; This has a special byte-hunk-handler in bytecomp.el.
(defmacro defsubst (name arglist &rest body)
＠＠ -163,7 +159,7 ＠＠
(put 'eval-when-compile 'lisp-indent-hook 0)
(defmacro eval-when-compile (&rest body)
- "Like `progn', but evaluates the body at compile time.
+ "Like `progn', but evaluates BODY at compile time, and when interpeted.
The result of the body appears to the compiler as a quoted constant."
;; Not necessary because we have it in b-c-initial-macro-environment
;; (list 'quote (eval (cons 'progn body)))
＠＠ -171,7 +167,8 ＠＠
(put 'eval-and-compile 'lisp-indent-hook 0)
(defmacro eval-and-compile (&rest body)
- "Like `progn', but evaluates the body at compile time and at load time."
+ "Like `progn', but evaluates the body at compile time and at load time,
+and when interpreted."
;; Remember, it's magic.
(cons 'progn body))
diff -r 0d436a78c514 -r 0d43872986b6 lisp/device.el
--- a/lisp/device.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/device.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -45,7 +45,7 ＠＠
(defun device-list ()
"Return a list of all devices."
- (apply 'nconc (mapcar 'console-device-list (console-list))))
+ (mapcan 'console-device-list (console-list)))
(defun device-type (&optional device)
"Return the type of the specified device (e.g. `x' or `tty').
diff -r 0d436a78c514 -r 0d43872986b6 lisp/dumped-lisp.el
--- a/lisp/dumped-lisp.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/dumped-lisp.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -300,7 +300,4 ＠＠
))
(setq preloaded-file-list
- (apply #'nconc
- (mapcar #'(lambda (x)
- (if (listp x) x (list x)))
- preloaded-file-list)))
+ (mapcan #'(lambda (x) (if (listp x) x (list x))) preloaded-file-list))
diff -r 0d436a78c514 -r 0d43872986b6 lisp/etags.el
--- a/lisp/etags.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/etags.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -439,8 +439,7 ＠＠
(defun buffer-tag-table-files ()
"Returns a list of all files referenced by all TAGS tables that
this buffer uses."
- (apply #'append
- (mapcar #'tag-table-files (buffer-tag-table-list))))
+ (mapcan #'tag-table-files (buffer-tag-table-list)))
;; Building the completion table
diff -r 0d436a78c514 -r 0d43872986b6 lisp/extents.el
--- a/lisp/extents.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/extents.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -109,7 +109,7 ＠＠
EXTENT, until no more children can be found."
(let ((children (extent-children extent)))
(if children
- (apply 'nconc (mapcar 'extent-descendants children))
+ (mapcan 'extent-descendants children)
(list extent))))
(defun set-extent-keymap (extent keymap)
diff -r 0d436a78c514 -r 0d43872986b6 lisp/frame.el
--- a/lisp/frame.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/frame.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -861,7 +861,7 ＠＠
(defun frame-list ()
"Return a list of all frames on all devices/consoles."
;; Lists are copies, so nconc is safe here.
- (apply 'nconc (mapcar 'device-frame-list (device-list))))
+ (mapcan #'device-frame-list (device-list)))
(defun frame-type (&optional frame)
"Return the type of the specified frame (e.g. `x' or `tty').
diff -r 0d436a78c514 -r 0d43872986b6 lisp/packages.el
--- a/lisp/packages.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/packages.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -467,13 +467,11 ＠＠
PACKAGE-HIERARCHIES is a list of package hierarchies.
SUFFIXES is a list of names of hierarchy subdirectories to look for."
(let ((directories
- (apply
- #'nconc
- (mapcar #'(lambda (hierarchy)
- (mapcar #'(lambda (suffix)
- (file-name-as-directory (concat hierarchy suffix)))
- suffixes))
- package-hierarchies))))
+ (mapcan #'(lambda (hierarchy)
+ (mapcar #'(lambda (suffix)
+ (file-name-as-directory (concat hierarchy suffix)))
+ suffixes))
+ package-hierarchies)))
(paths-directories-which-exist directories)))
(defun packages-find-package-load-path (package-hierarchies)
diff -r 0d436a78c514 -r 0d43872986b6 lisp/update-elc.el
--- a/lisp/update-elc.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/update-elc.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -367,21 +367,19 ＠＠
;; load-ignore-elc-files because byte-optimize gets autoloaded
;; from bytecomp.
(let ((recompile-bc-bootstrap
- (apply #'nconc
- (mapcar
- #'(lambda (arg)
- (when (member arg update-elc-files-to-compile)
- (append '("-f" "batch-byte-compile-one-file")
- (list arg))))
- bc-bootstrap)))
+ (mapcan
+ #'(lambda (arg)
+ (when (member arg update-elc-files-to-compile)
+ (append '("-f" "batch-byte-compile-one-file")
+ (list arg))))
+ bc-bootstrap))
(recompile-bootstrap-other
- (apply #'nconc
- (mapcar
- #'(lambda (arg)
- (when (member arg update-elc-files-to-compile)
- (append '("-f" "batch-byte-compile-one-file")
- (list arg))))
- bootstrap-other))))
+ (mapcan
+ #'(lambda (arg)
+ (when (member arg update-elc-files-to-compile)
+ (append '("-f" "batch-byte-compile-one-file")
+ (list arg))))
+ bootstrap-other)))
(mapc
#'(lambda (arg)
(setq update-elc-files-to-compile
--
“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 implementation for #'the, cl-macs.el
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 1284640563 -3600
# Node ID 0d436a78c514cca5bc27c840366a2fa9b927fc00
# Parent 75bcb5bef4595fcc37f01e3e173d96b59fa8a821
Add an implementation for #'the, cl-macs.el
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (the): Add a docstring and an implementation for this
macro.
* bytecomp.el (byte-compile-initial-macro-environment): Add #'the
to this, checking byte-compile-delete-errors to decide whether to
make the type assertion. Change the initvalue to use backquote and
preceding commas for the lambda expressions, to allow the latter
to be compiled.
diff -r 75bcb5bef459 -r 0d436a78c514 lisp/ChangeLog
--- a/lisp/ChangeLog Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 13:36:03 2010 +0100
＠＠ -1,3 +1,13 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (the): Add a docstring and an implementation for this
+ macro.
+ * bytecomp.el (byte-compile-initial-macro-environment): Add #'the
+ to this, checking byte-compile-delete-errors to decide whether to
+ make the type assertion. Change the initvalue to use backquote and
+ preceding commas for the lambda expressions, to allow the latter
+ to be compiled.
+
2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-seq.el (replace):
diff -r 75bcb5bef459 -r 0d436a78c514 lisp/bytecomp.el
--- a/lisp/bytecomp.el Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/bytecomp.el Thu Sep 16 13:36:03 2010 +0100
＠＠ -493,13 +493,21 ＠＠
(fset (car elt) (cdr elt)))))))
(defconst byte-compile-initial-macro-environment
- '((byte-compiler-options . (lambda (&rest forms)
- (apply 'byte-compiler-options-handler forms)))
- (eval-when-compile . (lambda (&rest body)
- (list 'quote (byte-compile-eval (cons 'progn body)))))
- (eval-and-compile . (lambda (&rest body)
- (byte-compile-eval (cons 'progn body))
- (cons 'progn body))))
+ `((byte-compiler-options
+ . ,#'(lambda (&rest forms)
+ (apply 'byte-compiler-options-handler forms)))
+ (eval-when-compile
+ . ,#'(lambda (&rest body)
+ (list 'quote (byte-compile-eval (cons 'progn body)))))
+ (eval-and-compile
+ . ,#'(lambda (&rest body)
+ (byte-compile-eval (cons 'progn body))
+ (cons 'progn body)))
+ (the .
+ ,#'(lambda (&rest body)
+ (if byte-compile-delete-errors
+ (second body)
+ (apply (cdr (symbol-function 'the)) body)))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
diff -r 75bcb5bef459 -r 0d436a78c514 lisp/cl-macs.el
--- a/lisp/cl-macs.el Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/cl-macs.el Thu Sep 16 13:36:03 2010 +0100
＠＠ -1962,7 +1962,19 ＠＠
;;;###autoload
(defmacro locally (&rest body) (cons 'progn body))
;;;###autoload
-(defmacro the (type form) form)
+(defmacro the (type form)
+ "Assert that FORM gives a result of type TYPE, and return FORM.
+
+TYPE is a Common Lisp type specifier.
+
+If macro expansion of a `the' form happens during byte compilation, and the
+byte compiler customization variable `byte-compile-delete-errors' is
+non-nil, `the' just returns FORM, without making any type checks."
+ (if (cl-safe-expr-p form)
+ `(prog1 ,form (assert ,(cl-make-type-test form type) t))
+ (let ((saved (gensym)))
+ `(let ((,saved ,form))
+ (prog1 ,saved (assert ,(cl-make-type-test saved type) t))))))
(defvar cl-proclaim-history t) ; for future compilers
(defvar cl-declare-stack t) ; for future compilers
--
“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 implementation for #'the, cl-macs.el
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5263:0d436a78c514
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 13:36:03 2010 +0100
files: lisp/ChangeLog lisp/bytecomp.el lisp/cl-macs.el
description:
Add an implementation for #'the, cl-macs.el
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (the): Add a docstring and an implementation for this
macro.
* bytecomp.el (byte-compile-initial-macro-environment): Add #'the
to this, checking byte-compile-delete-errors to decide whether to
make the type assertion. Change the initvalue to use backquote and
preceding commas for the lambda expressions, to allow the latter
to be compiled.
diff -r 75bcb5bef459 -r 0d436a78c514 lisp/ChangeLog
--- a/lisp/ChangeLog Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 13:36:03 2010 +0100
＠＠ -1,3 +1,13 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (the): Add a docstring and an implementation for this
+ macro.
+ * bytecomp.el (byte-compile-initial-macro-environment): Add #'the
+ to this, checking byte-compile-delete-errors to decide whether to
+ make the type assertion. Change the initvalue to use backquote and
+ preceding commas for the lambda expressions, to allow the latter
+ to be compiled.
+
2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-seq.el (replace):
diff -r 75bcb5bef459 -r 0d436a78c514 lisp/bytecomp.el
--- a/lisp/bytecomp.el Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/bytecomp.el Thu Sep 16 13:36:03 2010 +0100
＠＠ -493,13 +493,21 ＠＠
(fset (car elt) (cdr elt)))))))
(defconst byte-compile-initial-macro-environment
- '((byte-compiler-options . (lambda (&rest forms)
- (apply 'byte-compiler-options-handler forms)))
- (eval-when-compile . (lambda (&rest body)
- (list 'quote (byte-compile-eval (cons 'progn body)))))
- (eval-and-compile . (lambda (&rest body)
- (byte-compile-eval (cons 'progn body))
- (cons 'progn body))))
+ `((byte-compiler-options
+ . ,#'(lambda (&rest forms)
+ (apply 'byte-compiler-options-handler forms)))
+ (eval-when-compile
+ . ,#'(lambda (&rest body)
+ (list 'quote (byte-compile-eval (cons 'progn body)))))
+ (eval-and-compile
+ . ,#'(lambda (&rest body)
+ (byte-compile-eval (cons 'progn body))
+ (cons 'progn body)))
+ (the .
+ ,#'(lambda (&rest body)
+ (if byte-compile-delete-errors
+ (second body)
+ (apply (cdr (symbol-function 'the)) body)))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
diff -r 75bcb5bef459 -r 0d436a78c514 lisp/cl-macs.el
--- a/lisp/cl-macs.el Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/cl-macs.el Thu Sep 16 13:36:03 2010 +0100
＠＠ -1962,7 +1962,19 ＠＠
;;;###autoload
(defmacro locally (&rest body) (cons 'progn body))
;;;###autoload
-(defmacro the (type form) form)
+(defmacro the (type form)
+ "Assert that FORM gives a result of type TYPE, and return FORM.
+
+TYPE is a Common Lisp type specifier.
+
+If macro expansion of a `the' form happens during byte compilation, and the
+byte compiler customization variable `byte-compile-delete-errors' is
+non-nil, `the' just returns FORM, without making any type checks."
+ (if (cl-safe-expr-p form)
+ `(prog1 ,form (assert ,(cl-make-type-test form type) t))
+ (let ((saved (gensym)))
+ `(let ((,saved ,form))
+ (prog1 ,saved (assert ,(cl-make-type-test saved type) t))))))
(defvar cl-proclaim-history t) ; for future compilers
(defvar cl-declare-stack t) ; for future compilers
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] mouse-yank-function missing in XEmacs build with no window system
14 years, 3 months
The XEmacs Package Smoketest
The XEmacs Package Smoketest
COMMIT
NOTE: This patch has been committed.
Packages ChangeLog patch:
Diff command: cvs -q diff -U0
Files affected: xemacs-packages/x-symbol/ChangeLog
Index: xemacs-packages/x-symbol/ChangeLog
===================================================================
RCS file: /cvsroot/xemacs/XEmacs/packages/xemacs-packages/x-symbol/ChangeLog,v
retrieving revision 1.27
diff -U 0 -r1.27 ChangeLog
--- xemacs-packages/x-symbol/ChangeLog 29 Jul 2010 20:16:20 -0000 1.27
+++ xemacs-packages/x-symbol/ChangeLog 7 Sep 2010 21:16:50 -0000
＠＠ -0,0 +1,6 ＠＠
+2010-09-07 Mats Lidell <matsl(a)contactor.se>
+
+ * lisp/x-symbol-nomule.el (x-symbol-nomule-mouse-yank-function):
+ XEmacs build with no window system has not got
+ mouse-yank-function.
+
Packages source patch:
Diff command: cvs -q diff -u
Files affected: xemacs-packages/x-symbol/lisp/x-symbol-nomule.el
Index: xemacs-packages/x-symbol/lisp/x-symbol-nomule.el
===================================================================
RCS file: /cvsroot/xemacs/XEmacs/packages/xemacs-packages/x-symbol/lisp/x-symbol-nomule.el,v
retrieving revision 1.4
diff -u -r1.4 x-symbol-nomule.el
--- xemacs-packages/x-symbol/lisp/x-symbol-nomule.el 13 Jul 2008 14:25:56 -0000 1.4
+++ xemacs-packages/x-symbol/lisp/x-symbol-nomule.el 7 Sep 2010 21:14:34 -0000
＠＠ -67,7 +67,9 ＠＠
(aref display-table character)
(get-char-table character display-table)))
-(defvar x-symbol-nomule-mouse-yank-function mouse-yank-function
+(defvar x-symbol-nomule-mouse-yank-function
+ (and (boundp 'mouse-yank-function)
+ mouse-yank-function)
"Function that is called upon by `x-symbol-nomule-mouse-yank-function'.")
(defvar x-symbol-nomule-mouse-track-function
--
%% Mats
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Replace a doubled semi-colon with a single semi-colon, fns.c, for VS6's sake.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
Ar an séiú lá de mí Méan Fómhair, scríobh Vin Shelton:
> I think this patch broke the VS6 compile of fns.c:
>
> C:\cygwin\usr\local\src\xemacs-21.5-proc-2010-09-06\src\fns.c(1198) :
> warning C4244: '=' : conversion from 'double ' to 'long ', possible
> loss of data
> C:\cygwin\usr\local\src\xemacs-21.5-proc-2010-09-06\src\fns.c(5866) :
> error C2143: syntax error : missing ';' before 'type'
> C:\cygwin\usr\local\src\xemacs-21.5-proc-2010-09-06\src\fns.c(5879) :
> error C2065: 'obj' : undeclared identifier
> NMAKE : fatal error U1077: 'cl' : return code '0x2'
> Stop.
>
> Thanks for looking into this.
What an odd error. Anyway, it’s clear enough what’s wrong once you look at
the relevant lines, and I’ve committed the below. Please confirm whether the
change fixes the build for you, as I mention in the ChangeLog entry I didn’t
see the problem with Visual Studio 2005, and thanks for reporting the
problem.
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1283875426 -3600
# Node ID 75bcb5bef4595fcc37f01e3e173d96b59fa8a821
# Parent 69f687b3ba9d833c9f7b2872e679b511df1c578b
Replace a doubled semi-colon with a single semi-colon, fns.c, for VS6's sake.
src/ChangeLog addition:
2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freplace):
Replace an accidental double semi-colon with a single semi-colon,
hopefully fixing Vin's Visual Studio 6 build. (Visual Studio 2005
had no problem with it, oddly.)
diff -r 69f687b3ba9d -r 75bcb5bef459 src/ChangeLog
--- a/src/ChangeLog Mon Sep 06 17:29:51 2010 +0100
+++ b/src/ChangeLog Tue Sep 07 17:03:46 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Freplace):
+ Replace an accidental double semi-colon with a single semi-colon,
+ hopefully fixing Vin's Visual Studio 6 build. (Visual Studio 2005
+ had no problem with it, oddly.)
+
2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
Move #'replace to C; add bounds checking to it and to #'fill.
diff -r 69f687b3ba9d -r 75bcb5bef459 src/fns.c
--- a/src/fns.c Mon Sep 06 17:29:51 2010 +0100
+++ b/src/fns.c Tue Sep 07 17:03:46 2010 +0100
＠＠ -5862,7 +5862,7 ＠＠
{
Ibyte *staging, *cursor;
Elemcount count, len1 = string_char_length (sequence1);
- Elemcount len2 = XINT (Flength (sequence2)), ii = 0;;
+ Elemcount len2 = XINT (Flength (sequence2)), ii = 0;
Lisp_Object obj;
check_sequence_range (sequence1, start1, end1, make_int (len1));
--
“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: Replace a doubled semi-colon with a single semi-colon, fns.c, for VS6's sake.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5262:75bcb5bef459
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Tue Sep 07 17:03:46 2010 +0100
files: src/ChangeLog src/fns.c
description:
Replace a doubled semi-colon with a single semi-colon, fns.c, for VS6's sake.
src/ChangeLog addition:
2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freplace):
Replace an accidental double semi-colon with a single semi-colon,
hopefully fixing Vin's Visual Studio 6 build. (Visual Studio 2005
had no problem with it, oddly.)
diff -r 69f687b3ba9d -r 75bcb5bef459 src/ChangeLog
--- a/src/ChangeLog Mon Sep 06 17:29:51 2010 +0100
+++ b/src/ChangeLog Tue Sep 07 17:03:46 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Freplace):
+ Replace an accidental double semi-colon with a single semi-colon,
+ hopefully fixing Vin's Visual Studio 6 build. (Visual Studio 2005
+ had no problem with it, oddly.)
+
2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
Move #'replace to C; add bounds checking to it and to #'fill.
diff -r 69f687b3ba9d -r 75bcb5bef459 src/fns.c
--- a/src/fns.c Mon Sep 06 17:29:51 2010 +0100
+++ b/src/fns.c Tue Sep 07 17:03:46 2010 +0100
＠＠ -5862,7 +5862,7 ＠＠
{
Ibyte *staging, *cursor;
Elemcount count, len1 = string_char_length (sequence1);
- Elemcount len2 = XINT (Flength (sequence2)), ii = 0;;
+ Elemcount len2 = XINT (Flength (sequence2)), ii = 0;
Lisp_Object obj;
check_sequence_range (sequence1, start1, end1, make_int (len1));
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [PATCH] Make x-symbol-nomule.el compile with no mouse-yank-function
14 years, 3 months
The XEmacs Package Smoketest
The XEmacs Package Smoketest
>>>>> Mats Lidell <matsl(a)xemacs.org> writes:
Mats> I don't have the Karma to commit this patch. Can someone who has
Mats> please do.
I have also reverted this patch from the Package Smoketest so that the
smoketest now is based on what is in the repository.
Yours
--
%% Mats
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Move #'replace to C, add bounds-checking to it and to #'fill.
14 years, 3 months
Aidan Kehoe
Aidan Kehoe
I’ve tested this with Paul Dietz’ test suite, and our integrated tests also
have no problem with it. My compilation was --with-union-type and
--with-xemacs-compiler=g++, so it’s not super likely that there are build
problems, but Windows can always surprise me.
The bounds checking was something added for ANSI Common Lisp, and cl*.el in
general doesn’t reflect it. Nor does my C implementaion of #'reduce, for the
moment.
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1283790591 -3600
# Node ID 69f687b3ba9d833c9f7b2872e679b511df1c578b
# Parent dceee3855f15dbb5f66e965b04eb0e503fad8da5
Move #'replace to C, add bounds-checking to it and to #'fill.
2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
Move #'replace to C; add bounds checking to it and to #'fill.
* fns.c (Fsubseq, Ffill, mapcarX):
Don't #'nreverse in #'subseq, use fill_string_range and check
bounds in #'fill, use replace_string_range() in #'map-into
avoiding quadratic time when modfiying the string.
* fns.c (check_sequence_range, fill_string_range)
(replace_string_range, replace_string_range_1, Freplace):
New functions; check that arguments fit sequence dimensions, fill
a string range with a given character, replace a string range from
an Ibyte pointer.
diff -r dceee3855f15 -r 69f687b3ba9d lisp/ChangeLog
--- a/lisp/ChangeLog Sun Sep 05 20:31:05 2010 +0100
+++ b/lisp/ChangeLog Mon Sep 06 17:29:51 2010 +0100
＠＠ -1,3 +1,9 ＠＠
+2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-seq.el (replace):
+ Move this function, with added bounds-checking per ANSI Common
+ Lisp, to fns.c.
+
2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
* x-compose.el (define-compose-map, compose-map)
diff -r dceee3855f15 -r 69f687b3ba9d lisp/cl-seq.el
--- a/lisp/cl-seq.el Sun Sep 05 20:31:05 2010 +0100
+++ b/lisp/cl-seq.el Mon Sep 06 17:29:51 2010 +0100
＠＠ -142,48 +142,7 ＠＠
(defvar cl-if) (defvar cl-if-not)
(defvar cl-key)
-(defun replace (cl-seq1 cl-seq2 &rest cl-keys)
- "Replace the elements of SEQ1 with the elements of SEQ2.
-SEQ1 is destructively modified, then returned.
-Keywords supported: :start1 :end1 :start2 :end2
-:start1 and :end1 specify a subsequence of SEQ1, and :start2 and :end2 a
-subsequence of SEQ2; see `search' for more information."
- (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
- (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
- (or (= cl-start1 cl-start2)
- (let* ((cl-len (length cl-seq1))
- (cl-n (min (- (or cl-end1 cl-len) cl-start1)
- (- (or cl-end2 cl-len) cl-start2))))
- (while (>= (setq cl-n (1- cl-n)) 0)
- (cl-set-elt cl-seq1 (+ cl-start1 cl-n)
- (elt cl-seq2 (+ cl-start2 cl-n))))))
- (if (listp cl-seq1)
- (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
- (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000)))
- (if (listp cl-seq2)
- (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
- (cl-n (min cl-n1
- (if cl-end2 (- cl-end2 cl-start2) 4000000))))
- (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0))
- (setcar cl-p1 (car cl-p2))
- (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
- (setq cl-end2 (min (or cl-end2 (length cl-seq2))
- (+ cl-start2 cl-n1)))
- (while (and cl-p1 (< cl-start2 cl-end2))
- (setcar cl-p1 (aref cl-seq2 cl-start2))
- (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
- (setq cl-end1 (min (or cl-end1 (length cl-seq1))
- (+ cl-start1 (- (or cl-end2 (length cl-seq2))
- cl-start2))))
- (if (listp cl-seq2)
- (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
- (while (< cl-start1 cl-end1)
- (aset cl-seq1 cl-start1 (car cl-p2))
- (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
- (while (< cl-start1 cl-end1)
- (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
- (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
- cl-seq1))
+;; XEmacs; #'replace is in fns.c.
(defun remove* (cl-item cl-seq &rest cl-keys)
"Remove all occurrences of ITEM in SEQ.
diff -r dceee3855f15 -r 69f687b3ba9d src/ChangeLog
--- a/src/ChangeLog Sun Sep 05 20:31:05 2010 +0100
+++ b/src/ChangeLog Mon Sep 06 17:29:51 2010 +0100
＠＠ -1,3 +1,18 ＠＠
+2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Move #'replace to C; add bounds checking to it and to #'fill.
+
+ * fns.c (Fsubseq, Ffill, mapcarX):
+ Don't #'nreverse in #'subseq, use fill_string_range and check
+ bounds in #'fill, use replace_string_range() in #'map-into
+ avoiding quadratic time when modfiying the string.
+
+ * fns.c (check_sequence_range, fill_string_range)
+ (replace_string_range, replace_string_range_1, Freplace):
+ New functions; check that arguments fit sequence dimensions, fill
+ a string range with a given character, replace a string range from
+ an Ibyte pointer.
+
2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
* chartab.c (char_table_default_for_type,
diff -r dceee3855f15 -r 69f687b3ba9d src/fns.c
--- a/src/fns.c Sun Sep 05 20:31:05 2010 +0100
+++ b/src/fns.c Mon Sep 06 17:29:51 2010 +0100
＠＠ -54,11 +54,12 ＠＠
/* NOTE: This symbol is also used in lread.c */
#define FEATUREP_SYNTAX
-Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill;
+Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill, Qreplace;
Lisp_Object Qidentity;
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 Qbase64_conversion_error;
＠＠ -73,6 +74,20 ＠＠
invalid_state_2 ("object modified while traversing it", func, object);
}
+static void
+check_sequence_range (Lisp_Object sequence, Lisp_Object start,
+ Lisp_Object end, Lisp_Object length)
+{
+ Elemcount starting = XINT (start), ending, len = XINT (length);
+
+ ending = NILP (end) ? XINT (length) : XINT (end);
+
+ if (!(0 <= starting && starting <= ending && ending <= len))
+ {
+ args_out_of_range_3 (sequence, start, make_int (ending));
+ }
+}
+
static Lisp_Object
mark_bit_vector (Lisp_Object UNUSED (obj))
{
＠＠ -885,7 +900,7 ＠＠
{
CHECK_CHAR_COERCE_INT (elt);
string_result_ptr += set_itext_ichar (string_result_ptr,
- XCHAR (elt));
+ XCHAR (elt));
}
}
if (args_mse)
＠＠ -1044,8 +1059,8 ＠＠
e = len + e;
}
- if (!(0 <= s && s <= e && e <= len))
- args_out_of_range_3 (sequence, make_int (s), make_int (e));
+ check_sequence_range (sequence, make_int (s), make_int (e),
+ make_int (len));
if (VECTORP (sequence))
{
＠＠ -1060,18 +1075,24 ＠＠
}
else if (LISTP (sequence))
{
- Lisp_Object result = Qnil;
+ Lisp_Object result = Qnil, result_tail;
EMACS_INT i;
sequence = Fnthcdr (make_int (s), sequence);
- for (i = s; i < e; i++)
- {
- result = Fcons (Fcar (sequence), result);
+ if (s < e)
+ {
+ result = result_tail = Fcons (Fcar (sequence), Qnil);
sequence = Fcdr (sequence);
- }
-
- return Fnreverse (result);
+ 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))
{
＠＠ -3872,6 +3893,29 ＠＠
}
+static Lisp_Object replace_string_range_1 (Lisp_Object dest,
+ Lisp_Object start,
+ Lisp_Object end,
+ const Ibyte *source,
+ const Ibyte *source_limit,
+ Lisp_Object item);
+
+/* Fill the substring of DEST beginning at START and ending before END with
+ the character ITEM. If DEST does not have sufficient space for END -
+ START characters at START, write as many as is possible without changing
+ the character length of DEST. Update the string modification flag and do
+ any sledgehammer checks we have turned on.
+
+ START must be a Lisp integer. END can be nil, indicating the length of the
+ string, or a Lisp integer. The condition (<= 0 START END (length DEST))
+ must hold, or fill_string_range() will signal an error. */
+static Lisp_Object
+fill_string_range (Lisp_Object dest, Lisp_Object item, Lisp_Object start,
+ Lisp_Object end)
+{
+ return replace_string_range_1 (dest, start, end, NULL, NULL, item);
+}
+
DEFUN ("fill", Ffill, 2, MANY, 0, /*
Destructively modify SEQUENCE by replacing each element with ITEM.
SEQUENCE is a list, vector, bit vector, or string.
＠＠ -3881,21 +3925,20 ＠＠
exclusive upper bound on the elements of SEQUENCE to be modified, and
defaults to the length of SEQUENCE.
-arguments: (SEQUENCE ITEM &key (START 0) END)
+arguments: (SEQUENCE ITEM &key (START 0) (END (length SEQUENCE)))
*/
(int nargs, Lisp_Object *args))
{
Lisp_Object sequence = args[0];
Lisp_Object item = args[1];
- Elemcount starting = 0, ending = EMACS_INT_MAX, ii;
-
- PARSE_KEYWORDS (Qfill, nargs, args, 2, 2, (start, end),
- (start = Qzero, end = Qunbound), 0);
+ Elemcount starting = 0, ending = EMACS_INT_MAX, ii, len;
+
+ PARSE_KEYWORDS (Qfill, nargs, args, 2, 2, (start, end), (start = Qzero), 0);
CHECK_NATNUM (start);
starting = XINT (start);
- if (!UNBOUNDP (end))
+ if (!NILP (end))
{
CHECK_NATNUM (end);
ending = XINT (end);
＠＠ -3904,49 +3947,21 ＠＠
retry:
if (STRINGP (sequence))
{
- Bytecount prefix_bytecount, item_bytecount, delta;
- Ibyte item_buf[MAX_ICHAR_LEN];
- Ibyte *p, *pend;
-
CHECK_CHAR_COERCE_INT (item);
-
CHECK_LISP_WRITEABLE (sequence);
- sledgehammer_check_ascii_begin (sequence);
- item_bytecount = set_itext_ichar (item_buf, XCHAR (item));
-
- p = XSTRING_DATA (sequence);
- p = (Ibyte *) itext_n_addr (p, starting);
- prefix_bytecount = p - XSTRING_DATA (sequence);
-
- ending = min (ending, string_char_length (sequence));
- pend = (Ibyte *) itext_n_addr (p, ending - starting);
- delta = ((ending - starting) * item_bytecount) - (pend - p);
-
- /* Resize the string if the bytecount for the area being modified is
- different. */
- if (delta)
- {
- resize_string (sequence, prefix_bytecount, delta);
- /* No need to zero-terminate the string, resize_string has done
- that for us. */
- p = XSTRING_DATA (sequence) + prefix_bytecount;
- pend = p + ((ending - starting) * item_bytecount);
- }
-
- for (; p < pend; p += item_bytecount)
- memcpy (p, item_buf, item_bytecount);
-
-
- init_string_ascii_begin (sequence);
- bump_string_modiff (sequence);
- sledgehammer_check_ascii_begin (sequence);
+
+ fill_string_range (sequence, item, start, end);
}
else if (VECTORP (sequence))
{
Lisp_Object *p = XVECTOR_DATA (sequence);
+
CHECK_LISP_WRITEABLE (sequence);
-
- ending = min (ending, XVECTOR_LENGTH (sequence));
+ len = XVECTOR_LENGTH (sequence);
+
+ check_sequence_range (sequence, start, end, make_int (len));
+ ending = min (ending, len);
+
for (ii = starting; ii < ending; ++ii)
{
p[ii] = item;
＠＠ -3956,11 +3971,15 ＠＠
{
Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
int bit;
+
CHECK_BIT (item);
bit = XINT (item);
CHECK_LISP_WRITEABLE (sequence);
-
- ending = min (ending, bit_vector_length (v));
+ len = bit_vector_length (v);
+
+ check_sequence_range (sequence, start, end, make_int (len));
+ ending = min (ending, len);
+
for (ii = starting; ii < ending; ++ii)
{
set_bit_vector_bit (v, ii, bit);
＠＠ -3985,6 +4004,11 ＠＠
}
++counting;
}
+
+ if (counting != ending)
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
}
else
{
＠＠ -4129,6 +4153,24 ＠＠
}
+/* Replace the substring of DEST beginning at START and ending before END
+ with the text at SOURCE, which is END - START characters long and
+ SOURCE_LIMIT - SOURCE octets long. If DEST does not have sufficient
+ space for END - START characters at START, write as many as is possible
+ without changing the length of DEST. Update the string modification flag
+ and do any sledgehammer checks we have turned on in this build.
+
+ START must be a Lisp integer. END can be nil, indicating the length of the
+ string, or a Lisp integer. The condition (<= 0 START END (length DEST))
+ must hold, or replace_string_range() will signal an error. */
+static Lisp_Object
+replace_string_range (Lisp_Object dest, Lisp_Object start, Lisp_Object end,
+ const Ibyte *source, const Ibyte *source_limit)
+{
+ return replace_string_range_1 (dest, start, end, source, source_limit,
+ Qnil);
+}
+
/* This is the guts of several mapping functions.
Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time,
＠＠ -4168,6 +4210,7 ＠＠
{
Lisp_Object called, *args;
struct gcpro gcpro1, gcpro2;
+ Ibyte *lisp_vals_staging, *cursor;
int i, j;
assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1);
＠＠ -4224,9 +4267,15 ＠＠
if (!EQ (caller, Qsome) && !EQ (caller, Qevery))
{
assert (LRECORDP (lisp_vals));
+
lisp_vals_type
= (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type;
- assert (NILP (lisp_vals) || lisp_vals_type != lrecord_type_symbol);
+
+ if (lrecord_type_string == lisp_vals_type)
+ {
+ lisp_vals_staging = cursor
+ = alloca_ibytes (call_count * MAX_ICHAR_LEN);
+ }
}
for (i = 0; i < call_count; ++i)
＠＠ -4305,8 +4354,7 ＠＠
switch (lisp_vals_type)
{
case lrecord_type_symbol:
- /* This is #'mapc; the result of the funcall is
- discarded. */
+ /* Discard the result of funcall. */
break;
case lrecord_type_cons:
{
＠＠ -4331,10 +4379,8 ＠＠
}
case lrecord_type_string:
{
- /* If this ever becomes a code hotspot, we can keep
- around pointers into the data of the string, checking
- each time that it hasn't been relocated. */
- Faset (lisp_vals, make_int (i), called);
+ CHECK_CHAR_COERCE_INT (called);
+ cursor += set_itext_ichar (cursor, XCHAR (called));
break;
}
case lrecord_type_bit_vector:
＠＠ -4354,7 +4400,15 ＠＠
}
}
}
- }
+
+ if (!EQ (caller, Qsome) && !EQ (caller, Qevery) &&
+ lrecord_type_string == lisp_vals_type)
+ {
+ replace_string_range (lisp_vals, Qzero, make_int (call_count),
+ lisp_vals_staging, cursor);
+ }
+ }
+
UNGCPRO;
}
＠＠ -5302,6 +5356,590 ＠＠
return old;
}
+/* This function is the implementation of fill_string_range() and
+ replace_string_range(); see the comments for those functions. */
+static Lisp_Object
+replace_string_range_1 (Lisp_Object dest, Lisp_Object start, Lisp_Object end,
+ const Ibyte *source, const Ibyte *source_limit,
+ Lisp_Object item)
+{
+ Ibyte *destp = XSTRING_DATA (dest), *p = destp,
+ *pend = p + XSTRING_LENGTH (dest), *pcursor, item_buf[MAX_ICHAR_LEN];
+ Bytecount prefix_bytecount, source_len = source_limit - source;
+ Charcount ii = 0, starting = XINT (start), ending, len;
+ Elemcount delta;
+
+ while (ii < starting && p < pend)
+ {
+ INC_IBYTEPTR (p);
+ ii++;
+ }
+
+ pcursor = p;
+
+ if (NILP (end))
+ {
+ while (pcursor < pend)
+ {
+ INC_IBYTEPTR (pcursor);
+ ii++;
+ }
+
+ ending = len = ii;
+ }
+ else
+ {
+ ending = XINT (end);
+ while (ii < ending && pcursor < pend)
+ {
+ INC_IBYTEPTR (pcursor);
+ ii++;
+ }
+ }
+
+ if (pcursor == pend)
+ {
+ /* We have the length, check it for our callers. */
+ check_sequence_range (dest, start, end, make_int (ii));
+ }
+
+ if (!(p == pend || p == pcursor))
+ {
+ prefix_bytecount = p - destp;
+
+ if (!NILP (item))
+ {
+ assert (source == NULL && source_limit == NULL);
+ source_len = set_itext_ichar (item_buf, XCHAR (item));
+ delta = (source_len * (ending - starting)) - (pcursor - p);
+ }
+ else
+ {
+ assert (source != NULL && source_limit != NULL);
+ delta = source_len - (pcursor - p);
+ }
+
+ if (delta)
+ {
+ resize_string (dest, prefix_bytecount, delta);
+ destp = XSTRING_DATA (dest);
+ pcursor = destp + prefix_bytecount + (pcursor - p);
+ p = destp + prefix_bytecount;
+ }
+
+ if (CHARP (item))
+ {
+ while (starting < ending)
+ {
+ memcpy (p, item_buf, source_len);
+ p += source_len;
+ starting++;
+ }
+ }
+ else
+ {
+ while (starting < ending && source < source_limit)
+ {
+ source_len = itext_copy_ichar (source, p);
+ p += source_len, source += source_len;
+ }
+ }
+
+ init_string_ascii_begin (dest);
+ bump_string_modiff (dest);
+ sledgehammer_check_ascii_begin (dest);
+ }
+
+ return dest;
+}
+
+DEFUN ("replace", Freplace, 2, MANY, 0, /*
+Replace the elements of SEQUENCE-ONE with the elements of SEQUENCE-TWO.
+
+SEQUENCE-ONE is destructively modified, and returned. Its length is not
+changed.
+
+Keywords:start1 and :end1 specify a subsequence of SEQUENCE-ONE, and
+:start2 and :end2 a subsequence of SEQUENCE-TWO. See `search' for more
+information.
+
+arguments: (SEQUENCE-ONE SEQUENCE-TWO &key (START1 0) (END1 (length SEQUENCE-ONE)) (START2 0) (END2 (length SEQUENCE-TWO)))
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence1 = args[0], sequence2 = args[1],
+ result = sequence1;
+ Elemcount starting1, ending1 = EMACS_INT_MAX, starting2;
+ Elemcount ending2 = EMACS_INT_MAX, counting, startcounting;
+ Boolint sequence1_listp, sequence2_listp,
+ overwriting = EQ (sequence1, sequence2);
+
+ PARSE_KEYWORDS (Qreplace, nargs, args, 2, 4, (start1, end1, start2, end2),
+ (start1 = start2 = Qzero), 0);
+
+ CHECK_SEQUENCE (sequence1);
+ CHECK_LISP_WRITEABLE (sequence1);
+
+ CHECK_SEQUENCE (sequence2);
+
+ CHECK_NATNUM (start1);
+ starting1 = XINT (start1);
+ CHECK_NATNUM (start2);
+ starting2 = XINT (start2);
+
+ if (!NILP (end1))
+ {
+ CHECK_NATNUM (end1);
+ ending1 = XINT (end1);
+
+ if (!(starting1 <= ending1))
+ {
+ args_out_of_range_3 (sequence1, start1, end1);
+ }
+ }
+
+ if (!NILP (end2))
+ {
+ CHECK_NATNUM (end2);
+ ending2 = XINT (end2);
+
+ if (!(starting2 <= ending2))
+ {
+ args_out_of_range_3 (sequence1, start2, end2);
+ }
+ }
+
+ sequence1_listp = LISTP (sequence1);
+ sequence2_listp = LISTP (sequence2);
+
+ overwriting = overwriting && starting2 <= starting1;
+
+ if (sequence1_listp && !ZEROP (start1))
+ {
+ Lisp_Object nthcdrd = Fnthcdr (start1, sequence1);
+
+ if (NILP (nthcdrd))
+ {
+ check_sequence_range (sequence1, start1, end1, Flength (sequence1));
+ /* 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));
+ /* Nothing available to replace sequence1's contents. */
+ return result;
+ }
+
+ sequence2 = nthcdrd;
+ ending2 -= starting2;
+ starting2 = 0;
+ }
+
+ if (overwriting)
+ {
+ if (EQ (start1, start2))
+ {
+ return result;
+ }
+
+ /* Our ranges may overlap. Save the data that might be overwritten. */
+
+ if (CONSP (sequence2))
+ {
+ Elemcount len = XINT (Flength (sequence2));
+ Lisp_Object *subsequence
+ = alloca_array (Lisp_Object, min (ending2, len));
+ Elemcount counting = 0, ii = 0;
+
+ LIST_LOOP_2 (elt, sequence2)
+ {
+ if (counting == ending2)
+ {
+ break;
+ }
+
+ subsequence[ii++] = elt;
+ counting++;
+ }
+
+ check_sequence_range (sequence1, start1, end1,
+ /* The XINT (start2) is intentional here; we
+ called #'length after doing (nthcdr
+ start2 sequence2). */
+ make_int (XINT (start2) + len));
+ check_sequence_range (sequence2, start2, end2,
+ make_int (XINT (start2) + len));
+
+ while (starting1 < ending1
+ && starting2 < ending2 && !NILP (sequence1))
+ {
+ XSETCAR (sequence1, subsequence[starting2]);
+ sequence1 = XCDR (sequence1);
+ starting1++;
+ starting2++;
+ }
+ }
+ else if (STRINGP (sequence2))
+ {
+ Ibyte *p = XSTRING_DATA (sequence2),
+ *pend = p + XSTRING_LENGTH (sequence2), *pcursor,
+ *staging;
+ Bytecount ii = 0;
+
+ while (ii < starting2 && p < pend)
+ {
+ INC_IBYTEPTR (p);
+ ii++;
+ }
+
+ pcursor = p;
+
+ while (ii < ending2 && starting1 < ending1 && pcursor < pend)
+ {
+ INC_IBYTEPTR (pcursor);
+ starting1++;
+ ii++;
+ }
+
+ if (pcursor == pend)
+ {
+ check_sequence_range (sequence1, start1, end1, make_int (ii));
+ check_sequence_range (sequence2, start2, end2, make_int (ii));
+ }
+ else
+ {
+ assert ((pcursor - p) > 0);
+ staging = alloca_ibytes (pcursor - p);
+ memcpy (staging, p, pcursor - p);
+ replace_string_range (result, start1,
+ make_int (starting1),
+ staging, staging + (pcursor - p));
+ }
+ }
+ else
+ {
+ Elemcount seq_len = XINT (Flength (sequence2)), ii = 0,
+ subseq_len = min (min (ending1 - starting1, seq_len - starting1),
+ min (ending2 - starting2, seq_len - starting2));
+ Lisp_Object *subsequence = alloca_array (Lisp_Object, subseq_len);
+
+ check_sequence_range (sequence1, start1, end1, make_int (seq_len));
+ check_sequence_range (sequence2, start2, end2, make_int (seq_len));
+
+ while (starting2 < ending2 && ii < seq_len)
+ {
+ subsequence[ii] = Faref (sequence2, make_int (starting2));
+ ii++, starting2++;
+ }
+
+ ii = 0;
+
+ while (starting1 < ending1 && ii < seq_len)
+ {
+ Faset (sequence1, make_int (starting1), subsequence[ii]);
+ ii++, starting1++;
+ }
+ }
+ }
+ else if (sequence1_listp && sequence2_listp)
+ {
+ Lisp_Object sequence1_tortoise = sequence1,
+ sequence2_tortoise = sequence2;
+ Elemcount shortest_len = 0;
+
+ counting = startcounting = min (ending1, ending2);
+
+ while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2))
+ {
+ XSETCAR (sequence1,
+ CONSP (sequence2) ? XCAR (sequence2)
+: Fcar (sequence2));
+ 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);
+ }
+ }
+ }
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (sequence1, start1, end1,
+ make_int (XINT (start1) + shortest_len));
+ }
+ else if (NILP (sequence2))
+ {
+ check_sequence_range (sequence2, start2, end2,
+ make_int (XINT (start2) + shortest_len));
+ }
+ }
+ else if (sequence1_listp)
+ {
+ if (STRINGP (sequence2))
+ {
+ Ibyte *s2_data = XSTRING_DATA (sequence2),
+ *s2_end = s2_data + XSTRING_LENGTH (sequence2);
+ Elemcount char_count = 0;
+ Lisp_Object character;
+
+ while (char_count < starting2 && s2_data < s2_end)
+ {
+ INC_IBYTEPTR (s2_data);
+ char_count++;
+ }
+
+ while (starting1 < ending1 && starting2 < ending2
+ && s2_data < s2_end && !NILP (sequence1))
+ {
+ character = make_char (itext_ichar (s2_data));
+ CONSP (sequence1) ?
+ XSETCAR (sequence1, character)
+: Fsetcar (sequence1, character);
+ sequence1 = XCDR (sequence1);
+ starting1++;
+ starting2++;
+ char_count++;
+ INC_IBYTEPTR (s2_data);
+ }
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (sequence1, start1, end1,
+ make_int (XINT (start1) + starting1));
+ }
+
+ if (s2_data == s2_end)
+ {
+ check_sequence_range (sequence2, start2, end2,
+ make_int (char_count));
+ }
+ }
+ else
+ {
+ Elemcount len2 = XINT (Flength (sequence2));
+ check_sequence_range (sequence2, start2, end2, make_int (len2));
+
+ ending2 = min (ending2, len2);
+ while (starting2 < ending2
+ && starting1 < ending1 && !NILP (sequence1))
+ {
+ CHECK_CONS (sequence1);
+ XSETCAR (sequence1, Faref (sequence2, make_int (starting2)));
+ sequence1 = XCDR (sequence1);
+ starting1++;
+ starting2++;
+ }
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (sequence1, start1, end1,
+ make_int (XINT (start1) + starting1));
+ }
+ }
+ }
+ else if (sequence2_listp)
+ {
+ if (STRINGP (sequence1))
+ {
+ Elemcount ii = 0, count, len = string_char_length (sequence1);
+ Ibyte *staging, *cursor;
+ Lisp_Object obj;
+
+ check_sequence_range (sequence1, start1, end1, make_int (len));
+ ending1 = min (ending1, len);
+ count = ending1 - starting1;
+ staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN);
+
+ while (ii < count && !NILP (sequence2))
+ {
+ obj = CONSP (sequence2) ? XCAR (sequence2)
+: Fcar (sequence2);
+
+ CHECK_CHAR_COERCE_INT (obj);
+ cursor += set_itext_ichar (cursor, XCHAR (obj));
+ ii++;
+ sequence2 = XCDR (sequence2);
+ }
+
+ if (NILP (sequence2))
+ {
+ check_sequence_range (sequence2, start2, end2,
+ make_int (XINT (start2) + ii));
+ }
+
+ replace_string_range (result, start1, make_int (XINT (start1) + ii),
+ staging, cursor);
+ }
+ else
+ {
+ Elemcount len = XINT (Flength (sequence1));
+
+ check_sequence_range (sequence1, start2, end1, make_int (len));
+ ending1 = min (ending2, min (ending1, len));
+
+ while (starting1 < ending1 && !NILP (sequence2))
+ {
+ Faset (sequence1, make_int (starting1),
+ CONSP (sequence2) ? XCAR (sequence2)
+: Fcar (sequence2));
+ sequence2 = XCDR (sequence2);
+ starting1++;
+ starting2++;
+ }
+
+ if (NILP (sequence2))
+ {
+ check_sequence_range (sequence2, start2, end2,
+ make_int (XINT (start2) + starting2));
+ }
+ }
+ }
+ else
+ {
+ if (STRINGP (sequence1) && STRINGP (sequence2))
+ {
+ Ibyte *p2 = XSTRING_DATA (sequence2),
+ *p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor;
+ Charcount ii = 0, len1 = string_char_length (sequence1);
+
+ while (ii < starting2 && p2 < p2end)
+ {
+ INC_IBYTEPTR (p2);
+ ii++;
+ }
+
+ p2cursor = p2;
+ ending1 = min (ending1, len1);
+
+ while (ii < ending2 && starting1 < ending1 && p2cursor < p2end)
+ {
+ INC_IBYTEPTR (p2cursor);
+ ii++;
+ starting1++;
+ }
+
+ if (p2cursor == p2end)
+ {
+ check_sequence_range (sequence2, start2, end2, make_int (ii));
+ }
+
+ /* This isn't great; any error message won't necessarily reflect
+ the END1 that was supplied to #'replace. */
+ replace_string_range (result, start1, make_int (starting1),
+ p2, p2cursor);
+ }
+ else if (STRINGP (sequence1))
+ {
+ Ibyte *staging, *cursor;
+ Elemcount count, len1 = string_char_length (sequence1);
+ Elemcount len2 = XINT (Flength (sequence2)), ii = 0;;
+ Lisp_Object obj;
+
+ check_sequence_range (sequence1, start1, end1, make_int (len1));
+ check_sequence_range (sequence2, start2, end2, make_int (len2));
+
+ ending1 = min (ending1, len1);
+ ending2 = min (ending2, len2);
+ count = min (ending1 - starting1, ending2 - starting2);
+ staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN);
+
+ ii = 0;
+ while (ii < count)
+ {
+ obj = Faref (sequence2, make_int (starting2));
+
+ CHECK_CHAR_COERCE_INT (obj);
+ cursor += set_itext_ichar (cursor, XCHAR (obj));
+ starting2++, ii++;
+ }
+
+ replace_string_range (result, start1,
+ make_int (XINT (start1) + count),
+ staging, cursor);
+ }
+ else if (STRINGP (sequence2))
+ {
+ Ibyte *p2 = XSTRING_DATA (sequence2),
+ *p2end = p2 + XSTRING_LENGTH (sequence2);
+ Elemcount len1 = XINT (Flength (sequence1)), ii = 0;
+
+ check_sequence_range (sequence1, start1, end1, make_int (len1));
+ ending1 = min (ending1, len1);
+
+ while (ii < starting2 && p2 < p2end)
+ {
+ INC_IBYTEPTR (p2);
+ ii++;
+ }
+
+ while (p2 < p2end && starting1 < ending1 && starting2 < ending2)
+ {
+ Faset (sequence1, make_int (starting1),
+ make_char (itext_ichar (p2)));
+ INC_IBYTEPTR (p2);
+ starting1++;
+ starting2++;
+ ii++;
+ }
+
+ if (p2 == p2end)
+ {
+ check_sequence_range (sequence2, start2, end2, make_int (ii));
+ }
+ }
+ else
+ {
+ Elemcount len1 = XINT (Flength (sequence1)),
+ len2 = XINT (Flength (sequence2));
+
+ check_sequence_range (sequence1, start1, end1, make_int (len1));
+ check_sequence_range (sequence2, start2, end2, make_int (len2));
+
+ ending1 = min (ending1, len1);
+ ending2 = min (ending2, len2);
+
+ while (starting1 < ending1 && starting2 < ending2)
+ {
+ Faset (sequence1, make_int (starting1),
+ Faref (sequence2, make_int (starting2)));
+ starting1++;
+ starting2++;
+ }
+ }
+ }
+
+ return result;
+}
Lisp_Object
add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string)
＠＠ -5947,6 +6585,7 ＠＠
DEFSYMBOL (Qbit_vector);
defsymbol (&QsortX, "sort*");
DEFSYMBOL (Qreduce);
+ DEFSYMBOL (Qreplace);
DEFSYMBOL (Qmapconcat);
defsymbol (&QmapcarX, "mapcar*");
＠＠ -5963,6 +6602,10 ＠＠
DEFKEYWORD (Q_from_end);
DEFKEYWORD (Q_initial_value);
+ DEFKEYWORD (Q_start1);
+ DEFKEYWORD (Q_start2);
+ DEFKEYWORD (Q_end1);
+ DEFKEYWORD (Q_end2);
DEFSYMBOL (Qyes_or_no_p);
＠＠ -6062,6 +6705,7 ＠＠
DEFSUBR (Freduce);
DEFSUBR (Freplace_list);
+ DEFSUBR (Freplace);
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://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments