[COMMIT] Fix a bug in my last commit, symbol macros that expand to themselves hang.
8 years, 3 months
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1308509233 -3600
# Node ID 2a6a8da4dd7c1ab2c8455e82a4901ca853db1790
# Parent e05d98bf96448771d989af1b71dfc94b0be75b14
Fix a bug in my last commit, symbol macros that expand to themselves hang.
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (cl-defsubst-expand):
It is occasionally the case that the symbol naming the argument
co-incides with the value that it is replacing; in that case,
using the symbol macro is counterproductive and hangs XEmacs (as
does analogous code in SBCL), so don't.
diff -r e05d98bf9644 -r 2a6a8da4dd7c lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jun 19 19:15:52 2011 +0100
+++ b/lisp/ChangeLog Sun Jun 19 19:47:13 2011 +0100
＠＠ -1,3 +1,11 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (cl-defsubst-expand):
+ It is occasionally the case that the symbol naming the argument
+ co-incides with the value that it is replacing; in that case,
+ using the symbol macro is counterproductive and hangs XEmacs (as
+ does analogous code in SBCL), so don't.
+
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* behavior.el (enable-behavior):
diff -r e05d98bf9644 -r 2a6a8da4dd7c lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jun 19 19:15:52 2011 +0100
+++ b/lisp/cl-macs.el Sun Jun 19 19:47:13 2011 +0100
＠＠ -3223,7 +3223,9 ＠＠
(let* ((symbol-macros nil)
(lets (mapcan #'(lambda (argn argv)
(if (or simple (cl-const-expr-p argv))
- (progn (push (list argn argv) symbol-macros)
+ (progn (or (eq argn argv)
+ (push (list argn argv)
+ symbol-macros))
(and unsafe (list (list argn argv))))
(list (list argn argv))))
argns argvs)))
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
[COMMIT] Style and indentation corrections, behavior.el.
8 years, 3 months
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1308507352 -3600
# Node ID e05d98bf96448771d989af1b71dfc94b0be75b14
# Parent 810b775624861e2fe6ea3b238370c6a3b840a4de
Style and indentation corrections, behavior.el.
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* behavior.el (enable-behavior):
* behavior.el (disable-behavior):
Remove a couple of redundant lambdas here, and remove a cond
clause that was never tripped (because nil is a list.)
* behavior.el (behavior-menu-filter):
Correct some indentation here.
diff -r 810b77562486 -r e05d98bf9644 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jun 19 19:03:39 2011 +0100
+++ b/lisp/ChangeLog Sun Jun 19 19:15:52 2011 +0100
＠＠ -1,3 +1,12 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * behavior.el (enable-behavior):
+ * behavior.el (disable-behavior):
+ Remove a couple of redundant lambdas here, and remove a cond
+ clause that was never tripped (because nil is a list.)
+ * behavior.el (behavior-menu-filter):
+ Correct some indentation here.
+
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (defsubst*):
diff -r 810b77562486 -r e05d98bf9644 lisp/behavior.el
--- a/lisp/behavior.el Sun Jun 19 19:03:39 2011 +0100
+++ b/lisp/behavior.el Sun Jun 19 19:15:52 2011 +0100
＠＠ -372,10 +372,9 ＠＠
(let ((require (getf plist :require))
(enable (getf plist :enable)))
(cond ((listp require)
- (mapc #'(lambda (sym) (require sym)) require))
+ (mapc 'require require))
((symbolp require)
(require require))
- ((null require))
(t (error 'invalid-argument "Invalid :require spec" require)))
(message "Enabling behavior %s..." behavior)
(if enable (funcall enable))
＠＠ -395,10 +394,9 ＠＠
(let ((require (getf plist :require))
(disable (getf plist :disable)))
(cond ((listp require)
- (mapc #'(lambda (sym) (require sym)) require))
+ (mapc 'require require))
((symbolp require)
(require require))
- ((null require))
(t (error 'invalid-argument "Invalid :require spec" require)))
(message "Disabling behavior %s..." behavior)
(if disable (funcall disable))
＠＠ -476,9 +474,9 ＠＠
("%_Set Download Site"
("%_Official Releases"
:filter ,#'(lambda (&rest junk)
- (menu-split-long-menu
- (submenu-generate-accelerator-spec
- (package-ui-download-menu)))))
+ (menu-split-long-menu
+ (submenu-generate-accelerator-spec
+ (package-ui-download-menu)))))
("%_Pre-Releases"
:filter ,#'(lambda (&rest junk)
(menu-split-long-menu
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
commit: Style and indentation corrections, behavior.el.
8 years, 3 months
Aidan Kehoe
changeset: 5524:e05d98bf9644
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jun 19 19:15:52 2011 +0100
files: lisp/ChangeLog lisp/behavior.el
description:
Style and indentation corrections, behavior.el.
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* behavior.el (enable-behavior):
* behavior.el (disable-behavior):
Remove a couple of redundant lambdas here, and remove a cond
clause that was never tripped (because nil is a list.)
* behavior.el (behavior-menu-filter):
Correct some indentation here.
diff -r 810b77562486 -r e05d98bf9644 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jun 19 19:03:39 2011 +0100
+++ b/lisp/ChangeLog Sun Jun 19 19:15:52 2011 +0100
＠＠ -1,3 +1,12 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * behavior.el (enable-behavior):
+ * behavior.el (disable-behavior):
+ Remove a couple of redundant lambdas here, and remove a cond
+ clause that was never tripped (because nil is a list.)
+ * behavior.el (behavior-menu-filter):
+ Correct some indentation here.
+
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (defsubst*):
diff -r 810b77562486 -r e05d98bf9644 lisp/behavior.el
--- a/lisp/behavior.el Sun Jun 19 19:03:39 2011 +0100
+++ b/lisp/behavior.el Sun Jun 19 19:15:52 2011 +0100
＠＠ -372,10 +372,9 ＠＠
(let ((require (getf plist :require))
(enable (getf plist :enable)))
(cond ((listp require)
- (mapc #'(lambda (sym) (require sym)) require))
+ (mapc 'require require))
((symbolp require)
(require require))
- ((null require))
(t (error 'invalid-argument "Invalid :require spec" require)))
(message "Enabling behavior %s..." behavior)
(if enable (funcall enable))
＠＠ -395,10 +394,9 ＠＠
(let ((require (getf plist :require))
(disable (getf plist :disable)))
(cond ((listp require)
- (mapc #'(lambda (sym) (require sym)) require))
+ (mapc 'require require))
((symbolp require)
(require require))
- ((null require))
(t (error 'invalid-argument "Invalid :require spec" require)))
(message "Disabling behavior %s..." behavior)
(if disable (funcall disable))
＠＠ -476,9 +474,9 ＠＠
("%_Set Download Site"
("%_Official Releases"
:filter ,#'(lambda (&rest junk)
- (menu-split-long-menu
- (submenu-generate-accelerator-spec
- (package-ui-download-menu)))))
+ (menu-split-long-menu
+ (submenu-generate-accelerator-spec
+ (package-ui-download-menu)))))
("%_Pre-Releases"
:filter ,#'(lambda (&rest junk)
(menu-split-long-menu
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
[COMMIT] Improve #'defsubst* a little, document a bug that remains.
8 years, 3 months
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1308506619 -3600
# Node ID 810b775624861e2fe6ea3b238370c6a3b840a4de
# Parent 544e6336d37cbafad876c7a838a072bf1af6dce4
Improve #'defsubst* a little, document a bug that remains.
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (defsubst*):
* cl-macs.el (cl-defsubst-expand):
If defaults refer to earlier args, or if there's a &rest arg, use
#'proclaim-inline.
Use #'symbol-macrolet instead of #'subst when replacing argument
names with their values in the inline expansion; this avoids
(most) instances where the symbol's function slot is used.
Document a bug that occurs if the symbol is being shadowed in a
lexically-contained scope.
diff -r 544e6336d37c -r 810b77562486 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jun 19 17:43:03 2011 +0100
+++ b/lisp/ChangeLog Sun Jun 19 19:03:39 2011 +0100
＠＠ -1,3 +1,15 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (defsubst*):
+ * cl-macs.el (cl-defsubst-expand):
+ If defaults refer to earlier args, or if there's a &rest arg, use
+ #'proclaim-inline.
+ Use #'symbol-macrolet instead of #'subst when replacing argument
+ names with their values in the inline expansion; this avoids
+ (most) instances where the symbol's function slot is used.
+ Document a bug that occurs if the symbol is being shadowed in a
+ lexically-contained scope.
+
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el:
diff -r 544e6336d37c -r 810b77562486 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jun 19 17:43:03 2011 +0100
+++ b/lisp/cl-macs.el Sun Jun 19 19:03:39 2011 +0100
＠＠ -3201,7 +3201,10 ＠＠
(unsafe (not (cl-safe-expr-p pbody))))
(while (and p (eq (cl-expr-contains arglist (car p)) 1)) (pop p))
(list 'progn
- (if p nil ; give up if defaults refer to earlier args
+ (if (or p (memq '&rest arglist))
+ ; Defaults refer to earlier args, or we would have to cons up
+ ; something for &rest:
+ (list 'proclaim-inline name)
(list 'define-compiler-macro name
(if (memq '&key arglist)
(list* '&whole 'cl-whole '&cl-quote arglist)
＠＠ -3213,15 +3216,27 ＠＠
(list* 'defun* name arglist docstring body))))
(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
- (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
- (if (cl-simple-exprs-p argvs) (setq simple t))
- (let ((lets (mapcan #'(lambda (argn argv)
- (if (or simple (cl-const-expr-p argv))
- (progn (setq body (subst argv argn body))
- (and unsafe (list (list argn argv))))
- (list (list argn argv))))
- argns argvs)))
- (if lets (list 'let lets body) body))))
+ (if (and whole (not (cl-safe-expr-p (cons 'progn argvs))))
+ whole
+ (if (cl-simple-exprs-p argvs)
+ (setq simple t))
+ (let* ((symbol-macros nil)
+ (lets (mapcan #'(lambda (argn argv)
+ (if (or simple (cl-const-expr-p argv))
+ (progn (push (list argn argv) symbol-macros)
+ (and unsafe (list (list argn argv))))
+ (list (list argn argv))))
+ argns argvs)))
+ `(let ,lets
+ (symbol-macrolet
+ ;; #### Bug; this will happily substitute in places where the
+ ;; symbol is being shadowed in a different scope (e.g. inside
+ ;; let bindings or lambda expressions where it has been
+ ;; bound). We don't have GNU's issue where the replacement will
+ ;; be done when the symbol is used in a function context,
+ ;; because we're using #'symbol-macrolet instead of #'subst.
+ ,symbol-macros
+ ,body)))))
;; When a 64-bit build is byte-compiling code, some of its native fixnums
;; will not be represented as fixnums if the byte-compiled code is read by
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
commit: Improve #'defsubst* a little, document a bug that remains.
8 years, 3 months
Aidan Kehoe
changeset: 5523:810b77562486
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jun 19 19:03:39 2011 +0100
files: lisp/ChangeLog lisp/cl-macs.el
description:
Improve #'defsubst* a little, document a bug that remains.
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (defsubst*):
* cl-macs.el (cl-defsubst-expand):
If defaults refer to earlier args, or if there's a &rest arg, use
#'proclaim-inline.
Use #'symbol-macrolet instead of #'subst when replacing argument
names with their values in the inline expansion; this avoids
(most) instances where the symbol's function slot is used.
Document a bug that occurs if the symbol is being shadowed in a
lexically-contained scope.
diff -r 544e6336d37c -r 810b77562486 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jun 19 17:43:03 2011 +0100
+++ b/lisp/ChangeLog Sun Jun 19 19:03:39 2011 +0100
＠＠ -1,3 +1,15 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (defsubst*):
+ * cl-macs.el (cl-defsubst-expand):
+ If defaults refer to earlier args, or if there's a &rest arg, use
+ #'proclaim-inline.
+ Use #'symbol-macrolet instead of #'subst when replacing argument
+ names with their values in the inline expansion; this avoids
+ (most) instances where the symbol's function slot is used.
+ Document a bug that occurs if the symbol is being shadowed in a
+ lexically-contained scope.
+
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el:
diff -r 544e6336d37c -r 810b77562486 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jun 19 17:43:03 2011 +0100
+++ b/lisp/cl-macs.el Sun Jun 19 19:03:39 2011 +0100
＠＠ -3201,7 +3201,10 ＠＠
(unsafe (not (cl-safe-expr-p pbody))))
(while (and p (eq (cl-expr-contains arglist (car p)) 1)) (pop p))
(list 'progn
- (if p nil ; give up if defaults refer to earlier args
+ (if (or p (memq '&rest arglist))
+ ; Defaults refer to earlier args, or we would have to cons up
+ ; something for &rest:
+ (list 'proclaim-inline name)
(list 'define-compiler-macro name
(if (memq '&key arglist)
(list* '&whole 'cl-whole '&cl-quote arglist)
＠＠ -3213,15 +3216,27 ＠＠
(list* 'defun* name arglist docstring body))))
(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
- (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
- (if (cl-simple-exprs-p argvs) (setq simple t))
- (let ((lets (mapcan #'(lambda (argn argv)
- (if (or simple (cl-const-expr-p argv))
- (progn (setq body (subst argv argn body))
- (and unsafe (list (list argn argv))))
- (list (list argn argv))))
- argns argvs)))
- (if lets (list 'let lets body) body))))
+ (if (and whole (not (cl-safe-expr-p (cons 'progn argvs))))
+ whole
+ (if (cl-simple-exprs-p argvs)
+ (setq simple t))
+ (let* ((symbol-macros nil)
+ (lets (mapcan #'(lambda (argn argv)
+ (if (or simple (cl-const-expr-p argv))
+ (progn (push (list argn argv) symbol-macros)
+ (and unsafe (list (list argn argv))))
+ (list (list argn argv))))
+ argns argvs)))
+ `(let ,lets
+ (symbol-macrolet
+ ;; #### Bug; this will happily substitute in places where the
+ ;; symbol is being shadowed in a different scope (e.g. inside
+ ;; let bindings or lambda expressions where it has been
+ ;; bound). We don't have GNU's issue where the replacement will
+ ;; be done when the symbol is used in a function context,
+ ;; because we're using #'symbol-macrolet instead of #'subst.
+ ,symbol-macros
+ ,body)))))
;; When a 64-bit build is byte-compiling code, some of its native fixnums
;; will not be represented as fixnums if the byte-compiled code is read by
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
[COMMIT] Reimplement a few GNU functions in terms of CL functions, subr.el
8 years, 3 months
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1308501783 -3600
# Node ID 544e6336d37cbafad876c7a838a072bf1af6dce4
# Parent 3310f36295a0cc633e512469005151f8b311aa48
Reimplement a few GNU functions in terms of CL functions, subr.el
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el:
* cl-macs.el (assoc-ignore-case, assoc-ignore-representation):
* cl-macs.el (member-ignore-case): New compiler macros.
* subr.el (assoc-ignore-case):
* subr.el (assoc-ignore-representation):
* subr.el (member-ignore-case):
* subr.el (split-path):
* subr.el (delete-dups):
Reimplement a few GNU functions in terms of their CL counterparts,
for the sake of circularity checking and some speed; add type
checking (used in interpreted code and with low speed and safety
checking) for the sake of revealing incompatibilities when
developing.
* subr.el (remove-hook):
There's no need for flet here, an explicit lambda is enough.
diff -r 3310f36295a0 -r 544e6336d37c lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jun 19 16:53:03 2011 +0100
+++ b/lisp/ChangeLog Sun Jun 19 17:43:03 2011 +0100
＠＠ -1,3 +1,21 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el:
+ * cl-macs.el (assoc-ignore-case, assoc-ignore-representation):
+ * cl-macs.el (member-ignore-case): New compiler macros.
+ * subr.el (assoc-ignore-case):
+ * subr.el (assoc-ignore-representation):
+ * subr.el (member-ignore-case):
+ * subr.el (split-path):
+ * subr.el (delete-dups):
+ Reimplement a few GNU functions in terms of their CL counterparts,
+ for the sake of circularity checking and some speed; add type
+ checking (used in interpreted code and with low speed and safety
+ checking) for the sake of revealing incompatibilities when
+ developing.
+ * subr.el (remove-hook):
+ There's no need for flet here, an explicit lambda is enough.
+
2011-06-04 Aidan Kehoe <kehoea(a)parhasard.net>
* gutter-items.el (add-tab-to-gutter):
diff -r 3310f36295a0 -r 544e6336d37c lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jun 19 16:53:03 2011 +0100
+++ b/lisp/cl-macs.el Sun Jun 19 17:43:03 2011 +0100
＠＠ -3766,6 +3766,35 ＠＠
(the string ,string) :test #'eq)
form))
+(define-compiler-macro assoc-ignore-case (&whole form &rest args)
+ (if (eql 2 (length args))
+ `(assoc* (the string ,(pop args))
+ (the (and list (satisfies
+ (lambda (list)
+ (not (find-if-not 'stringp list :key 'car)))))
+ ,(pop args))
+:test 'equalp)
+ form))
+
+(define-compiler-macro assoc-ignore-representation (&whole form &rest args)
+ (if (eql 2 (length args))
+ `(assoc* (the string ,(pop args))
+ (the (and list (satisfies
+ (lambda (list)
+ (not (find-if-not 'stringp list :key 'car)))))
+ ,(pop args))
+:test 'equalp)
+ form))
+
+(define-compiler-macro member-ignore-case (&whole form &rest args)
+ (if (eql 2 (length args))
+ `(member* (the string ,(pop args))
+ (the (and list (satisfies
+ (lambda (list) (every 'stringp list))))
+ ,(pop args))
+:test 'equalp)
+ form))
+
(define-compiler-macro stable-union (&whole form &rest cl-keys)
(if (> (length form) 2)
(list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys)
diff -r 3310f36295a0 -r 544e6336d37c lisp/subr.el
--- a/lisp/subr.el Sun Jun 19 16:53:03 2011 +0100
+++ b/lisp/subr.el Sun Jun 19 17:43:03 2011 +0100
＠＠ -111,10 +111,6 ＠＠
;(defun butlast (x &optional n)
;(defun nbutlast (x &optional n)
-;; In cl-seq.el.
-;(defun remove (elt seq)
-;(defun remq (elt list)
-
(defmacro defun-when-void (&rest args)
"Define a function, just like `defun', unless it's already defined.
Used for compatibility among different emacs variants."
＠＠ -185,30 +181,28 ＠＠
(defun assoc-ignore-case (key alist)
"Like `assoc', but ignores differences in case and text representation.
KEY must be a string. Upper-case and lower-case letters are treated as equal."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
+ (assoc* (the string key)
+ (the (and list (satisfies (lambda (list)
+ (not (find-if-not 'stringp list
+:key 'car))))) alist)
+:test 'equalp))
(defun assoc-ignore-representation (key alist)
"Like `assoc', but ignores differences in text representation.
KEY must be a string."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
+ (assoc* (the string key)
+ (the (and list (satisfies (lambda (list)
+ (not (find-if-not 'stringp list
+:key 'car))))) alist)
+:test 'equalp))
(defun member-ignore-case (elt list)
"Like `member', but ignores differences in case and text representation.
ELT must be a string. Upper-case and lower-case letters are treated as equal."
- (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
- (setq list (cdr list)))
- list)
-
+ (member* (the string elt)
+ (the (and list (satisfies (lambda (list) (every 'stringp list))))
+ list)
+:test 'equalp))
;;;; Keymap support.
;; XEmacs: removed to keymap.el
＠＠ -351,23 +345,17 ＠＠
(setq local t)))
(let ((hook-value (if local (symbol-value hook) (default-value hook))))
;; Remove the function, for both the list and the non-list cases.
- ;; XEmacs: add hook-test, for handling one-shot hooks.
- (flet ((hook-test
- (fn hel)
- (or (equal fn hel)
- (and (symbolp hel)
- (equal fn
- (get hel 'one-shot-hook-fun))))))
- (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
- (if (equal hook-value function) (setq hook-value nil))
- (setq hook-value (delete* function (copy-sequence hook-value)
- :test 'hook-test)))
- ;; If the function is on the global hook, we need to shadow it locally
- ;;(when (and local (member* function (default-value hook)
- ;; :test 'hook-test)
- ;; (not (member* (cons 'not function) hook-value
- ;; :test 'hook-test)))
- ;; (push (cons 'not function) hook-value))
+ ;; XEmacs: call #'remove-if, rather than delete, since we check for
+ ;; one-shot hooks too.
+ (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
+ (if (equal hook-value function) (setq hook-value nil))
+ (setq hook-value
+ (remove-if #'(lambda (elt)
+ (or (equal function elt)
+ (and (symbolp elt)
+ (equal function
+ (get elt 'one-shot-hook-fun)))))
+ hook-value))
;; Set the actual variable
(if local (set hook hook-value) (set-default hook hook-value)))))
＠＠ -493,8 +481,7 ＠＠
"Explode a search path into a list of strings.
The path components are separated with the characters specified
with `path-separator'."
- (while (or (not (stringp path-separator))
- (/= (length path-separator) 1))
+ (while (not (and (stringp path-separator) (eql (length path-separator) 1)))
(setq path-separator (signal 'error (list "\
`path-separator' should be set to a single-character string"
path-separator))))
＠＠ -1722,11 +1709,7 ＠＠
Store the result in LIST and return it. LIST must be a proper list.
Of several `equal' occurrences of an element in LIST, the first
one is kept."
- (let ((tail list))
- (while tail
- (setcdr tail (delete (car tail) (cdr tail)))
- (setq tail (cdr tail))))
- list)
+ (delete-duplicates (the list list) :test 'equal :from-end t))
;; END SYNC WITH FSF 22.0.50.1 (CVS)
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
commit: Reimplement a few GNU functions in terms of CL functions, subr.el
8 years, 3 months
Aidan Kehoe
changeset: 5522:544e6336d37c
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jun 19 17:43:03 2011 +0100
files: lisp/ChangeLog lisp/cl-macs.el lisp/subr.el
description:
Reimplement a few GNU functions in terms of CL functions, subr.el
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el:
* cl-macs.el (assoc-ignore-case, assoc-ignore-representation):
* cl-macs.el (member-ignore-case): New compiler macros.
* subr.el (assoc-ignore-case):
* subr.el (assoc-ignore-representation):
* subr.el (member-ignore-case):
* subr.el (split-path):
* subr.el (delete-dups):
Reimplement a few GNU functions in terms of their CL counterparts,
for the sake of circularity checking and some speed; add type
checking (used in interpreted code and with low speed and safety
checking) for the sake of revealing incompatibilities when
developing.
* subr.el (remove-hook):
There's no need for flet here, an explicit lambda is enough.
diff -r 3310f36295a0 -r 544e6336d37c lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jun 19 16:53:03 2011 +0100
+++ b/lisp/ChangeLog Sun Jun 19 17:43:03 2011 +0100
＠＠ -1,3 +1,21 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el:
+ * cl-macs.el (assoc-ignore-case, assoc-ignore-representation):
+ * cl-macs.el (member-ignore-case): New compiler macros.
+ * subr.el (assoc-ignore-case):
+ * subr.el (assoc-ignore-representation):
+ * subr.el (member-ignore-case):
+ * subr.el (split-path):
+ * subr.el (delete-dups):
+ Reimplement a few GNU functions in terms of their CL counterparts,
+ for the sake of circularity checking and some speed; add type
+ checking (used in interpreted code and with low speed and safety
+ checking) for the sake of revealing incompatibilities when
+ developing.
+ * subr.el (remove-hook):
+ There's no need for flet here, an explicit lambda is enough.
+
2011-06-04 Aidan Kehoe <kehoea(a)parhasard.net>
* gutter-items.el (add-tab-to-gutter):
diff -r 3310f36295a0 -r 544e6336d37c lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jun 19 16:53:03 2011 +0100
+++ b/lisp/cl-macs.el Sun Jun 19 17:43:03 2011 +0100
＠＠ -3766,6 +3766,35 ＠＠
(the string ,string) :test #'eq)
form))
+(define-compiler-macro assoc-ignore-case (&whole form &rest args)
+ (if (eql 2 (length args))
+ `(assoc* (the string ,(pop args))
+ (the (and list (satisfies
+ (lambda (list)
+ (not (find-if-not 'stringp list :key 'car)))))
+ ,(pop args))
+:test 'equalp)
+ form))
+
+(define-compiler-macro assoc-ignore-representation (&whole form &rest args)
+ (if (eql 2 (length args))
+ `(assoc* (the string ,(pop args))
+ (the (and list (satisfies
+ (lambda (list)
+ (not (find-if-not 'stringp list :key 'car)))))
+ ,(pop args))
+:test 'equalp)
+ form))
+
+(define-compiler-macro member-ignore-case (&whole form &rest args)
+ (if (eql 2 (length args))
+ `(member* (the string ,(pop args))
+ (the (and list (satisfies
+ (lambda (list) (every 'stringp list))))
+ ,(pop args))
+:test 'equalp)
+ form))
+
(define-compiler-macro stable-union (&whole form &rest cl-keys)
(if (> (length form) 2)
(list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys)
diff -r 3310f36295a0 -r 544e6336d37c lisp/subr.el
--- a/lisp/subr.el Sun Jun 19 16:53:03 2011 +0100
+++ b/lisp/subr.el Sun Jun 19 17:43:03 2011 +0100
＠＠ -111,10 +111,6 ＠＠
;(defun butlast (x &optional n)
;(defun nbutlast (x &optional n)
-;; In cl-seq.el.
-;(defun remove (elt seq)
-;(defun remq (elt list)
-
(defmacro defun-when-void (&rest args)
"Define a function, just like `defun', unless it's already defined.
Used for compatibility among different emacs variants."
＠＠ -185,30 +181,28 ＠＠
(defun assoc-ignore-case (key alist)
"Like `assoc', but ignores differences in case and text representation.
KEY must be a string. Upper-case and lower-case letters are treated as equal."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
+ (assoc* (the string key)
+ (the (and list (satisfies (lambda (list)
+ (not (find-if-not 'stringp list
+:key 'car))))) alist)
+:test 'equalp))
(defun assoc-ignore-representation (key alist)
"Like `assoc', but ignores differences in text representation.
KEY must be a string."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
+ (assoc* (the string key)
+ (the (and list (satisfies (lambda (list)
+ (not (find-if-not 'stringp list
+:key 'car))))) alist)
+:test 'equalp))
(defun member-ignore-case (elt list)
"Like `member', but ignores differences in case and text representation.
ELT must be a string. Upper-case and lower-case letters are treated as equal."
- (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
- (setq list (cdr list)))
- list)
-
+ (member* (the string elt)
+ (the (and list (satisfies (lambda (list) (every 'stringp list))))
+ list)
+:test 'equalp))
;;;; Keymap support.
;; XEmacs: removed to keymap.el
＠＠ -351,23 +345,17 ＠＠
(setq local t)))
(let ((hook-value (if local (symbol-value hook) (default-value hook))))
;; Remove the function, for both the list and the non-list cases.
- ;; XEmacs: add hook-test, for handling one-shot hooks.
- (flet ((hook-test
- (fn hel)
- (or (equal fn hel)
- (and (symbolp hel)
- (equal fn
- (get hel 'one-shot-hook-fun))))))
- (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
- (if (equal hook-value function) (setq hook-value nil))
- (setq hook-value (delete* function (copy-sequence hook-value)
- :test 'hook-test)))
- ;; If the function is on the global hook, we need to shadow it locally
- ;;(when (and local (member* function (default-value hook)
- ;; :test 'hook-test)
- ;; (not (member* (cons 'not function) hook-value
- ;; :test 'hook-test)))
- ;; (push (cons 'not function) hook-value))
+ ;; XEmacs: call #'remove-if, rather than delete, since we check for
+ ;; one-shot hooks too.
+ (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
+ (if (equal hook-value function) (setq hook-value nil))
+ (setq hook-value
+ (remove-if #'(lambda (elt)
+ (or (equal function elt)
+ (and (symbolp elt)
+ (equal function
+ (get elt 'one-shot-hook-fun)))))
+ hook-value))
;; Set the actual variable
(if local (set hook hook-value) (set-default hook hook-value)))))
＠＠ -493,8 +481,7 ＠＠
"Explode a search path into a list of strings.
The path components are separated with the characters specified
with `path-separator'."
- (while (or (not (stringp path-separator))
- (/= (length path-separator) 1))
+ (while (not (and (stringp path-separator) (eql (length path-separator) 1)))
(setq path-separator (signal 'error (list "\
`path-separator' should be set to a single-character string"
path-separator))))
＠＠ -1722,11 +1709,7 ＠＠
Store the result in LIST and return it. LIST must be a proper list.
Of several `equal' occurrences of an element in LIST, the first
one is kept."
- (let ((tail list))
- (while tail
- (setcdr tail (delete (car tail) (cdr tail)))
- (setq tail (cdr tail))))
- list)
+ (delete-duplicates (the list list) :test 'equal :from-end t))
;; END SYNC WITH FSF 22.0.50.1 (CVS)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
[COMMIT] Correct a couple of comments, remove a superfluous gcpro1, fns.c
8 years, 3 months
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1308498783 -3600
# Node ID 3310f36295a0cc633e512469005151f8b311aa48
# Parent 05c1ad4f7a7b04ab226b7960ec603550097e3f22
Correct a couple of comments, remove a superfluous gcpro1, fns.c
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c:
* fns.c (list_delete_duplicates_from_end):
Correct a couple of comments in this file.
* fns.c (sublis):
Remove a superfluous gcpro1.
diff -r 05c1ad4f7a7b -r 3310f36295a0 src/ChangeLog
--- a/src/ChangeLog Sun Jun 19 16:37:17 2011 +0100
+++ b/src/ChangeLog Sun Jun 19 16:53:03 2011 +0100
＠＠ -1,3 +1,11 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c:
+ * fns.c (list_delete_duplicates_from_end):
+ Correct a couple of comments in this file.
+ * fns.c (sublis):
+ Remove a superfluous gcpro1.
+
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* elhash.c (Feq_hash):
diff -r 05c1ad4f7a7b -r 3310f36295a0 src/fns.c
--- a/src/fns.c Sun Jun 19 16:37:17 2011 +0100
+++ b/src/fns.c Sun Jun 19 16:53:03 2011 +0100
＠＠ -718,7 +718,7 ＠＠
}
/* Given PREDICATE and KEY, return a C function pointer appropriate for use
- in deciding whether one given elements of a sequence is less than
+ in deciding whether one given element of a sequence is less than
another. */
static check_test_func_t
＠＠ -2058,8 +2058,8 ＠＠
return val;
}
-/* Split STRING into a list of substrings. The substrings are the
- parts of original STRING separated by SEPCHAR.
+/* Split STRING into a list of substrings. The substrings are the parts of
+ original STRING separated by SEPCHAR.
If UNESCAPE is non-zero, ESCAPECHAR specifies a character that will quote
SEPCHAR, and cause it not to split STRING. A double ESCAPECHAR is
＠＠ -3755,10 +3755,8 ＠＠
/* We can't delete (or remove) as we go, because that breaks START and
END. We could if END were nil, and that would change an ON(N + 2)
- algorithm to an ON^2 algorithm; list_position_cons_before() would need to
- be modified to return the cons *before* the one containing the item for
- that. Here and now it doesn't matter, though, #'delete-duplicates is
- relatively expensive no matter what. */
+ algorithm to an ON^2 algorithm. Here and now it doesn't matter, though,
+ #'delete-duplicates is relatively expensive no matter what. */
struct Lisp_Bit_Vector *deleting
= (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ (sizeof (long)
＠＠ -9060,7 +9058,6 ＠＠
Lisp_Object test, Lisp_Object key, int depth)
{
Lisp_Object keyed = KEY (key, tree), aa, dd;
- struct gcpro gcpro1;
if (depth + lisp_eval_depth > max_lisp_eval_depth)
{
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
commit: Correct a couple of comments, remove a superfluous gcpro1, fns.c
8 years, 3 months
Aidan Kehoe
changeset: 5521:3310f36295a0
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jun 19 16:53:03 2011 +0100
files: src/ChangeLog src/fns.c
description:
Correct a couple of comments, remove a superfluous gcpro1, fns.c
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c:
* fns.c (list_delete_duplicates_from_end):
Correct a couple of comments in this file.
* fns.c (sublis):
Remove a superfluous gcpro1.
diff -r 05c1ad4f7a7b -r 3310f36295a0 src/ChangeLog
--- a/src/ChangeLog Sun Jun 19 16:37:17 2011 +0100
+++ b/src/ChangeLog Sun Jun 19 16:53:03 2011 +0100
＠＠ -1,3 +1,11 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c:
+ * fns.c (list_delete_duplicates_from_end):
+ Correct a couple of comments in this file.
+ * fns.c (sublis):
+ Remove a superfluous gcpro1.
+
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* elhash.c (Feq_hash):
diff -r 05c1ad4f7a7b -r 3310f36295a0 src/fns.c
--- a/src/fns.c Sun Jun 19 16:37:17 2011 +0100
+++ b/src/fns.c Sun Jun 19 16:53:03 2011 +0100
＠＠ -718,7 +718,7 ＠＠
}
/* Given PREDICATE and KEY, return a C function pointer appropriate for use
- in deciding whether one given elements of a sequence is less than
+ in deciding whether one given element of a sequence is less than
another. */
static check_test_func_t
＠＠ -2058,8 +2058,8 ＠＠
return val;
}
-/* Split STRING into a list of substrings. The substrings are the
- parts of original STRING separated by SEPCHAR.
+/* Split STRING into a list of substrings. The substrings are the parts of
+ original STRING separated by SEPCHAR.
If UNESCAPE is non-zero, ESCAPECHAR specifies a character that will quote
SEPCHAR, and cause it not to split STRING. A double ESCAPECHAR is
＠＠ -3755,10 +3755,8 ＠＠
/* We can't delete (or remove) as we go, because that breaks START and
END. We could if END were nil, and that would change an ON(N + 2)
- algorithm to an ON^2 algorithm; list_position_cons_before() would need to
- be modified to return the cons *before* the one containing the item for
- that. Here and now it doesn't matter, though, #'delete-duplicates is
- relatively expensive no matter what. */
+ algorithm to an ON^2 algorithm. Here and now it doesn't matter, though,
+ #'delete-duplicates is relatively expensive no matter what. */
struct Lisp_Bit_Vector *deleting
= (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ (sizeof (long)
＠＠ -9060,7 +9058,6 ＠＠
Lisp_Object test, Lisp_Object key, int depth)
{
Lisp_Object keyed = KEY (key, tree), aa, dd;
- struct gcpro gcpro1;
if (depth + lisp_eval_depth > max_lisp_eval_depth)
{
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
[COMMIT] Expand the documentation of #'eq-hash, mention the CL PRINT-OBJECT protocol
8 years, 3 months
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1308497837 -3600
# Node ID 05c1ad4f7a7b04ab226b7960ec603550097e3f22
# Parent bcd74c477a387f6a7ea62cf0244af98635c473ac
Expand the documentation of #'eq-hash, mention the CL PRINT-OBJECT protocol
2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
* elhash.c (Feq_hash):
Document that this returns, for non-immediate objects, a value
that is unique among currently-reachable objects.
diff -r bcd74c477a38 -r 05c1ad4f7a7b src/ChangeLog
--- a/src/ChangeLog Sat Jun 04 14:17:59 2011 +0100
+++ b/src/ChangeLog Sun Jun 19 16:37:17 2011 +0100
＠＠ -1,3 +1,9 ＠＠
+2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * elhash.c (Feq_hash):
+ Document that this returns, for non-immediate objects, a value
+ that is unique among currently-reachable objects.
+
2011-05-29 Didier Verna <didier(a)xemacs.org>
* console-impl.h (struct console_methods): Remove device parameter
diff -r bcd74c477a38 -r 05c1ad4f7a7b src/elhash.c
--- a/src/elhash.c Sat Jun 04 14:17:59 2011 +0100
+++ b/src/elhash.c Sun Jun 19 16:37:17 2011 +0100
＠＠ -2008,6 +2008,10 ＠＠
DEFUN ("eq-hash", Feq_hash, 1, 1, 0, /*
Return a hash value for OBJECT appropriate for use with `eq.'
+
+If OBJECT is not immediate (it is not a fixnum or character) this hash value
+will be unique among currently-reachable objects, and is appropriate for
+implementing the Common Lisp PRINT-OBJECT protocol.
*/
(object))
{
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches