* bug#11038: 24.0.94; 24.0.94; cl loop macroexpand fails with (wrong-type-argument listp emacs)
@ 2012-03-17 22:27 Christopher Schmidt
2012-03-18 1:37 ` Stefan Monnier
0 siblings, 1 reply; 4+ messages in thread
From: Christopher Schmidt @ 2012-03-17 22:27 UTC (permalink / raw)
To: 11038
[-- Attachment #1: Type: text/plain, Size: 276 bytes --]
Hi,
I think I hit on a bug in GNU Emacs 24.0.94.1 (x86_64-unknown-linux-gnu,
GTK+ Version 2.24.10) of 2012-03-11. This cl loop is not parsed
correctly.
(loop for rms in nil
when t
do (loop for (gnu . emacs) in nil)
end)
Backtrace when evaling this form:
[-- Attachment #2: backtrace --]
[-- Type: text/plain, Size: 22307 bytes --]
Debugger entered--Lisp error: (wrong-type-argument listp emacs)
cdr(emacs)
(setq x (cdr x))
(prog1 x (setq x (cdr x)))
(car (prog1 x (setq x (cdr x))))
(pop x)
(cl-expr-contains (pop x) y)
(or (cl-expr-contains (pop x) y) 0)
(+ sum (or (cl-expr-contains (pop x) y) 0))
(setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))
(while x (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
(let ((sum 0)) (while x (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) (and (> sum 0) sum))
(cond ((equal y x) 1) ((and (consp x) (not (memq (car-safe x) (quote (quote function function*))))) (let ((sum 0)) (while x (setq sum (+ sum (or (cl-expr-contains ... y) 0)))) (and (> sum 0) sum))) (t nil))
cl-expr-contains((gnu . emacs) it)
(or (cl-expr-contains (pop x) y) 0)
(+ sum (or (cl-expr-contains (pop x) y) 0))
(setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))
(while x (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
(let ((sum 0)) (while x (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) (and (> sum 0) sum))
(cond ((equal y x) 1) ((and (consp x) (not (memq (car-safe x) (quote (quote function function*))))) (let ((sum 0)) (while x (setq sum (+ sum (or (cl-expr-contains ... y) 0)))) (and (> sum 0) sum))) (t nil))
cl-expr-contains((loop for (gnu . emacs) in nil) it)
(or (cl-expr-contains (pop x) y) 0)
(+ sum (or (cl-expr-contains (pop x) y) 0))
(setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))
(while x (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
(let ((sum 0)) (while x (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) (and (> sum 0) sum))
(cond ((equal y x) 1) ((and (consp x) (not (memq (car-safe x) (quote (quote function function*))))) (let ((sum 0)) (while x (setq sum (+ sum (or (cl-expr-contains ... y) 0)))) (and (> sum 0) sum))) (t nil))
cl-expr-contains((progn (loop for (gnu . emacs) in nil)) it)
(or (cl-expr-contains (pop x) y) 0)
(+ sum (or (cl-expr-contains (pop x) y) 0))
(setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))
(while x (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
(let ((sum 0)) (while x (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) (and (> sum 0) sum))
(cond ((equal y x) 1) ((and (consp x) (not (memq (car-safe x) (quote (quote function function*))))) (let ((sum 0)) (while x (setq sum (+ sum (or (cl-expr-contains ... y) 0)))) (and (> sum 0) sum))) (t nil))
cl-expr-contains(((progn (loop for (gnu . emacs) in nil))) it)
(if (cl-expr-contains form (quote it)) (let ((temp (make-symbol "--cl-var--"))) (push (list temp) loop-bindings) (setq form (list* (quote if) (list (quote setq) temp cond) (subst temp (quote it) form)))) (setq form (list* (quote if) cond form)))
(let ((form (cons (if simple (cons (quote progn) (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) (if (cl-expr-contains form (quote it)) (let ((temp (make-symbol "--cl-var--"))) (push (list temp) loop-bindings) (setq form (list* (quote if) (list (quote setq) temp cond) (subst temp (quote it) form)))) (setq form (list* (quote if) cond form))) (push (if simple (list (quote progn) form t) form) loop-body))
(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 loop-args) (quote 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 loop-args) (quote end)) (pop loop-args)) (if (eq word (quote unless)) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons (quote progn) (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) (if (cl-expr-contains form (quote it)) (let ((temp (make-symbol "--cl-var--"))) (push (list temp) loop-bindings) (setq form (list* (quote if) (list (quote setq) temp cond) (subst temp (quote it) form)))) (setq form (list* (quote if) cond form))) (push (if simple (list (quote progn) form t) form) loop-body)))
(cond ((null loop-args) (error "Malformed `loop' macro")) ((eq word (quote named)) (setq loop-name (pop loop-args))) ((eq word (quote initially)) (if (memq (car loop-args) (quote (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 (quote finally)) (if (eq (car loop-args) (quote return)) (setq loop-result-explicit (or (cl-pop2 loop-args) (quote (quote nil)))) (if (memq (car loop-args) (quote (do doing))) (pop loop-args)) (or (consp (car loop-args)) (error "Syntax error on `finally' clause")) (if (and (eq (caar loop-args) (quote return)) (null loop-name)) (setq loop-result-explicit (or (nth 1 (pop loop-args)) (quote (quote nil)))) (while (consp (car loop-args)) (push (pop loop-args) loop-finally))))) ((memq word (quote (for as))) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) (ands nil)) (while (let ((var (or ... ...))) (setq word (pop loop-args)) (if (eq word (quote being)) (setq word (pop loop-args))) (if (memq word (quote ...)) (setq word (pop loop-args))) (if (memq word (quote ...)) (setq word (quote in) loop-args (cons ... loop-args))) (cond ((memq word ...) (push word loop-args) (if ... ...) (let* ... ... ... ... ... ... ...)) ((memq word ...) (let* ... ... ... ... ...)) ((eq word ...) (let* ... ... ...)) ((memq word ...) (let ... ... ... ... ...)) ((memq word ...) (let ... ... ... ... ...)) ((memq word hash-types) (or ... ...) (let* ... ... ...)) ((memq word ...) (let ... ...)) ((memq word ...) (let ... ... ...)) ((memq word ...) (let ... ... ... ...)) ((memq word key-types) (or ... ...) (let ... ... ...)) ((memq word ...) (let ... ... ... ... ...)) ((memq word ...) (let ... ... ... ... ... ...)) (t (let ... ...))) (eq (car loop-args) (quote and))) (setq ands t) (pop loop-args)) (if (and ands loop-for-bindings) (push (nreverse loop-for-bindings) loop-bindings) (setq loop-bindings (nconc (mapcar (quote list) loop-for-bindings) loop-bindings))) (if loop-for-sets (push (list (quote progn) (cl-loop-let (nreverse loop-for-sets) (quote setq) ands) t) loop-body)) (if loop-for-steps (push (cons (if ands (quote psetq) (quote setq)) (apply (quote append) (nreverse loop-for-steps))) loop-steps)))) ((eq word (quote repeat)) (let ((temp (make-symbol "--cl-var--"))) (push (list (list temp (pop loop-args))) loop-bindings) (push (list (quote >=) (list (quote setq) temp (list (quote 1-) temp)) 0) loop-body))) ((memq word (quote (collect collecting))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil (quote nreverse)))) (if (eq var loop-accum-var) (push (list (quote progn) (list (quote push) what var) t) loop-body) (push (list (quote progn) (list (quote setq) var (list ... var ...)) t) loop-body)))) ((memq word (quote (nconc nconcing append appending))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil (quote nreverse)))) (push (list (quote progn) (list (quote setq) var (if (eq var loop-accum-var) (list ... ... var) (list ... var what))) t) loop-body))) ((memq word (quote (concat concating))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum ""))) (push (list (quote progn) (list (quote callf) (quote concat) var what) t) loop-body))) ((memq word (quote (vconcat vconcating))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum []))) (push (list (quote progn) (list (quote callf) (quote vconcat) var what) t) loop-body))) ((memq word (quote (sum summing))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list (quote progn) (list (quote incf) var what) t) loop-body))) ((memq word (quote (count counting))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list (quote progn) (list (quote if) what (list (quote incf) var)) t) loop-body))) ((memq word (quote (minimize minimizing maximize maximizing))) (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))) (set (list (quote setq) var (list (quote if) var (list func var temp) temp)))) (push (list (quote progn) (if (eq temp what) set (list (quote let) (list ...) set)) t) loop-body))) ((eq word (quote with)) (let ((bindings nil)) (while (progn (push (list (pop loop-args) (and ... ...)) bindings) (eq (car loop-args) (quote and))) (pop loop-args)) (push (nreverse bindings) loop-bindings))) ((eq word (quote while)) (push (pop loop-args) loop-body)) ((eq word (quote until)) (push (list (quote not) (pop loop-args)) loop-body)) ((eq word (quote always)) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (push (list (quote setq) loop-finish-flag (pop loop-args)) loop-body) (setq loop-result t)) ((eq word (quote never)) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (push (list (quote setq) loop-finish-flag (list (quote not) (pop loop-args))) loop-body) (setq loop-result t)) ((eq word (quote thereis)) (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 (quote setq) loop-finish-flag (list (quote not) (list (quote setq) loop-result-var (pop loop-args)))) loop-body)) ((memq word (quote (if when unless))) (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 ... ...) (progn ... ...)) (cl-loop-build-ands (nreverse loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) (if (eq (car loop-args) (quote end)) (pop loop-args)) (if (eq word (quote unless)) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple ... ...) (if simple ... ...)))) (if (cl-expr-contains form (quote it)) (let ((temp ...)) (push (list temp) loop-bindings) (setq form (list* ... ... ...))) (setq form (list* (quote if) cond form))) (push (if simple (list (quote progn) form t) form) loop-body)))) ((memq word (quote (do doing))) (let ((body nil)) (or (consp (car loop-args)) (error "Syntax error on `do' clause")) (while (consp (car loop-args)) (push (pop loop-args) body)) (push (cons (quote progn) (nreverse (cons t body))) loop-body))) ((eq word (quote 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 (quote setq) loop-result-var (pop loop-args) loop-finish-flag nil) loop-body)) (t (let ((handler (and (symbolp word) (get word (quote cl-loop-handler))))) (or handler (error "Expected a loop keyword, found %s" word)) (funcall handler))))
(let ((word (pop loop-args)) (hash-types (quote (hash-key hash-keys hash-value hash-values))) (key-types (quote (key-code key-codes key-seq key-seqs key-binding key-bindings)))) (cond ((null loop-args) (error "Malformed `loop' macro")) ((eq word (quote named)) (setq loop-name (pop loop-args))) ((eq word (quote initially)) (if (memq (car loop-args) (quote (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 (quote finally)) (if (eq (car loop-args) (quote return)) (setq loop-result-explicit (or (cl-pop2 loop-args) (quote (quote nil)))) (if (memq (car loop-args) (quote (do doing))) (pop loop-args)) (or (consp (car loop-args)) (error "Syntax error on `finally' clause")) (if (and (eq (caar loop-args) (quote return)) (null loop-name)) (setq loop-result-explicit (or (nth 1 ...) (quote ...))) (while (consp (car loop-args)) (push (pop loop-args) loop-finally))))) ((memq word (quote (for as))) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) (ands nil)) (while (let ((var ...)) (setq word (pop loop-args)) (if (eq word ...) (setq word ...)) (if (memq word ...) (setq word ...)) (if (memq word ...) (setq word ... loop-args ...)) (cond (... ... ... ...) (... ...) (... ...) (... ...) (... ...) (... ... ...) (... ...) (... ...) (... ...) (... ... ...) (... ...) (... ...) (t ...)) (eq (car loop-args) (quote and))) (setq ands t) (pop loop-args)) (if (and ands loop-for-bindings) (push (nreverse loop-for-bindings) loop-bindings) (setq loop-bindings (nconc (mapcar ... loop-for-bindings) loop-bindings))) (if loop-for-sets (push (list (quote progn) (cl-loop-let ... ... ands) t) loop-body)) (if loop-for-steps (push (cons (if ands ... ...) (apply ... ...)) loop-steps)))) ((eq word (quote repeat)) (let ((temp (make-symbol "--cl-var--"))) (push (list (list temp (pop loop-args))) loop-bindings) (push (list (quote >=) (list (quote setq) temp (list ... temp)) 0) loop-body))) ((memq word (quote (collect collecting))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil (quote nreverse)))) (if (eq var loop-accum-var) (push (list (quote progn) (list ... what var) t) loop-body) (push (list (quote progn) (list ... var ...) t) loop-body)))) ((memq word (quote (nconc nconcing append appending))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil (quote nreverse)))) (push (list (quote progn) (list (quote setq) var (if ... ... ...)) t) loop-body))) ((memq word (quote (concat concating))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum ""))) (push (list (quote progn) (list (quote callf) (quote concat) var what) t) loop-body))) ((memq word (quote (vconcat vconcating))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum []))) (push (list (quote progn) (list (quote callf) (quote vconcat) var what) t) loop-body))) ((memq word (quote (sum summing))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list (quote progn) (list (quote incf) var what) t) loop-body))) ((memq word (quote (count counting))) (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list (quote progn) (list (quote if) what (list ... var)) t) loop-body))) ((memq word (quote (minimize minimizing maximize maximizing))) (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 ... 0 3))) (set (list (quote setq) var (list ... var ... temp)))) (push (list (quote progn) (if (eq temp what) set (list ... ... set)) t) loop-body))) ((eq word (quote with)) (let ((bindings nil)) (while (progn (push (list ... ...) bindings) (eq (car loop-args) (quote and))) (pop loop-args)) (push (nreverse bindings) loop-bindings))) ((eq word (quote while)) (push (pop loop-args) loop-body)) ((eq word (quote until)) (push (list (quote not) (pop loop-args)) loop-body)) ((eq word (quote always)) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (push (list (quote setq) loop-finish-flag (pop loop-args)) loop-body) (setq loop-result t)) ((eq word (quote never)) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (push (list (quote setq) loop-finish-flag (list (quote not) (pop loop-args))) loop-body) (setq loop-result t)) ((eq word (quote thereis)) (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 (quote setq) loop-finish-flag (list (quote not) (list (quote setq) loop-result-var (pop loop-args)))) loop-body)) ((memq word (quote (if when unless))) (let* ((cond (pop loop-args)) (then (let (...) (cl-parse-loop-clause) (cl-loop-build-ands ...))) (else (let (...) (if ... ...) (cl-loop-build-ands ...))) (simple (and (eq ... t) (eq ... t)))) (if (eq (car loop-args) (quote end)) (pop loop-args)) (if (eq word (quote unless)) (setq then (prog1 else (setq else then)))) (let ((form (cons ... ...))) (if (cl-expr-contains form (quote it)) (let (...) (push ... loop-bindings) (setq form ...)) (setq form (list* ... cond form))) (push (if simple (list ... form t) form) loop-body)))) ((memq word (quote (do doing))) (let ((body nil)) (or (consp (car loop-args)) (error "Syntax error on `do' clause")) (while (consp (car loop-args)) (push (pop loop-args) body)) (push (cons (quote progn) (nreverse (cons t body))) loop-body))) ((eq word (quote 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 (quote setq) loop-result-var (pop loop-args) loop-finish-flag nil) loop-body)) (t (let ((handler (and (symbolp word) (get word ...)))) (or handler (error "Expected a loop keyword, found %s" word)) (funcall handler)))) (if (eq (car loop-args) (quote and)) (progn (pop loop-args) (cl-parse-loop-clause))))
cl-parse-loop-clause()
(while (not (eq (car loop-args) (quote cl-end-loop))) (cl-parse-loop-clause))
(let ((loop-name nil) (loop-bindings nil) (loop-body nil) (loop-steps nil) (loop-result nil) (loop-result-explicit nil) (loop-result-var nil) (loop-finish-flag nil) (loop-accum-var nil) (loop-accum-vars nil) (loop-initially nil) (loop-finally nil) (loop-map-form nil) (loop-first-flag nil) (loop-destr-temps nil) (loop-symbol-macs nil)) (setq loop-args (append loop-args (quote (cl-end-loop)))) (while (not (eq (car loop-args) (quote cl-end-loop))) (cl-parse-loop-clause)) (if loop-finish-flag (push (\` (((\, loop-finish-flag) t))) loop-bindings)) (if loop-first-flag (progn (push (\` (((\, loop-first-flag) t))) loop-bindings) (push (\` (setq (\, loop-first-flag) nil)) loop-steps))) (let* ((epilogue (nconc (nreverse loop-finally) (list (or loop-result-explicit loop-result)))) (ands (cl-loop-build-ands (nreverse loop-body))) (while-body (nconc (cadr ands) (nreverse loop-steps))) (body (append (nreverse loop-initially) (list (if loop-map-form (list ... ... ...) (list* ... ... while-body))) (if loop-finish-flag (if (equal epilogue ...) (list loop-result-var) (\` ...)) epilogue)))) (if loop-result-var (push (list loop-result-var) loop-bindings)) (while loop-bindings (if (cdar loop-bindings) (setq body (list (cl-loop-let (pop loop-bindings) body t))) (let ((lets nil)) (while (and loop-bindings (not ...)) (push (car ...) lets)) (setq body (list (cl-loop-let lets body nil)))))) (if loop-symbol-macs (setq body (list (list* (quote symbol-macrolet) loop-symbol-macs body)))) (list* (quote block) loop-name body)))
(if (not (memq t (mapcar (quote symbolp) (delq nil (delq t (copy-list loop-args)))))) (list (quote block) nil (list* (quote while) t loop-args)) (let ((loop-name nil) (loop-bindings nil) (loop-body nil) (loop-steps nil) (loop-result nil) (loop-result-explicit nil) (loop-result-var nil) (loop-finish-flag nil) (loop-accum-var nil) (loop-accum-vars nil) (loop-initially nil) (loop-finally nil) (loop-map-form nil) (loop-first-flag nil) (loop-destr-temps nil) (loop-symbol-macs nil)) (setq loop-args (append loop-args (quote (cl-end-loop)))) (while (not (eq (car loop-args) (quote cl-end-loop))) (cl-parse-loop-clause)) (if loop-finish-flag (push (\` (((\, loop-finish-flag) t))) loop-bindings)) (if loop-first-flag (progn (push (\` ((... t))) loop-bindings) (push (\` (setq (\, loop-first-flag) nil)) loop-steps))) (let* ((epilogue (nconc (nreverse loop-finally) (list (or loop-result-explicit loop-result)))) (ands (cl-loop-build-ands (nreverse loop-body))) (while-body (nconc (cadr ands) (nreverse loop-steps))) (body (append (nreverse loop-initially) (list (if loop-map-form ... ...)) (if loop-finish-flag (if ... ... ...) epilogue)))) (if loop-result-var (push (list loop-result-var) loop-bindings)) (while loop-bindings (if (cdar loop-bindings) (setq body (list (cl-loop-let ... body t))) (let ((lets nil)) (while (and loop-bindings ...) (push ... lets)) (setq body (list ...))))) (if loop-symbol-macs (setq body (list (list* (quote symbol-macrolet) loop-symbol-macs body)))) (list* (quote block) loop-name body))))
(lambda (&rest loop-args) "The Common Lisp `loop' macro.\nValid clauses are:\n for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,\n for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,\n for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND,\n always COND, never COND, thereis COND, collect EXPR into VAR,\n append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR,\n count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR,\n if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],\n unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],\n do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,\n finally return EXPR, named NAME.\n\n(fn CLAUSE...)" (if (not (memq t (mapcar (quote symbolp) (delq nil (delq t (copy-list loop-args)))))) (list (quote block) nil (list* (quote while) t loop-args)) (let ((loop-name nil) (loop-bindings nil) (loop-body nil) (loop-steps nil) (loop-result nil) (loop-result-explicit nil) (loop-result-var nil) (loop-finish-flag nil) (loop-accum-var nil) (loop-accum-vars nil) (loop-initially nil) (loop-finally nil) (loop-map-form nil) (loop-first-flag nil) (loop-destr-temps nil) (loop-symbol-macs nil)) (setq loop-args (append loop-args (quote (cl-end-loop)))) (while (not (eq (car loop-args) (quote cl-end-loop))) (cl-parse-loop-clause)) (if loop-finish-flag (push (\` ((... t))) loop-bindings)) (if loop-first-flag (progn (push (\` (...)) loop-bindings) (push (\` (setq ... nil)) loop-steps))) (let* ((epilogue (nconc (nreverse loop-finally) (list ...))) (ands (cl-loop-build-ands (nreverse loop-body))) (while-body (nconc (cadr ands) (nreverse loop-steps))) (body (append (nreverse loop-initially) (list ...) (if loop-finish-flag ... epilogue)))) (if loop-result-var (push (list loop-result-var) loop-bindings)) (while loop-bindings (if (cdar loop-bindings) (setq body (list ...)) (let (...) (while ... ...) (setq body ...)))) (if loop-symbol-macs (setq body (list (list* ... loop-symbol-macs body)))) (list* (quote block) loop-name body)))))(for rms in nil when t do (loop for (gnu . emacs) in nil) end)
#<subr macroexpand>((loop for rms in nil when t do (loop for (gnu . emacs) in nil) end) nil)
macroexpand((loop for rms in nil when t do (loop for (gnu . emacs) in nil) end))
eval-defun-2()
eval-defun(nil)
call-interactively(eval-defun nil nil)
[-- Attachment #3: Type: text/plain, Size: 159 bytes --]
(loop for (gnu . emacs) in nil)
is parsed and executed correctly, so is
(loop for rms in nil
do (loop for (gnu . emacs) in nil))
Christopher
^ permalink raw reply [flat|nested] 4+ messages in thread
* bug#11038: 24.0.94; 24.0.94; cl loop macroexpand fails with (wrong-type-argument listp emacs)
2012-03-17 22:27 bug#11038: 24.0.94; 24.0.94; cl loop macroexpand fails with (wrong-type-argument listp emacs) Christopher Schmidt
@ 2012-03-18 1:37 ` Stefan Monnier
2012-05-06 14:53 ` Christopher Schmidt
0 siblings, 1 reply; 4+ messages in thread
From: Stefan Monnier @ 2012-03-18 1:37 UTC (permalink / raw)
To: 11038
> I think I hit on a bug in GNU Emacs 24.0.94.1 (x86_64-unknown-linux-gnu,
> GTK+ Version 2.24.10) of 2012-03-11. This cl loop is not parsed
> correctly.
> (loop for rms in nil
> when t
> do (loop for (gnu . emacs) in nil)
> end)
> Backtrace when evaling this form:
> Debugger entered--Lisp error: (wrong-type-argument listp emacs)
Indeed, there's a bug in cl-expr-contains because it does not correctly
handle all forms of Elisp. This is a very long standing bug. It might
be possible to fix it by macro-expanding the code before calling
cl-expr-contains, but since I'm not familiar with `loop' nor with its
implementation, I'd rather let someone else write the corresponding
patch (which may have to wait for 24.2).
Stefan
^ permalink raw reply [flat|nested] 4+ messages in thread
* bug#11038: 24.0.94; 24.0.94; cl loop macroexpand fails with (wrong-type-argument listp emacs)
2012-03-18 1:37 ` Stefan Monnier
@ 2012-05-06 14:53 ` Christopher Schmidt
2012-05-06 15:39 ` Stefan Monnier
0 siblings, 1 reply; 4+ messages in thread
From: Christopher Schmidt @ 2012-05-06 14:53 UTC (permalink / raw)
To: 11038
[-- Attachment #1: Type: text/plain, Size: 494 bytes --]
Stefan Monnier <monnier@iro.umontreal.ca> writes:
> Indeed, there's a bug in cl-expr-contains because it does not
> correctly handle all forms of Elisp. This is a very long standing
> bug. It might be possible to fix it by macro-expanding the code
> before calling cl-expr-contains, but since I'm not familiar with
> `loop' nor with its implementation, I'd rather let someone else write
> the corresponding patch (which may have to wait for 24.2).
Here is an (admittedly very naive) patch.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: cl-expr-contains.diff --]
[-- Type: text/x-diff, Size: 1607 bytes --]
=== modified file 'lisp/ChangeLog'
--- lisp/ChangeLog 2012-05-06 08:43:46 +0000
+++ lisp/ChangeLog 2012-05-06 13:47:05 +0000
@@ -1,3 +1,8 @@
+2012-05-06 Christopher Schmidt <christopher@ch.ristopher.com>
+
+ * emacs-lisp/cl-macs.el (cl-expr-contains): Handle cons cells
+ whose cdr is not a cons cell correctly (Bug#11038).
+
2012-05-06 Chong Yidong <cyd@gnu.org>
* emacs-lisp/tabulated-list.el (tabulated-list-format): Accept
=== modified file 'lisp/emacs-lisp/cl-loaddefs.el'
--- lisp/emacs-lisp/cl-loaddefs.el 2012-04-26 03:18:47 +0000
+++ lisp/emacs-lisp/cl-loaddefs.el 2012-05-06 13:50:33 +0000
@@ -286,7 +286,7 @@
;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist
;;;;;; do* do loop return-from return block etypecase typecase ecase
;;;;;; case load-time-value eval-when destructuring-bind function*
-;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "abb2e33c6f61539d69ddbe7c4046261b")
+;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "69f391c482a4981642368c6716aacfc8")
;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\
=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- lisp/emacs-lisp/cl-macs.el 2012-04-26 03:18:47 +0000
+++ lisp/emacs-lisp/cl-macs.el 2012-05-06 13:36:29 +0000
@@ -146,8 +146,9 @@
(cond ((equal y x) 1)
((and (consp x) (not (memq (car-safe x) '(quote function function*))))
(let ((sum 0))
- (while x
+ (while (consp x)
(setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
+ (setq sum (+ sum (or (cl-expr-contains x y) 0)))
(and (> sum 0) sum)))
(t nil)))
[-- Attachment #3: Type: text/plain, Size: 504 bytes --]
I grepped through the sources of cl.*\.el. cl-expr-contains and
cl-expr-contains-any are not specific to the loop implementation. I
think the functions do what their names say, inspect an expression and
count occurrences of symbols. The comment above cl-expr-contains says
so as well (";;; Count number of times X refers to Y. Return nil for 0
times.").
I tested my patch for a few hours with my configuration that makes heavy
use of cl. I have not run in any problem so far.
Christopher
^ permalink raw reply [flat|nested] 4+ messages in thread
* bug#11038: 24.0.94; 24.0.94; cl loop macroexpand fails with (wrong-type-argument listp emacs)
2012-05-06 14:53 ` Christopher Schmidt
@ 2012-05-06 15:39 ` Stefan Monnier
0 siblings, 0 replies; 4+ messages in thread
From: Stefan Monnier @ 2012-05-06 15:39 UTC (permalink / raw)
To: 11038-done
>> Indeed, there's a bug in cl-expr-contains because it does not
>> correctly handle all forms of Elisp. This is a very long standing
>> bug. It might be possible to fix it by macro-expanding the code
>> before calling cl-expr-contains, but since I'm not familiar with
>> `loop' nor with its implementation, I'd rather let someone else write
>> the corresponding patch (which may have to wait for 24.2).
> Here is an (admittedly very naive) patch.
Thanks, installed.
Stefan
^ permalink raw reply [flat|nested] 4+ messages in thread
end of thread, other threads:[~2012-05-06 15:39 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2012-03-17 22:27 bug#11038: 24.0.94; 24.0.94; cl loop macroexpand fails with (wrong-type-argument listp emacs) Christopher Schmidt
2012-03-18 1:37 ` Stefan Monnier
2012-05-06 14:53 ` Christopher Schmidt
2012-05-06 15:39 ` Stefan Monnier
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).