mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-24 10:38:38 +00:00
Code Issues Releases Activity

* calc/calc-prog.el (math-do-defmath): Use backquote forms. Fix

Browse Source 
handling of interactive spec when the body uses return.
(math-do-arg-check, math-define-function-body): Use backquote forms.
* calc/calc-ext.el (math-defcache): Likewise.
* calc/calc-rewr.el (math-rwfail, math-rweval): Likewise.
* allout.el (allout-new-exposure): Likewise.
* calc/calcalg2.el (math-tracing-integral): Likewise.
* info.el (Info-last-menu-item): Likewise.
* emulation/vip.el (vip-loop): Likewise.
* textmodes/artist.el (artist-funcall): Likewise.
* menu-bar.el (menu-bar-make-mm-toggle, menu-bar-make-toggle):
Construct menu-item directly.

* cedet/ede/base.el (ede-with-projectfile): Use backquote forms.
This commit is contained in:
Andreas Schwab 2012-08-07 18:12:20 +02:00
parent c644523bd8
commit 651eaf36f2
12 changed files with 193 additions and 240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
lisp/ChangeLog
View File

@ -1,5 +1,18 @@
2012-08-07 Andreas Schwab <schwab@linux-m68k.org>
* calc/calc-prog.el (math-do-defmath): Use backquote forms. Fix
handling of interactive spec when the body uses return.
(math-do-arg-check, math-define-function-body): Use backquote forms.
* calc/calc-ext.el (math-defcache): Likewise.
* calc/calc-rewr.el (math-rwfail, math-rweval): Likewise.
* allout.el (allout-new-exposure): Likewise.
* calc/calcalg2.el (math-tracing-integral): Likewise.
* info.el (Info-last-menu-item): Likewise.
* emulation/vip.el (vip-loop): Likewise.
* textmodes/artist.el (artist-funcall): Likewise.
* menu-bar.el (menu-bar-make-mm-toggle, menu-bar-make-toggle):
Construct menu-item directly.
* progmodes/autoconf.el (font-lock-syntactic-keywords): Don't
declare.

10
lisp/allout.el
View File

@ -5312,11 +5312,11 @@ Examples:
Expose children and grandchildren of first topic at current
level, and expose children of subsequent topics at current
level *except* for the last, which should be opened completely."
(list 'save-excursion
'(if (not (or (allout-goto-prefix-doublechecked)
(allout-next-heading)))
(error "allout-new-exposure: Can't find any outline topics"))
(list 'allout-expose-topic (list 'quote spec))))
`(save-excursion
(if (not (or (allout-goto-prefix-doublechecked)
(allout-next-heading)))
(error "allout-new-exposure: Can't find any outline topics"))
(allout-expose-topic ',spec)))
;;;_ #7 Systematic outline presentation -- copying, printing, flattening

75
lisp/calc/calc-ext.el
View File

@ -1997,51 +1997,36 @@ calc-kill calc-kill-region calc-yank))))
(cache-val (intern (concat (symbol-name name) "-cache")))
(last-prec (intern (concat (symbol-name name) "-last-prec")))
(last-val (intern (concat (symbol-name name) "-last"))))
(list 'progn
; (list 'defvar cache-prec (if init (math-numdigs (nth 1 init)) -100))
(list 'defvar cache-prec
`(cond
((consp ,init) (math-numdigs (nth 1 ,init)))
(,init
(nth 1 (math-numdigs (eval ,init))))
(t
-100)))
(list 'defvar cache-val
`(cond
((consp ,init) ,init)
(,init (eval ,init))
(t ,init)))
(list 'defvar last-prec -100)
(list 'defvar last-val nil)
(list 'setq 'math-cache-list
(list 'cons
(list 'quote cache-prec)
(list 'cons
(list 'quote last-prec)
'math-cache-list)))
(list 'defun
name ()
(list 'or
(list '= last-prec 'calc-internal-prec)
(list 'setq
last-val
(list 'math-normalize
(list 'progn
(list 'or
(list '>= cache-prec
'calc-internal-prec)
(list 'setq
cache-val
(list 'let
'((calc-internal-prec
(+ calc-internal-prec
4)))
form)
cache-prec
'(+ calc-internal-prec 2)))
cache-val))
last-prec 'calc-internal-prec))
last-val))))
`(progn
; (defvar ,cache-prec ,(if init (math-numdigs (nth 1 init)) -100))
(defvar ,cache-prec (cond
((consp ,init) (math-numdigs (nth 1 ,init)))
(,init
(nth 1 (math-numdigs (eval ,init))))
(t
-100)))
(defvar ,cache-val (cond ((consp ,init) ,init)
(,init (eval ,init))
(t ,init)))
(defvar ,last-prec -100)
(defvar ,last-val nil)
(setq math-cache-list
(cons ',cache-prec
(cons ',last-prec
math-cache-list)))
(defun ,name ()
(or (= ,last-prec calc-internal-prec)
(setq ,last-val
(math-normalize
(progn (or (>= ,cache-prec calc-internal-prec)
(setq ,cache-val
(let ((calc-internal-prec
(+ calc-internal-prec 4)))
,form)
,cache-prec (+ calc-internal-prec 2)))
,cache-val))
,last-prec calc-internal-prec))
,last-val))))
(put 'math-defcache 'lisp-indent-hook 2)
;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public]

222
lisp/calc/calc-prog.el
View File

@ -1792,89 +1792,63 @@ Redefine the corresponding command."
(defun math-do-defmath (func args body)
(require 'calc-macs)
(let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
(doc (if (stringp (car body)) (list (car body))))
(doc (if (stringp (car body))
(prog1 (list (car body))
(setq body (cdr body)))))
(clargs (mapcar 'math-clean-arg args))
(body (math-define-function-body
(if (stringp (car body)) (cdr body) body)
clargs)))
(list 'progn
(if (and (consp (car body))
(eq (car (car body)) 'interactive))
(let ((inter (car body)))
(setq body (cdr body))
(if (or (> (length inter) 2)
(integerp (nth 1 inter)))
(let ((hasprefix nil) (hasmulti nil))
(if (stringp (nth 1 inter))
(progn
(cond ((equal (nth 1 inter) "p")
(setq hasprefix t))
((equal (nth 1 inter) "m")
(setq hasmulti t))
(t (error
"Can't handle interactive code string \"%s\""
(nth 1 inter))))
(setq inter (cdr inter))))
(if (not (integerp (nth 1 inter)))
(error
"Expected an integer in interactive specification"))
(append (list 'defun
(intern (concat "calc-"
(symbol-name func)))
(if (or hasprefix hasmulti)
'(&optional n)
()))
doc
(if (or hasprefix hasmulti)
'((interactive "P"))
'((interactive)))
(list
(append
'(calc-slow-wrapper)
(and hasmulti
(list
(list 'setq
'n
(list 'if
'n
(list 'prefix-numeric-value
'n)
(nth 1 inter)))))
(list
(list 'calc-enter-result
(if hasmulti 'n (nth 1 inter))
(nth 2 inter)
(if hasprefix
(list 'append
(list 'quote (list fname))
(list 'calc-top-list-n
(nth 1 inter))
(list 'and
'n
(list
'list
(list
'math-normalize
(list
'prefix-numeric-value
'n)))))
(list 'cons
(list 'quote fname)
(list 'calc-top-list-n
(if hasmulti
'n
(nth 1 inter)))))))))))
(append (list 'defun
(intern (concat "calc-" (symbol-name func)))
args)
doc
(list
inter
(cons 'calc-wrapper body))))))
(append (list 'defun fname clargs)
doc
(math-do-arg-list-check args nil nil)
body))))
(inter (if (and (consp (car body))
(eq (car (car body)) 'interactive))
(prog1 (car body)
(setq body (cdr body))))))
(setq body (math-define-function-body body clargs))
`(progn
,(if inter
(if (or (> (length inter) 2)
(integerp (nth 1 inter)))
(let ((hasprefix nil) (hasmulti nil))
(when (stringp (nth 1 inter))
(cond ((equal (nth 1 inter) "p")
(setq hasprefix t))
((equal (nth 1 inter) "m")
(setq hasmulti t))
(t (error
"Can't handle interactive code string \"%s\""
(nth 1 inter))))
(setq inter (cdr inter)))
(unless (integerp (nth 1 inter))
(error "Expected an integer in interactive specification"))
`(defun ,(intern (concat "calc-" (symbol-name func)))
,(if (or hasprefix hasmulti) '(&optional n) ())
,@doc
(interactive ,@(if (or hasprefix hasmulti) '("P")))
(calc-slow-wrapper
,@(if hasmulti
`((setq n (if n
(prefix-numeric-value n)
,(nth 1 inter)))))
(calc-enter-result
,(if hasmulti 'n (nth 1 inter))
,(nth 2 inter)
,(if hasprefix
`(append '(,fname)
(calc-top-list-n ,(nth 1 inter))
(and n
(list
(math-normalize
(prefix-numeric-value n)))))
`(cons ',fname
(calc-top-list-n
,(if hasmulti
'n
(nth 1 inter)))))))))
`(defun ,(intern (concat "calc-" (symbol-name func))) ,clargs
,@doc
,inter
(calc-wrapper ,@body))))
(defun ,fname ,clargs
,@doc
,@(math-do-arg-list-check args nil nil)
,@body))))
(defun math-clean-arg (arg)
(if (consp arg)
@ -1887,56 +1861,42 @@ Redefine the corresponding command."
(list (cons 'and
(cons var
(if (cdr chk)
(setq chk (list (cons 'progn chk)))
`((progn ,@chk))
chk)))))
(and (consp arg)
(let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
(qual (car arg))
(qqual (list 'quote qual))
(qual-name (symbol-name qual))
(chk (intern (concat "math-check-" qual-name))))
(if (fboundp chk)
(append rest
(list
(when (consp arg)
(let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
(qual (car arg))
(qual-name (symbol-name qual))
(chk (intern (concat "math-check-" qual-name))))
(if (fboundp chk)
(append rest
(if is-rest
`((setq ,var (mapcar ',chk ,var)))
`((setq ,var (,chk ,var)))))
(if (fboundp (setq chk (intern (concat "math-" qual-name))))
(append rest
(if is-rest
`((mapcar #'(lambda (x)
(or (,chk x)
(math-reject-arg x ',qual)))
,var))
`((or (,chk ,var)
(math-reject-arg ,var ',qual)))))
(if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
(fboundp (setq chk (intern
(concat "math-"
(math-match-substring
qual-name 1))))))
(append rest
(if is-rest
(list 'setq var
(list 'mapcar (list 'quote chk) var))
(list 'setq var (list chk var)))))
(if (fboundp (setq chk (intern (concat "math-" qual-name))))
(append rest
(list
(if is-rest
(list 'mapcar
(list 'function
(list 'lambda '(x)
(list 'or
(list chk 'x)
(list 'math-reject-arg
'x qqual))))
var)
(list 'or
(list chk var)
(list 'math-reject-arg var qqual)))))
(if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
(fboundp (setq chk (intern
(concat "math-"
(math-match-substring
qual-name 1))))))
(append rest
(list
(if is-rest
(list 'mapcar
(list 'function
(list 'lambda '(x)
(list 'and
(list chk 'x)
(list 'math-reject-arg
'x qqual))))
var)
(list 'and
(list chk var)
(list 'math-reject-arg var qqual)))))
(error "Unknown qualifier `%s'" qual-name))))))))
`((mapcar #'(lambda (x)
(and (,chk x)
(math-reject-arg x ',qual)))
,var))
`((and
(,chk ,var)
(math-reject-arg ,var ',qual)))))
(error "Unknown qualifier `%s'" qual-name))))))))
(defun math-do-arg-list-check (args is-opt is-rest)
(cond ((null args) nil)
@ -1980,7 +1940,7 @@ Redefine the corresponding command."
(defun math-define-function-body (body env)
(let ((body (math-define-body body env)))
(if (math-body-refers-to body 'math-return)
(list (cons 'catch (cons '(quote math-return) body)))
`((catch 'math-return ,@body))
body)))
;; The variable math-exp-env is local to math-define-body, but is

20
lisp/calc/calc-rewr.el
View File

@ -1439,21 +1439,19 @@
(put 'calcFunc-vxor 'math-rewrite-default '(vec))
(defmacro math-rwfail (&optional back)
(list 'setq 'pc
(list 'and
(if back
'(setq btrack (cdr btrack))
'btrack)
''((backtrack)))))
`(setq pc (and ,(if back
'(setq btrack (cdr btrack))
'btrack)
'((backtrack)))))
;; This monstrosity is necessary because the use of static vectors of
;; registers makes rewrite rules non-reentrant. Yucko!
(defmacro math-rweval (form)
(list 'let '((orig (car rules)))
'(setcar rules (quote (nil nil nil no-phase)))
(list 'unwind-protect
form
'(setcar rules orig))))
`(let ((orig (car rules)))
(setcar rules '(nil nil nil no-phase))
(unwind-protect
,form
(setcar rules orig))))
(defvar math-rewrite-phase 1)

27
lisp/calc/calcalg2.el
View File

@ -667,21 +667,18 @@
(defvar math-integral-limit)
(defmacro math-tracing-integral (&rest parts)
(list 'and
'trace-buffer
(list 'with-current-buffer
'trace-buffer
'(goto-char (point-max))
(list 'and
'(bolp)
'(insert (make-string (- math-integral-limit
math-integ-level) 32)
(format "%2d " math-integ-depth)
(make-string math-integ-level 32)))
;;(list 'condition-case 'err
(cons 'insert parts)
;; '(error (insert (prin1-to-string err))))
'(sit-for 0))))
`(and trace-buffer
(with-current-buffer trace-buffer
(goto-char (point-max))
(and (bolp)
(insert (make-string (- math-integral-limit
math-integ-level) 32)
(format "%2d " math-integ-depth)
(make-string math-integ-level 32)))
;;(condition-case err
(insert ,@parts)
;; (error (insert (prin1-to-string err))))
(sit-for 0))))
;;; The following wrapper caches results and avoids infinite recursion.
;;; Each cache entry is: ( A B ) Integral of A is B;

4
lisp/cedet/ChangeLog
View File

@ -1,3 +1,7 @@
2012-08-07 Andreas Schwab <schwab@linux-m68k.org>
* ede/base.el (ede-with-projectfile): Use backquote forms.
2012-07-29 Paul Eggert <eggert@cs.ucla.edu>
inaccessable -> inaccessible spelling fix (Bug#10052)

28
lisp/cedet/ede/base.el
View File

@ -285,22 +285,18 @@ All specific project types must derive from this project."
;;
(defmacro ede-with-projectfile (obj &rest forms)
"For the project in which OBJ resides, execute FORMS."
(list 'save-window-excursion
(list 'let* (list
(list 'pf
(list 'if (list 'obj-of-class-p
obj 'ede-target)
;; @todo -I think I can change
;; this to not need ede-load-project-file
;; but I'm not sure how to test well.
(list 'ede-load-project-file
(list 'oref obj 'path))
obj))
'(dbka (get-file-buffer (oref pf file))))
'(if (not dbka) (find-file (oref pf file))
(switch-to-buffer dbka))
(cons 'progn forms)
'(if (not dbka) (kill-buffer (current-buffer))))))
`(save-window-excursion
(let* ((pf (if (obj-of-class-p ,obj ede-target)
;; @todo -I think I can change
;; this to not need ede-load-project-file
;; but I'm not sure how to test well.
(ede-load-project-file (oref ,obj path))
,obj))
(dbka (get-file-buffer (oref pf file))))
(if (not dbka) (find-file (oref pf file))
(switch-to-buffer dbka))
,@forms
(if (not dbka) (kill-buffer (current-buffer))))))
(put 'ede-with-projectfile 'lisp-indent-function 1)
;;; The EDE persistent cache.

8
lisp/emulation/vip.el
View File

@ -307,10 +307,10 @@ If nil then it is bound to `delete-backward-char'."
(defmacro vip-loop (count body)
"(COUNT BODY) Execute BODY COUNT times."
(list 'let (list (list 'count count))
(list 'while (list '> 'count 0)
body
(list 'setq 'count (list '1- 'count)))))
`(let ((count ,count))
(while (> count 0)
,body
(setq count (1- count)))))
(defun vip-push-mark-silent (&optional location)
"Set mark at LOCATION (point, by default) and push old mark on mark ring.

2
lisp/info.el
View File

@ -2854,7 +2854,7 @@ N is the digit argument used to invoke this command."
(Info-extract-menu-node-name)))))
(defmacro Info-no-error (&rest body)
(list 'condition-case nil (cons 'progn (append body '(t))) '(error nil)))
`(condition-case nil (progn ,@body t) (error nil)))
(defun Info-next-preorder ()
"Go to the next subnode or the next node, or go up a level."

18
lisp/menu-bar.el
View File

@ -637,11 +637,11 @@ FNAME is the minor mode's name (variable and function).
DOC is the text to use for the menu entry.
HELP is the text to use for the tooltip.
PROPS are additional properties."
`(list 'menu-item ,doc ',fname
,@(mapcar (lambda (p) (list 'quote p)) props)
:help ,help
:button '(:toggle . (and (default-boundp ',fname)
(default-value ',fname)))))
`'(menu-item ,doc ,fname
,@props
:help ,help
:button (:toggle . (and (default-boundp ',fname)
(default-value ',fname)))))
(defmacro menu-bar-make-toggle (name variable doc message help &rest body)
`(progn
@ -664,10 +664,10 @@ by \"Save Options\" in Custom buffers.")
;; a candidate for "Save Options", and we do not want to save options
;; the user have already set explicitly in his init file.
(if interactively (customize-mark-as-set ',variable)))
(list 'menu-item ,doc ',name
:help ,help
:button '(:toggle . (and (default-boundp ',variable)
(default-value ',variable))))))
'(menu-item ,doc ,name
:help ,help
:button (:toggle . (and (default-boundp ',variable)
(default-value ',variable))))))
;; Function for setting/saving default font.

6
lisp/textmodes/artist.el
View File

@ -1790,7 +1790,7 @@ info-variant-part."
;;
(defmacro artist-funcall (fn &rest args)
"Call function FN with ARGS, if FN is not nil."
(list 'if fn (cons 'funcall (cons fn args))))
`(if ,fn (funcall ,fn ,@args)))
(defun artist-uniq (l)
"Remove consecutive duplicates in list L. Comparison is done with `equal'."
@ -2384,8 +2384,8 @@ in the coord."
;;
(defmacro artist-put-pixel (point-list x y)
"In POINT-LIST, store a ``pixel'' at coord X,Y."
(list 'setq point-list
(list 'append point-list (list 'list (list 'artist-new-coord x y)))))
`(setq ,point-list
(append ,point-list (list (artist-new-coord ,x ,y)))))
;; Calculate list of points using eight point algorithm
;; return a list of coords