diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-macs.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 294 |
1 files changed, 161 insertions, 133 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 3e800c53008..76f677c6198 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -6,6 +6,7 @@ ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -128,6 +129,12 @@ (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) (defun cl-expr-access-order (x v) + ;; This apparently tries to return nil iff the expression X evaluates + ;; the variables V in the same order as they appear in V (so as to + ;; be able to replace those vars with the expressions they're bound + ;; to). + ;; FIXME: This is very naive, it doesn't even check to see if those + ;; variables appear more than once. (if (cl-const-expr-p x) v (if (consp x) (progn @@ -632,7 +639,7 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "loop" macro. -(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars) +(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars) (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) (defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag) (defvar loop-initially) (defvar loop-map-form) (defvar loop-name) @@ -640,7 +647,7 @@ This is compatible with Common Lisp, but note that `defun' and (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) ;;;###autoload -(defmacro loop (&rest args) +(defmacro loop (&rest loop-args) "The Common Lisp `loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, @@ -655,8 +662,8 @@ Valid clauses are: finally return EXPR, named NAME. \(fn CLAUSE...)" - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args)))))) - (list 'block nil (list* 'while t args)) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args)))))) + (list 'block nil (list* 'while t loop-args)) (let ((loop-name nil) (loop-bindings nil) (loop-body nil) (loop-steps nil) (loop-result nil) (loop-result-explicit nil) @@ -665,8 +672,8 @@ Valid clauses are: (loop-initially nil) (loop-finally nil) (loop-map-form nil) (loop-first-flag nil) (loop-destr-temps nil) (loop-symbol-macs nil)) - (setq args (append args '(cl-end-loop))) - (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) + (setq loop-args (append loop-args '(cl-end-loop))) + (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) (if loop-finish-flag (push `((,loop-finish-flag t)) loop-bindings)) (if loop-first-flag @@ -706,34 +713,34 @@ Valid clauses are: (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) (list* 'block loop-name body))))) -(defun cl-parse-loop-clause () ; uses args, loop-* - (let ((word (pop args)) +(defun cl-parse-loop-clause () ; uses loop-* + (let ((word (pop loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs key-binding key-bindings))) (cond - ((null args) + ((null loop-args) (error "Malformed `loop' macro")) ((eq word 'named) - (setq loop-name (pop args))) + (setq loop-name (pop loop-args))) ((eq word 'initially) - (if (memq (car args) '(do doing)) (pop args)) - (or (consp (car args)) (error "Syntax error on `initially' clause")) - (while (consp (car args)) - (push (pop args) loop-initially))) + (if (memq (car loop-args) '(do doing)) (pop loop-args)) + (or (consp (car loop-args)) (error "Syntax error on `initially' clause")) + (while (consp (car loop-args)) + (push (pop loop-args) loop-initially))) ((eq word 'finally) - (if (eq (car args) 'return) - (setq loop-result-explicit (or (cl-pop2 args) '(quote nil))) - (if (memq (car args) '(do doing)) (pop args)) - (or (consp (car args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar args) 'return) (null loop-name)) - (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil))) - (while (consp (car args)) - (push (pop args) loop-finally))))) + (if (eq (car loop-args) 'return) + (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil))) + (if (memq (car loop-args) '(do doing)) (pop loop-args)) + (or (consp (car loop-args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar loop-args) 'return) (null loop-name)) + (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil))) + (while (consp (car loop-args)) + (push (pop loop-args) loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) @@ -742,29 +749,29 @@ Valid clauses are: ;; Use `gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because ;; these vars get added to the cl-macro-environment. - (let ((var (or (pop args) (gensym "--cl-var--")))) - (setq word (pop args)) - (if (eq word 'being) (setq word (pop args))) - (if (memq word '(the each)) (setq word (pop args))) + (let ((var (or (pop loop-args) (gensym "--cl-var--")))) + (setq word (pop loop-args)) + (if (eq word 'being) (setq word (pop loop-args))) + (if (memq word '(the each)) (setq word (pop loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in args (cons '(buffer-list) args))) + (setq word 'in loop-args (cons '(buffer-list) loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto above below by)) - (push word args) - (if (memq (car args) '(downto above)) + (push word loop-args) + (if (memq (car loop-args) '(downto above)) (error "Must specify `from' value for downward loop")) - (let* ((down (or (eq (car args) 'downfrom) - (memq (caddr args) '(downto above)))) - (excl (or (memq (car args) '(above below)) - (memq (caddr args) '(above below)))) - (start (and (memq (car args) '(from upfrom downfrom)) - (cl-pop2 args))) - (end (and (memq (car args) + (let* ((down (or (eq (car loop-args) 'downfrom) + (memq (caddr loop-args) '(downto above)))) + (excl (or (memq (car loop-args) '(above below)) + (memq (caddr loop-args) '(above below)))) + (start (and (memq (car loop-args) '(from upfrom downfrom)) + (cl-pop2 loop-args))) + (end (and (memq (car loop-args) '(to upto downto above below)) - (cl-pop2 args))) - (step (and (eq (car args) 'by) (cl-pop2 args))) + (cl-pop2 loop-args))) + (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args))) (end-var (and (not (cl-const-expr-p end)) (make-symbol "--cl-var--"))) (step-var (and (not (cl-const-expr-p step)) @@ -787,7 +794,7 @@ Valid clauses are: (let* ((on (eq word 'on)) (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) - (push (list temp (pop args)) loop-for-bindings) + (push (list temp (pop loop-args)) loop-for-bindings) (push (list 'consp temp) loop-body) (if (eq word 'in-ref) (push (list var (list 'car temp)) loop-symbol-macs) @@ -797,8 +804,8 @@ Valid clauses are: (push (list var (if on temp (list 'car temp))) loop-for-sets)))) (push (list temp - (if (eq (car args) 'by) - (let ((step (cl-pop2 args))) + (if (eq (car loop-args) 'by) + (let ((step (cl-pop2 loop-args))) (if (and (memq (car-safe step) '(quote function function*)) @@ -809,10 +816,10 @@ Valid clauses are: loop-for-steps))) ((eq word '=) - (let* ((start (pop args)) - (then (if (eq (car args) 'then) (cl-pop2 args) start))) + (let* ((start (pop loop-args)) + (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start))) (push (list var nil) loop-for-bindings) - (if (or ands (eq (car args) 'and)) + (if (or ands (eq (car loop-args) 'and)) (progn (push `(,var (if ,(or loop-first-flag @@ -832,7 +839,7 @@ Valid clauses are: ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop args)) loop-for-bindings) + (push (list temp-vec (pop loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push (list '< (list 'setq temp-idx (list '1+ temp-idx)) (list 'length temp-vec)) loop-body) @@ -844,15 +851,15 @@ Valid clauses are: loop-for-sets)))) ((memq word '(element elements)) - (let ((ref (or (memq (car args) '(in-ref of-ref)) - (and (not (memq (car args) '(in of))) + (let ((ref (or (memq (car loop-args) '(in-ref of-ref)) + (and (not (memq (car loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 args)) + (seq (cl-pop2 loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (eq (caadr args) 'index)) - (cadr (cl-pop2 args)) + (temp-idx (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (eq (caadr loop-args) 'index)) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) @@ -878,13 +885,13 @@ Valid clauses are: loop-for-steps))) ((memq word hash-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) hash-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) + (or (memq (car loop-args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 loop-args)) + (other (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (memq (caadr loop-args) hash-types) + (not (eq (caadr loop-args) word))) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) @@ -894,16 +901,16 @@ Valid clauses are: ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) - (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) + (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))) (setq loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) - (while (memq (car args) '(in of from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) + (while (memq (car loop-args) '(in of from to)) + (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) + ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) + (t (setq buf (cl-pop2 loop-args))))) (setq loop-map-form `(cl-map-extents (lambda (,var ,(make-symbol "--cl-var--")) @@ -914,12 +921,12 @@ Valid clauses are: (let ((buf nil) (prop nil) (from nil) (to nil) (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) - (while (memq (car args) '(in of property from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - ((eq (car args) 'property) - (setq prop (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) + (while (memq (car loop-args) '(in of property from to)) + (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) + ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) + ((eq (car loop-args) 'property) + (setq prop (cl-pop2 loop-args))) + (t (setq buf (cl-pop2 loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) (push (list var (list 'cons var1 var2)) loop-for-sets)) @@ -929,13 +936,13 @@ Valid clauses are: ,buf ,prop ,from ,to)))) ((memq word key-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let ((map (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) key-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) + (or (memq (car loop-args) '(in of)) (error "Expected `of'")) + (let ((map (cl-pop2 loop-args)) + (other (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (memq (caadr loop-args) key-types) + (not (eq (caadr loop-args) word))) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) @@ -957,7 +964,7 @@ Valid clauses are: loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) + (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))) (temp (make-symbol "--cl-var--"))) (push (list var (if scr (list 'frame-selected-window scr) @@ -975,9 +982,9 @@ Valid clauses are: (if handler (funcall handler var) (error "Expected a `for' preposition, found %s" word))))) - (eq (car args) 'and)) + (eq (car loop-args) 'and)) (setq ands t) - (pop args)) + (pop loop-args)) (if (and ands loop-for-bindings) (push (nreverse loop-for-bindings) loop-bindings) (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) @@ -993,11 +1000,11 @@ Valid clauses are: ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop args))) loop-bindings) + (push (list (list temp (pop loop-args))) loop-bindings) (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) ((memq word '(collect collecting)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil 'nreverse))) (if (eq var loop-accum-var) (push (list 'progn (list 'push what var) t) loop-body) @@ -1006,7 +1013,7 @@ Valid clauses are: t) loop-body)))) ((memq word '(nconc nconcing append appending)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil 'nreverse))) (push (list 'progn (list 'setq var @@ -1021,27 +1028,27 @@ Valid clauses are: var what))) t) loop-body))) ((memq word '(concat concating)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum ""))) (push (list 'progn (list 'callf 'concat var what) t) loop-body))) ((memq word '(vconcat vconcating)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum []))) (push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) ((memq word '(sum summing)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list 'progn (list 'incf var what) t) loop-body))) ((memq word '(count counting)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop args)) + (let* ((what (pop loop-args)) (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) (var (cl-loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) @@ -1052,27 +1059,27 @@ Valid clauses are: ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop args) - (and (eq (car args) '=) (cl-pop2 args))) + (while (progn (push (list (pop loop-args) + (and (eq (car loop-args) '=) (cl-pop2 loop-args))) bindings) - (eq (car args) 'and)) - (pop args)) + (eq (car loop-args) 'and)) + (pop loop-args)) (push (nreverse bindings) loop-bindings))) ((eq word 'while) - (push (pop args) loop-body)) + (push (pop loop-args) loop-body)) ((eq word 'until) - (push (list 'not (pop args)) loop-body)) + (push (list 'not (pop loop-args)) loop-body)) ((eq word 'always) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (pop args)) loop-body) + (push (list 'setq loop-finish-flag (pop loop-args)) loop-body) (setq loop-result t)) ((eq word 'never) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (list 'not (pop args))) + (push (list 'setq loop-finish-flag (list 'not (pop loop-args))) loop-body) (setq loop-result t)) @@ -1080,20 +1087,20 @@ Valid clauses are: (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) (push (list 'setq loop-finish-flag - (list 'not (list 'setq loop-result-var (pop args)))) + (list 'not (list 'setq loop-result-var (pop loop-args)))) loop-body)) ((memq word '(if when unless)) - (let* ((cond (pop args)) + (let* ((cond (pop loop-args)) (then (let ((loop-body nil)) (cl-parse-loop-clause) (cl-loop-build-ands (nreverse loop-body)))) (else (let ((loop-body nil)) - (if (eq (car args) 'else) - (progn (pop args) (cl-parse-loop-clause))) + (if (eq (car loop-args) 'else) + (progn (pop loop-args) (cl-parse-loop-clause))) (cl-loop-build-ands (nreverse loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car args) 'end) (pop args)) + (if (eq (car loop-args) 'end) (pop loop-args)) (if (eq word 'unless) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) @@ -1107,22 +1114,22 @@ Valid clauses are: ((memq word '(do doing)) (let ((body nil)) - (or (consp (car args)) (error "Syntax error on `do' clause")) - (while (consp (car args)) (push (pop args) body)) + (or (consp (car loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car loop-args)) (push (pop loop-args) body)) (push (cons 'progn (nreverse (cons t body))) loop-body))) ((eq word 'return) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--"))) (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push (list 'setq loop-result-var (pop args) + (push (list 'setq loop-result-var (pop loop-args) loop-finish-flag nil) loop-body)) (t (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) (or handler (error "Expected a loop keyword, found %s" word)) (funcall handler)))) - (if (eq (car args) 'and) - (progn (pop args) (cl-parse-loop-clause))))) + (if (eq (car loop-args) 'and) + (progn (pop loop-args) (cl-parse-loop-clause))))) (defun cl-loop-let (specs body par) ; uses loop-* (let ((p specs) (temps nil) (new nil)) @@ -1158,9 +1165,9 @@ Valid clauses are: (list* (if par 'let 'let*) (nconc (nreverse temps) (nreverse new)) body)))) -(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-* - (if (eq (car args) 'into) - (let ((var (cl-pop2 args))) +(defun cl-loop-handle-accum (def &optional func) ; uses loop-* + (if (eq (car loop-args) 'into) + (let ((var (cl-pop2 loop-args))) (or (memq var loop-accum-vars) (progn (push (list (list var def)) loop-bindings) (push var loop-accum-vars))) @@ -1741,15 +1748,6 @@ Example: (defsetf default-file-modes set-default-file-modes t) (defsetf default-value set-default) (defsetf documentation-property put) -(defsetf extent-data set-extent-data) -(defsetf extent-face set-extent-face) -(defsetf extent-priority set-extent-priority) -(defsetf extent-end-position (ext) (store) - (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) - store) store)) -(defsetf extent-start-position (ext) (store) - (list 'progn (list 'set-extent-endpoints store - (list 'extent-end-position ext)) store)) (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) (defsetf face-background-pixmap (f &optional s) (x) (list 'set-face-background-pixmap f x s)) @@ -1763,6 +1761,7 @@ Example: (defsetf frame-visible-p cl-set-frame-visible-p) (defsetf frame-width set-screen-width t) (defsetf frame-parameter set-frame-parameter t) +(defsetf terminal-parameter set-terminal-parameter) (defsetf getenv setenv t) (defsetf get-register set-register) (defsetf global-key-binding global-set-key) @@ -1806,19 +1805,34 @@ Example: (defsetf window-height () (store) (list 'progn (list 'enlarge-window (list '- store '(window-height))) store)) (defsetf window-hscroll set-window-hscroll) +(defsetf window-parameter set-window-parameter) (defsetf window-point set-window-point) (defsetf window-start set-window-start) (defsetf window-width () (store) (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) -(defsetf x-get-cutbuffer x-store-cutbuffer t) -(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. (defsetf x-get-secondary-selection x-own-secondary-selection t) (defsetf x-get-selection x-own-selection t) +;; This is a hack that allows (setf (eq a 7) B) to mean either +;; (setq a 7) or (setq a nil) depending on whether B is nil or not. +;; This is useful when you have control over the PLACE but not over +;; the VALUE, as is the case in define-minor-mode's :variable. +(define-setf-method eq (place val) + (let ((method (get-setf-method place cl-macro-environment)) + (val-temp (make-symbol "--eq-val--")) + (store-temp (make-symbol "--eq-store--"))) + (list (append (nth 0 method) (list val-temp)) + (append (nth 1 method) (list val)) + (list store-temp) + `(let ((,(car (nth 2 method)) + (if ,store-temp ,val-temp (not ,val-temp)))) + ,(nth 3 method) ,store-temp) + `(eq ,(nth 4 method) ,val-temp)))) + ;;; More complex setf-methods. -;;; These should take &environment arguments, but since full arglists aren't -;;; available while compiling cl-macs, we fake it by referring to the global -;;; variable cl-macro-environment directly. +;; These should take &environment arguments, but since full arglists aren't +;; available while compiling cl-macs, we fake it by referring to the global +;; variable cl-macro-environment directly. (define-setf-method apply (func arg1 &rest rest) (or (and (memq (car-safe func) '(quote function function*)) @@ -2616,21 +2630,36 @@ surrounded by (block NAME ...). (cons '&cl-quote args)) (list* 'cl-defsubst-expand (list 'quote argns) (list 'quote (list* 'block name body)) - (not (or unsafe (cl-expr-access-order pbody argns))) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil (and (memq '&key args) 'cl-whole) unsafe argns))) (list* 'defun* name args 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 (delq nil - (mapcar* (function - (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (setq body (subst argv argn body)) - (and unsafe (list argn argv))) - (list argn argv)))) - argns argvs)))) + (let* ((substs ()) + (lets (delq nil + (mapcar* (function + (lambda (argn argv) + (if (or simple (cl-const-expr-p argv)) + (progn (push (cons argn argv) substs) + (and unsafe (list argn argv))) + (list argn argv)))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (subst (cdar substs) (caar substs) body)) + (t (sublis substs body)))) (if lets (list 'let lets body) body)))) @@ -2753,5 +2782,4 @@ surrounded by (block NAME ...). ;; generated-autoload-file: "cl-loaddefs.el" ;; End: -;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 ;;; cl-macs.el ends here |