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.
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.
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
(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]
(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)
(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)
(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
(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)
(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;
+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)
;;
(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.
(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.
(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."
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
;; 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.
;;
(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'."
;;
(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
projects / emacs.git / commitdiff