carbon2-commit: Use defmacro* when defining dolist, dotimes, do-symbols, macrolet, cl-macs.el
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5384:60ba780f9078
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jan 02 00:06:14 2011 +0000
files: lisp/ChangeLog lisp/cl-macs.el
description:
Use defmacro* when defining dolist, dotimes, do-symbols, macrolet, cl-macs.el
2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
diff -r 47298dcf2e8f -r 60ba780f9078 lisp/ChangeLog
--- a/lisp/ChangeLog Sat Jan 01 20:08:44 2011 +0000
+++ b/lisp/ChangeLog Sun Jan 02 00:06:14 2011 +0000
＠＠ -1,3 +1,12 ＠＠
+2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (dolist, dotimes, do-symbols, macrolet)
+ (symbol-macrolet):
+ Define these macros with defmacro* instead of parsing the argument
+ list by hand, for the sake of style and readability; use backquote
+ where appropriate, instead of calling #'list and and friends, for
+ the same reason.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* x-misc.el (device-x-display):
diff -r 47298dcf2e8f -r 60ba780f9078 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sat Jan 01 20:08:44 2011 +0000
+++ b/lisp/cl-macs.el Sun Jan 02 00:06:14 2011 +0000
＠＠ -1679,51 +1679,42 ＠＠
(or (cdr endtest) '(nil)))))
;;;###autoload
-(defmacro dolist (spec &rest body)
+(defmacro* dolist ((var list &optional result) &body body)
"Loop over a list.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
-Then evaluate RESULT to get return value, default nil.
-
-arguments: ((VAR LIST &optional RESULT) &body BODY)"
- (let ((temp (gensym "--dolist-temp--")))
- (list 'block nil
- (list* 'let (list (list temp (nth 1 spec)) (car spec))
- (list* 'while temp (list 'setq (car spec) (list 'car temp))
- (append body (list (list 'setq temp
- (list 'cdr temp)))))
- (if (cdr (cdr spec))
- (cons (list 'setq (car spec) nil) (cdr (cdr spec)))
- '(nil))))))
+Then evaluate RESULT to get return value, default nil."
+ (let ((gensym (gensym)))
+ `(block nil
+ (let ((,gensym ,list) ,var)
+ (while ,gensym
+ (setq ,var (car ,gensym))
+ ,＠body
+ (setq ,gensym (cdr ,gensym)))
+ ,＠(if result `((setq ,var nil) ,result))))))
;;;###autoload
-(defmacro dotimes (spec &rest body)
+(defmacro* dotimes ((var count &optional result) &body body)
"Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers from 0, inclusive,
to COUNT, exclusive. Then evaluate RESULT to get return value, default
-nil.
-
-arguments: ((VAR COUNT &optional RESULT) &body BODY)"
- (let ((temp (gensym "--dotimes-temp--")))
- (list 'block nil
- (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
- (list* 'while (list '< (car spec) temp)
- (append body (list (list 'incf (car spec)))))
- (or (cdr (cdr spec)) '(nil))))))
+nil."
+ (let* ((limit (if (cl-const-expr-p count) count (gensym)))
+ (bind (if (cl-const-expr-p count) nil `((,limit ,count)))))
+ `(block nil
+ (let ((,var 0) ,＠bind)
+ (while (< ,var ,limit)
+ ,＠body
+ (setq ,var (1+ ,var)))
+ ,＠(if result (list result))))))
;;;###autoload
-(defmacro do-symbols (spec &rest body)
- "Loop over all symbols.
+(defmacro* do-symbols ((var &optional obarray result) &rest body)
+ "Loop over all interned symbols.
Evaluate BODY with VAR bound to each interned symbol, or to each symbol
-from OBARRAY.
-
-arguments: ((VAR &optional OBARRAY RESULT) &body BODY)"
- ;; Apparently this doesn't have an implicit block.
- (list 'block nil
- (list 'let (list (car spec))
- (list* 'mapatoms
- (list 'function (list* 'lambda (list (car spec)) body))
- (and (cadr spec) (list (cadr spec))))
- (caddr spec))))
+from OBARRAY."
+ `(block nil
+ (mapatoms #'(lambda (,var) ,＠body) ,＠(and obarray (list obarray)))
+ ,＠(if result `((let (,var) ,result)))))
;;;###autoload
(defmacro do-all-symbols (spec &rest body)
＠＠ -1806,37 +1797,34 ＠＠
;; The following ought to have a better definition for use with newer
;; byte compilers.
;;;###autoload
-(defmacro macrolet (bindings &rest body)
+(defmacro* macrolet (((name arglist &optional docstring &body body)
+ &rest macros) &body form)
"Make temporary macro definitions.
-This is like `flet', but for macros instead of functions.
-
-arguments: (((NAME ARGLIST &optional DOCSTRING &body body) &rest MACROS) &body FORM)"
- (if (cdr bindings)
- (list 'macrolet
- (list (car bindings)) (list* 'macrolet (cdr bindings) body))
- (if (null bindings) (cons 'progn body)
- (let* ((name (caar bindings))
- (res (cl-transform-lambda (cdar bindings) name)))
- (eval (car res))
- (cl-macroexpand-all (cons 'progn body)
- (cons (list* name 'lambda (cdr res))
- cl-macro-environment))))))
+This is like `flet', but for macros instead of functions."
+ (cl-macroexpand-all (cons 'progn form)
+ (nconc
+ (loop
+ for (name . details)
+ in (cons (list* name arglist docstring body) macros)
+ collect
+ (list* name 'lambda
+ (prog1
+ (cdr (setq details (cl-transform-lambda
+ details name)))
+ (eval (car details)))))
+ cl-macro-environment)))
;;;###autoload
-(defmacro symbol-macrolet (bindings &rest body)
+(defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form)
"Make symbol macro definitions.
Within the body FORMs, references to the variable NAME will be replaced
-by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
-
-arguments: (((NAME EXPANSION) &rest SYMBOL-MACROS) &body FORM)"
- (if (cdr bindings)
- (list 'symbol-macrolet
- (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
- (if (null bindings) (cons 'progn body)
- (cl-macroexpand-all (cons 'progn body)
- (cons (list (symbol-name (caar bindings))
- (cadar bindings))
- cl-macro-environment)))))
+by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)."
+ (cl-macroexpand-all (cons 'progn form)
+ (append (list (list (symbol-name name) expansion))
+ (loop
+ for (name expansion) in symbol-macros
+ collect (list (symbol-name name) expansion))
+ cl-macro-environment)))
(defvar cl-closure-vars nil)
;;;###autoload
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Be more helpful in printing ephemerons, weak lists, and weak boxes.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5383:47298dcf2e8f
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sat Jan 01 20:08:44 2011 +0000
files: src/ChangeLog src/data.c
description:
Be more helpful in printing ephemerons, weak lists, and weak boxes.
2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
* data.c (print_ephemeron, print_weak_list, print_weak_box):
Be more helpful in printing these structures; show their contents,
print their UIDs so it's possible to distinguish between them.
diff -r d0bb90d90736 -r 47298dcf2e8f src/ChangeLog
--- a/src/ChangeLog Thu Dec 30 13:46:50 2010 +0000
+++ b/src/ChangeLog Sat Jan 01 20:08:44 2011 +0000
＠＠ -1,3 +1,9 ＠＠
+2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * data.c (print_ephemeron, print_weak_list, print_weak_box):
+ Be more helpful in printing these structures; show their contents,
+ print their UIDs so it's possible to distinguish between them.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* lisp.h (DECLARE_N_KEYWORDS_8, DECLARE_N_KEYWORDS_9)
diff -r d0bb90d90736 -r 47298dcf2e8f src/data.c
--- a/src/data.c Thu Dec 30 13:46:50 2010 +0000
+++ b/src/data.c Sat Jan 01 20:08:44 2011 +0000
＠＠ -2612,14 +2612,19 ＠＠
static void
print_weak_list (Lisp_Object obj, Lisp_Object printcharfun,
- int UNUSED (escapeflag))
+ int escapeflag)
{
if (print_readably)
- printing_unreadable_lisp_object (obj, 0);
+ {
+ printing_unreadable_lisp_object (obj, 0);
+ }
- write_fmt_string_lisp (printcharfun, "#<weak-list %s %S>", 2,
- encode_weak_list_type (XWEAK_LIST (obj)->type),
- XWEAK_LIST (obj)->list);
+ write_ascstring (printcharfun, "#<weak-list :type ");
+ print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
+ printcharfun, escapeflag);
+ write_ascstring (printcharfun, " :list ");
+ print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
+ write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj));
}
static int
＠＠ -3087,12 +3092,16 ＠＠
}
static void
-print_weak_box (Lisp_Object obj, Lisp_Object printcharfun,
- int UNUSED (escapeflag))
+print_weak_box (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
if (print_readably)
- printing_unreadable_lisp_object (obj, 0);
- write_fmt_string (printcharfun, "#<weak-box>"); /* #### fix */
+ {
+ printing_unreadable_lisp_object (obj, 0);
+ }
+
+ write_ascstring (printcharfun, "#<weak-box ");
+ print_internal (XWEAK_BOX (obj)->value, printcharfun, escapeflag);
+ write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj));
}
static int
＠＠ -3309,12 +3318,20 ＠＠
}
static void
-print_ephemeron (Lisp_Object obj, Lisp_Object printcharfun,
- int UNUSED (escapeflag))
+print_ephemeron (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
if (print_readably)
- printing_unreadable_lisp_object (obj, 0);
- write_fmt_string (printcharfun, "#<ephemeron>"); /* #### fix */
+ {
+ printing_unreadable_lisp_object (obj, 0);
+ }
+
+ write_ascstring (printcharfun, "#<ephemeron :key ");
+ print_internal (XEPHEMERON (obj)->key, printcharfun, escapeflag);
+ write_ascstring (printcharfun, " :value ");
+ print_internal (XEPHEMERON (obj)->value, printcharfun, escapeflag);
+ write_ascstring (printcharfun, " :finalizer ");
+ print_internal (XEPHEMERON_FINALIZER (obj), printcharfun, escapeflag);
+ write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj));
}
static int
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Provide #'device-x-display, as documented in Lispref; thanks, Jeff Mincy.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5382:d0bb90d90736
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Dec 30 13:46:50 2010 +0000
files: lisp/ChangeLog lisp/x-misc.el
description:
Provide #'device-x-display, as documented in Lispref; thanks, Jeff Mincy.
lisp/ChangeLog addition:
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
diff -r f87bb35a6b94 -r d0bb90d90736 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/ChangeLog Thu Dec 30 13:46:50 2010 +0000
＠＠ -1,3 +1,10 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * x-misc.el (device-x-display):
+ Provide this function, documented in the Lispref for years, but
+ not existing previously. Thank you Julian Bradfield, thank you
+ Jeff Mincy.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
diff -r f87bb35a6b94 -r d0bb90d90736 lisp/x-misc.el
--- a/lisp/x-misc.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/x-misc.el Thu Dec 30 13:46:50 2010 +0000
＠＠ -86,4 +86,10 ＠＠
(x-bogosity-check-resource name class type))
(x-get-resource name class type locale nil 'warn))
+(defun device-x-display (&optional device)
+ "If DEVICE is an X11 device, return its DISPLAY.
+
+DEVICE defaults to the selected device."
+ (and (eq 'x (device-type device)) (device-connection device)))
+
;;; x-misc.el ends here
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Test sanity-checking of :start, :end keyword arguments when appropriate.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5381:f87bb35a6b94
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Dec 30 01:14:13 2010 +0000
files: tests/ChangeLog tests/automated/lisp-tests.el
description:
Test sanity-checking of :start, :end keyword arguments when appropriate.
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (wrong-type-argument): Add a missing
parenthesis here.
Make sure #'count #'position #'find #'delete* #'remove* #'reduce
#'delete-duplicates #'remove-duplicates #'replace #'mismatch
#'search sanity check their :start and :end keyword arguments.
diff -r df125a42c50c -r f87bb35a6b94 tests/ChangeLog
--- a/tests/ChangeLog Thu Dec 30 01:04:38 2010 +0000
+++ b/tests/ChangeLog Thu Dec 30 01:14:13 2010 +0000
＠＠ -1,3 +1,11 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el (wrong-type-argument): Add a missing
+ parenthesis here.
+ Make sure #'count #'position #'find #'delete* #'remove* #'reduce
+ #'delete-duplicates #'remove-duplicates #'replace #'mismatch
+ #'search sanity check their :start and :end keyword arguments.
+
2010-11-20 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
diff -r df125a42c50c -r f87bb35a6b94 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Thu Dec 30 01:04:38 2010 +0000
+++ b/tests/automated/lisp-tests.el Thu Dec 30 01:14:13 2010 +0000
＠＠ -2549,7 +2549,7 ＠＠
(Check-Error wrong-type-argument
(fill "1 2 3 4 5" ?1 :start (float most-positive-fixnum)))
(Check-Error wrong-type-argument
- (fill #*10101010 1 :start (float most-positive-fixnum))
+ (fill #*10101010 1 :start (float most-positive-fixnum)))
(Check-Error wrong-type-argument
(fill '(1 2 3 4 5) 1 :end (float most-positive-fixnum)))
(Check-Error wrong-type-argument
＠＠ -2669,4 +2669,125 ＠＠
(replace '(1 2 3 4 5) [5 4 3 2 1]
:end2 (1+ most-positive-fixnum))))
+(symbol-macrolet
+ ((list-length 2048) (vector-length 512) (string-length (* 8192 2)))
+ (let ((list
+ ;; CIRCULAR_LIST_SUSPICION_LENGTH is 1024, it's helpful if this list
+ ;; is longer than that.
+ (make-list list-length 'make-list))
+ (vector (make-vector vector-length 'make-vector))
+ (bit-vector (make-bit-vector vector-length 1))
+ (string (make-string string-length
+ (or (decode-char 'ucs #x20ac) ?\xFF)))
+ (item 'cons))
+ (dolist (function '(count position find delete* remove* reduce))
+ (Check-Error args-out-of-range
+ (funcall function item list
+:start (1+ list-length) :end (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (funcall function item list
+:start -1 :end list-length))
+ (Check-Error args-out-of-range
+ (funcall function item list :end (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (funcall function item vector
+:start (1+ vector-length) :end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (funcall function item vector :start -1))
+ (Check-Error args-out-of-range
+ (funcall function item vector :end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (funcall function item bit-vector
+:start (1+ vector-length) :end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (funcall function item bit-vector :start -1))
+ (Check-Error args-out-of-range
+ (funcall function item bit-vector :end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (funcall function item string
+:start (1+ string-length) :end (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (funcall function item string :start -1))
+ (Check-Error args-out-of-range
+ (funcall function item string :end (* 2 string-length))))
+ (dolist (function '(delete-duplicates remove-duplicates))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence list)
+:start (1+ list-length) :end (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (funcall function (copy-sequence list)
+:start -1 :end list-length))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence list)
+:end (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence vector)
+:start (1+ vector-length) :end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (funcall function (copy-sequence vector) :start -1))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence vector)
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence bit-vector)
+:start (1+ vector-length) :end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (funcall function (copy-sequence bit-vector) :start -1))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence bit-vector)
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence string)
+:start (1+ string-length) :end (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (funcall function (copy-sequence string) :start -1))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence string)
+:end (* 2 string-length))))
+ (dolist (function '(replace mismatch search))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence list) (copy-sequence list)
+:start1 (1+ list-length) :end1 (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (funcall function (copy-sequence list) (copy-sequence list)
+:start1 -1 :end1 list-length))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence list) (copy-sequence list)
+:end1 (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence vector)
+ (copy-sequence vector) :start1 (1+ vector-length)
+:end1 (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (funcall function (copy-sequence vector)
+ (copy-sequence vector) :start1 -1))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence vector)
+ (copy-sequence vector)
+:end1 (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence bit-vector)
+ (copy-sequence bit-vector)
+:start1 (1+ vector-length)
+:end1 (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (funcall function (copy-sequence bit-vector)
+ (copy-sequence bit-vector) :start1 -1))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence bit-vector)
+ (copy-sequence bit-vector)
+:end1 (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence string)
+ (copy-sequence string)
+:start1 (1+ string-length)
+:end1 (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (funcall function (copy-sequence string)
+ (copy-sequence string) :start1 -1))
+ (Check-Error args-out-of-range
+ (funcall function (copy-sequence string)
+ (copy-sequence string)
+:end1 (* 2 string-length))))))
+
;;; end of lisp-tests.el
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Support up to nine keywords in the PARSE_KEYWORDS() macro.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5380:df125a42c50c
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Dec 30 01:04:38 2010 +0000
files: src/ChangeLog src/lisp.h
description:
Support up to nine keywords in the PARSE_KEYWORDS() macro.
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* lisp.h (DECLARE_N_KEYWORDS_8, DECLARE_N_KEYWORDS_9)
(CHECK_N_KEYWORDS_8, CHECK_N_KEYWORDS_9):
Support up to nine keywords in the PARSE_KEYWORDS() macro.
diff -r 57a64ab2ae45 -r df125a42c50c src/ChangeLog
--- a/src/ChangeLog Thu Dec 30 01:00:40 2010 +0000
+++ b/src/ChangeLog Thu Dec 30 01:04:38 2010 +0000
＠＠ -1,3 +1,9 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lisp.h (DECLARE_N_KEYWORDS_8, DECLARE_N_KEYWORDS_9)
+ (CHECK_N_KEYWORDS_8, CHECK_N_KEYWORDS_9):
+ Support up to nine keywords in the PARSE_KEYWORDS() macro.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* elhash.c (syms_of_elhash):
diff -r 57a64ab2ae45 -r df125a42c50c src/lisp.h
--- a/src/lisp.h Thu Dec 30 01:00:40 2010 +0000
+++ b/src/lisp.h Thu Dec 30 01:04:38 2010 +0000
＠＠ -3641,6 +3641,10 ＠＠
DECLARE_N_KEYWORDS_5(a,b,c,d,e), f = Qnil
#define DECLARE_N_KEYWORDS_7(a,b,c,d,e,f,g) \
DECLARE_N_KEYWORDS_6(a,b,c,d,e,f), g = Qnil
+#define DECLARE_N_KEYWORDS_8(a,b,c,d,e,f,g,h) \
+ DECLARE_N_KEYWORDS_7(a,b,c,d,e,f,g), h = Qnil
+#define DECLARE_N_KEYWORDS_9(a,b,c,d,e,f,g,h,i) \
+ DECLARE_N_KEYWORDS_8(a,b,c,d,e,f,g,h), i = Qnil
#define CHECK_N_KEYWORDS_1(a) \
else if (EQ (pk_key, Q_##a)) { a = pk_value; }
＠＠ -3656,6 +3660,12 ＠＠
else if (EQ (pk_key, Q_##f)) { f = pk_value; }
#define CHECK_N_KEYWORDS_7(a,b,c,d,e,f,g) CHECK_N_KEYWORDS_6(a,b,c,d,e,f) \
else if (EQ (pk_key, Q_##g)) { g = pk_value; }
+#define CHECK_N_KEYWORDS_8(a,b,c,d,e,f,g,h) \
+ CHECK_N_KEYWORDS_7(a,b,c,d,e,f,g) \
+ else if (EQ (pk_key, Q_##h)) { h = pk_value; }
+#define CHECK_N_KEYWORDS_9(a,b,c,d,e,f,g,h,i) \
+ CHECK_N_KEYWORDS_8(a,b,c,d,e,f,g,h) \
+ else if (EQ (pk_key, Q_##i)) { i = pk_value; }
Boolint non_nil_allow_other_keys_p (Elemcount offset, int nargs,
Lisp_Object *args);
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Implement some basic Lisp functions in terms of Common Lisp builtins.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5379:57a64ab2ae45
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Dec 30 01:00:40 2010 +0000
files: lisp/ChangeLog lisp/iso8859-1.el lisp/simple.el lisp/subr.el
description:
Implement some basic Lisp functions in terms of Common Lisp builtins.
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
this function (it's already in subr.el).
* iso8859-1.el (char-width):
On non-Mule, make this function equivalent to that produced by
(constantly 1), but preserve its docstring.
* subr.el (subst-char-in-string): Define this in terms of
#'substitute, #'nsubstitute.
(string-width): Define this using #'reduce and #'char-width.
(char-width): Give this a simpler definition, it makes far more
sense to check for mule at load time and redefine, as we do in
iso8859-1.el.
(store-substring): Implement this in terms of #'replace, now
#'replace is cheap.
diff -r 31be2a3d121d -r 57a64ab2ae45 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Dec 30 00:50:10 2010 +0000
+++ b/lisp/ChangeLog Thu Dec 30 01:00:40 2010 +0000
＠＠ -1,3 +1,19 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * simple.el (assoc-ignore-case): Remove a duplicate definition of
+ this function (it's already in subr.el).
+ * iso8859-1.el (char-width):
+ On non-Mule, make this function equivalent to that produced by
+ (constantly 1), but preserve its docstring.
+ * subr.el (subst-char-in-string): Define this in terms of
+ #'substitute, #'nsubstitute.
+ (string-width): Define this using #'reduce and #'char-width.
+ (char-width): Give this a simpler definition, it makes far more
+ sense to check for mule at load time and redefine, as we do in
+ iso8859-1.el.
+ (store-substring): Implement this in terms of #'replace, now
+ #'replace is cheap.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
diff -r 31be2a3d121d -r 57a64ab2ae45 lisp/iso8859-1.el
--- a/lisp/iso8859-1.el Thu Dec 30 00:50:10 2010 +0000
+++ b/lisp/iso8859-1.el Thu Dec 30 01:00:40 2010 +0000
＠＠ -84,6 +84,17 ＠＠
;; by default.
(setq-default ctl-arrow #xA0)
+(when (and (compiled-function-p (symbol-function 'char-width))
+ (not (featurep 'mule)))
+ (defalias 'char-width
+ (let ((constantly (constantly 1)))
+ (make-byte-code (compiled-function-arglist constantly)
+ (compiled-function-instructions constantly)
+ (compiled-function-constants constantly)
+ (compiled-function-stack-depth constantly)
+ (compiled-function-doc-string
+ (symbol-function 'char-width))))))
+
;; Shouldn't be necessary, but one file in the packages uses it:
(provide 'iso8859-1)
diff -r 31be2a3d121d -r 57a64ab2ae45 lisp/simple.el
--- a/lisp/simple.el Thu Dec 30 00:50:10 2010 +0000
+++ b/lisp/simple.el Thu Dec 30 01:00:40 2010 +0000
＠＠ -3332,11 +3332,6 ＠＠
;; keyboard-quit
;; buffer-quit-function
;; keyboard-escape-quit
-
-(defun assoc-ignore-case (key alist)
- "Like `assoc', but assumes KEY is a string and ignores case when comparing."
- (assoc* key alist :test #'equalp))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mail composition code ;;
diff -r 31be2a3d121d -r 57a64ab2ae45 lisp/subr.el
--- a/lisp/subr.el Thu Dec 30 00:50:10 2010 +0000
+++ b/lisp/subr.el Thu Dec 30 01:00:40 2010 +0000
＠＠ -765,14 +765,8 ＠＠
(defun subst-char-in-string (fromchar tochar string &optional inplace)
"Replace FROMCHAR with TOCHAR in STRING each time it occurs.
Unless optional argument INPLACE is non-nil, return a new string."
- (let ((i (length string))
- (newstr (if inplace string (copy-sequence string))))
- (while (> i 0)
- (setq i (1- i))
- (if (eq (aref newstr i) fromchar)
- (aset newstr i tochar)))
- newstr))
-
+ (funcall (if inplace #'nsubstitute #'substitute) tochar fromchar
+ (the string string) :test #'eq))
;; XEmacs addition:
(defun replace-in-string (str regexp newtext &optional literal)
＠＠ -961,23 +955,11 ＠＠
the characters in STRING, which may not accurately represent the actual
display width when using a window system. With no international support,
simply returns the length of the string."
- (if (featurep 'mule)
- (let ((col 0)
- (len (length string))
- (i 0))
- (with-fboundp '(charset-width char-charset)
- (while (< i len)
- (setq col (+ col (charset-width (char-charset (aref string i)))))
- (setq i (1+ i))))
- col)
- (length string)))
+ (reduce #'+ (the string string) :initial-value 0 :key #'char-width))
(defun char-width (character)
"Return number of columns a CHARACTER occupies when displayed."
- (if (featurep 'mule)
- (with-fboundp '(charset-width char-charset)
- (charset-width (char-charset character)))
- 1))
+ (charset-width (char-charset character)))
;; The following several functions are useful in GNU Emacs 20 because
;; of the multibyte "characters" the internal representation of which
＠＠ -1003,18 +985,9 ＠＠
(defun store-substring (string idx obj)
"Embed OBJ (string or character) at index IDX of STRING."
- (let* ((str (cond ((stringp obj) obj)
- ((characterp obj) (char-to-string obj))
- (t (error
- "Invalid argument (should be string or character): %s"
- obj))))
- (string-len (length string))
- (len (length str))
- (i 0))
- (while (and (< i len) (< idx string-len))
- (aset string idx (aref str i))
- (setq idx (1+ idx) i (1+ i)))
- string))
+ (if (stringp obj)
+ (replace (the string string) obj :start1 idx)
+ (prog1 string (aset string idx obj))))
;; From FSF 21.1; ELLIPSES is XEmacs addition.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Move Qcount, Q_default, Q_test to general-slots.h; add SYMBOL_KEYWORD_GENERAL()
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5378:31be2a3d121d
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Dec 30 00:50:10 2010 +0000
files: src/ChangeLog src/abbrev.c src/chartab.c src/elhash.c src/general-slots.h src/general.c src/lisp.h
description:
Move Qcount, Q_default, Q_test to general-slots.h; add SYMBOL_KEYWORD_GENERAL()
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* elhash.c (syms_of_elhash):
* chartab.c (syms_of_chartab):
* abbrev.c (syms_of_abbrev):
* general-slots.h:
Move Qcount, Q_default, Q_test to general-slots.h, they're about
to be used by other files. Rename Q_default to Q_default_, for the
sake of the PARSE_KEYWORDS macro (given that default is a reserved
identifier in C). Add SYMBOL_KEYWORD_GENERAL(), analogous to
SYMBOL_GENERAL() to make this easier.
diff -r ed5d4f081fa9 -r 31be2a3d121d src/ChangeLog
--- a/src/ChangeLog Thu Dec 30 00:18:50 2010 +0000
+++ b/src/ChangeLog Thu Dec 30 00:50:10 2010 +0000
＠＠ -1,3 +1,15 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * elhash.c (syms_of_elhash):
+ * chartab.c (syms_of_chartab):
+ * abbrev.c (syms_of_abbrev):
+ * general-slots.h:
+ Move Qcount, Q_default, Q_test to general-slots.h, they're about
+ to be used by other files. Rename Q_default to Q_default_, for the
+ sake of the PARSE_KEYWORDS macro (given that default is a reserved
+ identifier in C). Add SYMBOL_KEYWORD_GENERAL(), analogous to
+ SYMBOL_GENERAL() to make this easier.
+
2010-12-29 Aidan Kehoe <kehoea(a)parhasard.net>
* floatfns.c (Ffloat): If we've been handed a bigfloat here, it's
diff -r ed5d4f081fa9 -r 31be2a3d121d src/abbrev.c
--- a/src/abbrev.c Thu Dec 30 00:18:50 2010 +0000
+++ b/src/abbrev.c Thu Dec 30 00:50:10 2010 +0000
＠＠ -75,7 +75,7 ＠＠
/* Hook to run before expanding any abbrev. */
Lisp_Object Vpre_abbrev_expand_hook, Qpre_abbrev_expand_hook;
-Lisp_Object Qsystem_type, Qcount;
+Lisp_Object Qsystem_type;
struct abbrev_match_mapper_closure
{
＠＠ -558,9 +558,6 ＠＠
void
syms_of_abbrev (void)
{
- DEFSYMBOL(Qcount);
- Qcount = intern ("count");
- staticpro (&Qcount);
DEFSYMBOL(Qsystem_type);
Qsystem_type = intern ("system-type");
DEFSYMBOL (Qpre_abbrev_expand_hook);
diff -r ed5d4f081fa9 -r 31be2a3d121d src/chartab.c
--- a/src/chartab.c Thu Dec 30 00:18:50 2010 +0000
+++ b/src/chartab.c Thu Dec 30 00:50:10 2010 +0000
＠＠ -42,7 +42,7 ＠＠
#include "chartab.h"
#include "syntax.h"
-Lisp_Object Qchar_tablep, Qchar_table, Q_default;
+Lisp_Object Qchar_tablep, Qchar_table;
Lisp_Object Vall_syntax_tables;
＠＠ -1581,7 +1581,7 ＠＠
{
type = value;
}
- else if (EQ (key, Q_default))
+ else if (EQ (key, Q_default_))
{
default_ = value;
}
＠＠ -1626,7 +1626,11 ＠＠
check_valid_char_table_value (default_, XCHAR_TABLE_TYPE (chartab),
ERROR_ME);
set_char_table_default (chartab, default_);
- set_char_table_default (XCHAR_TABLE (chartab)->mirror_table, default_);
+ if (!NILP (XCHAR_TABLE (chartab)->mirror_table))
+ {
+ set_char_table_default (XCHAR_TABLE (chartab)->mirror_table,
+ default_);
+ }
}
while (!NILP (dataval))
＠＠ -1902,7 +1906,6 ＠＠
DEFSYMBOL (Qchar_table);
DEFSYMBOL_MULTIWORD_PREDICATE (Qchar_tablep);
- DEFKEYWORD (Q_default);
DEFSUBR (Fchar_table_p);
DEFSUBR (Fchar_table_type_list);
＠＠ -1957,7 +1960,7 ＠＠
define_structure_type_keyword (st, Q_type, chartab_type_validate);
define_structure_type_keyword (st, Q_data, chartab_data_validate);
- define_structure_type_keyword (st, Q_default, chartab_default_validate);
+ define_structure_type_keyword (st, Q_default_, chartab_default_validate);
}
void
diff -r ed5d4f081fa9 -r 31be2a3d121d src/elhash.c
--- a/src/elhash.c Thu Dec 30 00:18:50 2010 +0000
+++ b/src/elhash.c Thu Dec 30 00:50:10 2010 +0000
＠＠ -93,7 +93,7 ＠＠
static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value;
static Lisp_Object Vall_weak_hash_tables;
static Lisp_Object Qrehash_size, Qrehash_threshold;
-static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
+static Lisp_Object Q_size, Q_weakness, Q_rehash_size, Q_rehash_threshold;
static Lisp_Object Vhash_table_test_eq, Vhash_table_test_eql;
static Lisp_Object Vhash_table_test_weak_list;
＠＠ -2291,7 +2291,6 ＠＠
DEFSYMBOL (Qnon_weak); /* obsolete */
DEFKEYWORD (Q_data);
- DEFKEYWORD (Q_test);
DEFKEYWORD (Q_size);
DEFKEYWORD (Q_rehash_size);
DEFKEYWORD (Q_rehash_threshold);
diff -r ed5d4f081fa9 -r 31be2a3d121d src/general-slots.h
--- a/src/general-slots.h Thu Dec 30 00:18:50 2010 +0000
+++ b/src/general-slots.h Thu Dec 30 00:50:10 2010 +0000
＠＠ -32,6 +32,8 ＠＠
SYMBOL_KEYWORD (Q_foo); declares a keyword symbol ":foo"
SYMBOL_GENERAL (Qfoo, "bar"); declares a symbol named "bar" but stored in
the variable Qfoo
+ SYMBOL_KEYWORD_GENERAL (Q_foo_, ":bar"); declares a keyword named ":bar"
+ but stored in the variable Q_foo_.
To sort the crap in this file, use the following:
＠＠ -92,6 +94,7 ＠＠
SYMBOL (Qconsole);
SYMBOL (Qcontrol_1);
SYMBOL (Qcopies);
+SYMBOL (Qcount);
SYMBOL_MODULE_API (Qcritical);
SYMBOL (Qctext);
SYMBOL (Qcurrent);
＠＠ -102,6 +105,9 ＠＠
SYMBOL (Qdead);
SYMBOL (Qdebug);
SYMBOL (Qdefault);
+/* We name the C variable corresponding to the keyword Q_default_, not
+ Q_default, to allow it to be useful with PARSE_KEYWORDS (). */
+SYMBOL_KEYWORD_GENERAL (Q_default_, ":default");
SYMBOL_MODULE_API (Qdelete);
SYMBOL (Qdelq);
SYMBOL (Qdescription);
＠＠ -270,6 +276,7 ＠＠
SYMBOL_KEYWORD (Q_start);
SYMBOL (Qstream);
SYMBOL (Qstring);
+SYMBOL (Qstring_match);
SYMBOL_KEYWORD (Q_style);
SYMBOL_KEYWORD (Q_suffix);
SYMBOL (Qsubtype);
＠＠ -279,6 +286,7 ＠＠
SYMBOL (Qsystem_default);
SYMBOL (Qterminal);
SYMBOL (Qtest);
+SYMBOL_KEYWORD (Q_test);
SYMBOL (Qtext);
SYMBOL_KEYWORD (Q_text);
SYMBOL (Qthis_command);
diff -r ed5d4f081fa9 -r 31be2a3d121d src/general.c
--- a/src/general.c Thu Dec 30 00:18:50 2010 +0000
+++ b/src/general.c Thu Dec 30 00:50:10 2010 +0000
＠＠ -29,8 +29,9 ＠＠
#define SYMBOL(fou) Lisp_Object fou
#define SYMBOL_MODULE_API(fou) Lisp_Object fou
-#define SYMBOL_KEYWORD(la_cle_est_fou) Lisp_Object la_cle_est_fou
+#define SYMBOL_KEYWORD(la_cle_est_folle) Lisp_Object la_cle_est_folle
#define SYMBOL_GENERAL(tout_le_monde, est_fou) Lisp_Object tout_le_monde
+#define SYMBOL_KEYWORD_GENERAL(ponle, la_clave) Lisp_Object ponle
#include "general-slots.h"
＠＠ -38,6 +39,7 ＠＠
#undef SYMBOL_MODULE_API
#undef SYMBOL_KEYWORD
#undef SYMBOL_GENERAL
+#undef SYMBOL_KEYWORD_GENERAL
void
syms_of_general (void)
＠＠ -46,10 +48,13 ＠＠
#define SYMBOL_MODULE_API(loco) DEFSYMBOL (loco)
#define SYMBOL_KEYWORD(meshugeneh) DEFKEYWORD (meshugeneh)
#define SYMBOL_GENERAL(vachement, fou) defsymbol (&vachement, fou)
+#define SYMBOL_KEYWORD_GENERAL(bescheuert, gaaanz_bescheuert) \
+ defkeyword (&bescheuert, gaaanz_bescheuert)
#include "general-slots.h"
#undef SYMBOL
#undef SYMBOL_KEYWORD
#undef SYMBOL_GENERAL
+#undef SYMBOL_KEYWORD_GENERAL
}
diff -r ed5d4f081fa9 -r 31be2a3d121d src/lisp.h
--- a/src/lisp.h Thu Dec 30 00:18:50 2010 +0000
+++ b/src/lisp.h Thu Dec 30 00:50:10 2010 +0000
＠＠ -5305,9 +5305,11 ＠＠
/* Defined in general.c */
#define SYMBOL(fou) extern Lisp_Object fou
#define SYMBOL_MODULE_API(fou) extern MODULE_API Lisp_Object fou
-#define SYMBOL_KEYWORD(la_cle_est_fou) extern Lisp_Object la_cle_est_fou
+#define SYMBOL_KEYWORD(la_cle_est_folle) extern Lisp_Object la_cle_est_folle
#define SYMBOL_GENERAL(tout_le_monde, est_fou) \
extern Lisp_Object tout_le_monde
+#define SYMBOL_KEYWORD_GENERAL(y_compris_ben, mais_que_peut_on_faire) \
+ extern Lisp_Object y_compris_ben
#include "general-slots.h"
＠＠ -5315,6 +5317,7 ＠＠
#undef SYMBOL_MODULE_API
#undef SYMBOL_KEYWORD
#undef SYMBOL_GENERAL
+#undef SYMBOL_KEYWORD_GENERAL
extern Lisp_Object Qeq;
extern Lisp_Object Qeql;
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: cl-macs belongs in lisp-files-needed-for-byte-compilation.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5377:ed5d4f081fa9
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Dec 30 00:18:50 2010 +0000
files: lisp/ChangeLog lisp/update-elc.el
description:
cl-macs belongs in lisp-files-needed-for-byte-compilation.
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
(lisp-files-needing-early-byte-compilation):
cl-macs belongs in the former, not the latter, it is as
fundamental as bytecomp.el.
diff -r 203dcac81dae -r ed5d4f081fa9 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Dec 30 00:15:37 2010 +0000
+++ b/lisp/ChangeLog Thu Dec 30 00:18:50 2010 +0000
＠＠ -1,3 +1,10 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * update-elc.el (lisp-files-needed-for-byte-compilation)
+ (lisp-files-needing-early-byte-compilation):
+ cl-macs belongs in the former, not the latter, it is as
+ fundamental as bytecomp.el.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.el:
diff -r 203dcac81dae -r ed5d4f081fa9 lisp/update-elc.el
--- a/lisp/update-elc.el Thu Dec 30 00:15:37 2010 +0000
+++ b/lisp/update-elc.el Thu Dec 30 00:18:50 2010 +0000
＠＠ -102,6 +102,7 ＠＠
;; .elc's.
(defvar lisp-files-needed-for-byte-compilation
'("bytecomp"
+ "cl-macs"
"byte-optimize"))
;; Lisp files not in `lisp-files-needed-for-byte-compilation' that need
＠＠ -110,8 +111,7 ＠＠
(defvar lisp-files-needing-early-byte-compilation
'("easy-mmode"
"autoload"
- "shadow"
- "cl-macs"))
+ "shadow"))
(defvar unbytecompiled-lisp-files
'("paths.el"
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Provide some milquetoast compatibility in our errors, type-error, program-error
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5376:203dcac81dae
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Dec 30 00:15:37 2010 +0000
files: lisp/ChangeLog lisp/cl.el
description:
Provide some milquetoast compatibility in our errors, type-error, program-error
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.el:
Provde the Common Lisp program-error, type-error as error
symbols. This doesn't nearly go far enough for anyone using the
Common Lisp errors.
diff -r 8aa511adfad6 -r 203dcac81dae lisp/ChangeLog
--- a/lisp/ChangeLog Wed Dec 29 23:56:57 2010 +0000
+++ b/lisp/ChangeLog Thu Dec 30 00:15:37 2010 +0000
＠＠ -1,3 +1,10 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl.el:
+ Provde the Common Lisp program-error, type-error as error
+ symbols. This doesn't nearly go far enough for anyone using the
+ Common Lisp errors.
+
2010-12-29 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (delete-duplicates):
diff -r 8aa511adfad6 -r 203dcac81dae lisp/cl.el
--- a/lisp/cl.el Wed Dec 29 23:56:57 2010 +0000
+++ b/lisp/cl.el Thu Dec 30 00:15:37 2010 +0000
＠＠ -603,6 +603,19 ＠＠
;; XEmacs change
(define-error 'cl-assertion-failed "Assertion failed")
+;; XEmacs; provide a milquetoast amount of compatibility in our error symbols.
+(define-error 'type-error "Wrong type" 'wrong-type-argument)
+(define-error 'program-error "Error in your program" 'invalid-argument)
+
+(map-plist
+ #'(lambda (key value)
+ (mapc #'(lambda (error)
+ (put error 'error-conditions
+ (cons key (get error 'error-conditions))))
+ value))
+ '(program-error (wrong-number-of-arguments invalid-keyword-argument)
+ type-error (wrong-type-argument malformed-list circular-list)))
+
;; XEmacs change: omit the autoload rules; we handle those a different way
;;; Define data for indentation and edebug.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: #'delete-duplicates: don't attempt to compiler macroexpand with bad arguments
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5375:8aa511adfad6
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Wed Dec 29 23:56:57 2010 +0000
files: lisp/ChangeLog lisp/cl-macs.el
description:
#'delete-duplicates: don't attempt to compiler macroexpand with bad arguments
2010-12-29 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
diff -r 9ac28212c75a -r 8aa511adfad6 lisp/ChangeLog
--- a/lisp/ChangeLog Wed Dec 29 23:53:48 2010 +0000
+++ b/lisp/ChangeLog Wed Dec 29 23:56:57 2010 +0000
＠＠ -1,3 +1,9 ＠＠
+2010-12-29 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (delete-duplicates):
+ If the form has an incorrect number of arguments, don't attempt a
+ compiler macroexpansion.
+
2010-12-29 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (cl-safe-expr-p):
diff -r 9ac28212c75a -r 8aa511adfad6 lisp/cl-macs.el
--- a/lisp/cl-macs.el Wed Dec 29 23:53:48 2010 +0000
+++ b/lisp/cl-macs.el Wed Dec 29 23:56:57 2010 +0000
＠＠ -3487,56 +3487,60 ＠＠
;; XEmacs; inline delete-duplicates if it's called with one of the
;; common compile-time constant tests and an optional :from-end
;; argument, we want the speed in font-lock.el.
-(define-compiler-macro delete-duplicates (&whole form cl-seq &rest cl-keys)
- (if (not (or (memq (car-safe cl-seq)
- ;; No need to check for a list at runtime with
- ;; these. We could expand the list, but these are all
- ;; the functions in the relevant context at the moment.
- '(nreverse append nconc mapcan mapcar string-to-list))
- (and (listp cl-seq) (equal (butlast cl-seq) '(the list)))))
- form
- (cond
- ((or (plists-equal cl-keys '(:test 'eq) t)
- (plists-equal cl-keys '(:test #'eq) t))
- `(let* ((begin ,cl-seq)
- cl-seq)
- (while (memq (car begin) (cdr begin))
- (setq begin (cdr begin)))
- (setq cl-seq begin)
- (while (cddr cl-seq)
- (if (memq (cadr cl-seq) (cddr cl-seq))
- (setcdr (cdr cl-seq) (cddr cl-seq)))
- (setq cl-seq (cdr cl-seq)))
- begin))
- ((or (plists-equal cl-keys '(:test 'eq :from-end t) t)
- (plists-equal cl-keys '(:test #'eq :from-end t) t))
- `(let* ((begin ,cl-seq)
- (cl-seq begin))
- (while cl-seq
- (setq cl-seq (setcdr cl-seq
- (delq (car cl-seq) (cdr cl-seq)))))
- begin))
- ((or (plists-equal cl-keys '(:test 'equal) t)
- (plists-equal cl-keys '(:test #'equal) t))
- `(let* ((begin ,cl-seq)
- cl-seq)
- (while (member (car begin) (cdr begin))
- (setq begin (cdr begin)))
- (setq cl-seq begin)
- (while (cddr cl-seq)
- (if (member (cadr cl-seq) (cddr cl-seq))
- (setcdr (cdr cl-seq) (cddr cl-seq)))
- (setq cl-seq (cdr cl-seq)))
- begin))
- ((or (plists-equal cl-keys '(:test 'equal :from-end t) t)
- (plists-equal cl-keys '(:test #'equal :from-end t) t))
- `(let* ((begin ,cl-seq)
- (cl-seq begin))
- (while cl-seq
- (setq cl-seq (setcdr cl-seq (delete (car cl-seq)
- (cdr cl-seq)))))
- begin))
- (t form))))
+(define-compiler-macro delete-duplicates (&whole form &rest cl-keys)
+ (let ((cl-seq (if cl-keys (pop cl-keys))))
+ (if (or
+ (not (or (memq (car-safe cl-seq)
+ ;; No need to check for a list at runtime with
+ ;; these. We could expand the list, but these are all
+ ;; the functions in the relevant context at the moment.
+ '(nreverse append nconc mapcan mapcar string-to-list))
+ (and (listp cl-seq) (equal (butlast cl-seq) '(the list)))))
+ ;; Wrong number of arguments.
+ (not (cdr form)))
+ form
+ (cond
+ ((or (plists-equal cl-keys '(:test 'eq) t)
+ (plists-equal cl-keys '(:test #'eq) t))
+ `(let* ((begin ,cl-seq)
+ cl-seq)
+ (while (memq (car begin) (cdr begin))
+ (setq begin (cdr begin)))
+ (setq cl-seq begin)
+ (while (cddr cl-seq)
+ (if (memq (cadr cl-seq) (cddr cl-seq))
+ (setcdr (cdr cl-seq) (cddr cl-seq)))
+ (setq cl-seq (cdr cl-seq)))
+ begin))
+ ((or (plists-equal cl-keys '(:test 'eq :from-end t) t)
+ (plists-equal cl-keys '(:test #'eq :from-end t) t))
+ `(let* ((begin ,cl-seq)
+ (cl-seq begin))
+ (while cl-seq
+ (setq cl-seq (setcdr cl-seq
+ (delq (car cl-seq) (cdr cl-seq)))))
+ begin))
+ ((or (plists-equal cl-keys '(:test 'equal) t)
+ (plists-equal cl-keys '(:test #'equal) t))
+ `(let* ((begin ,cl-seq)
+ cl-seq)
+ (while (member (car begin) (cdr begin))
+ (setq begin (cdr begin)))
+ (setq cl-seq begin)
+ (while (cddr cl-seq)
+ (if (member (cadr cl-seq) (cddr cl-seq))
+ (setcdr (cdr cl-seq) (cddr cl-seq)))
+ (setq cl-seq (cdr cl-seq)))
+ begin))
+ ((or (plists-equal cl-keys '(:test 'equal :from-end t) t)
+ (plists-equal cl-keys '(:test #'equal :from-end t) t))
+ `(let* ((begin ,cl-seq)
+ (cl-seq begin))
+ (while cl-seq
+ (setq cl-seq (setcdr cl-seq (delete (car cl-seq)
+ (cdr cl-seq)))))
+ begin))
+ (t form)))))
;; XEmacs; it's perfectly reasonable, and often much clearer to those
;; reading the code, to call regexp-quote on a constant string, which is
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments