Mercurial > emacs
changeset 58255:65bbc782c81c
Use make-symbol rather than gensym.
(loop, cl-parse-loop-clause, defsetf): Use backquote.
| author | Stefan Monnier <monnier@iro.umontreal.ca> |
|---|---|
| date | Tue, 16 Nov 2004 04:05:29 +0000 |
| parents | e64002f85cf6 |
| children | 02a1d74082fd |
| files | lisp/emacs-lisp/cl-macs.el |
| diffstat | 1 files changed, 219 insertions(+), 225 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/emacs-lisp/cl-macs.el Tue Nov 16 04:04:50 2004 +0000 +++ b/lisp/emacs-lisp/cl-macs.el Tue Nov 16 04:05:29 2004 +0000 @@ -292,7 +292,7 @@ (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) (if (listp (cadr restarg)) - (setq restarg (gensym "--rest--")) + (setq restarg (make-symbol "--cl-rest--")) (setq restarg (cadr restarg))) (push (list restarg expr) bind-lets) (if (eq (car args) '&whole) @@ -354,7 +354,7 @@ (look (list 'memq (list 'quote karg) restarg))) (and def bind-enquote (setq def (list 'quote def))) (if (cddr arg) - (let* ((temp (or (nth 2 arg) (gensym))) + (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) (val (list 'car (list 'cdr temp)))) (cl-do-arglist temp look) (cl-do-arglist varg @@ -377,7 +377,7 @@ (setq keys (nreverse keys)) (or (and (eq (car args) '&allow-other-keys) (pop args)) (null keys) (= safety 0) - (let* ((var (gensym "--keys--")) + (let* ((var (make-symbol "--cl-keys--")) (allow '(:allow-other-keys)) (check (list 'while var @@ -494,7 +494,7 @@ place of a KEYLIST of one atom. A KEYLIST of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. Key values are compared by `eql'." - (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) + (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (head-list nil) (body (cons 'cond @@ -530,7 +530,7 @@ satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, typecase returns nil. A TYPE of t or `otherwise' is allowed only in the final clause, and matches if no other keys match." - (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) + (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (type-list nil) (body (cons 'cond @@ -644,10 +644,10 @@ (setq args (append args '(cl-end-loop))) (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) (if loop-finish-flag - (push (list (list loop-finish-flag t)) loop-bindings)) + (push `((,loop-finish-flag t)) loop-bindings)) (if loop-first-flag - (progn (push (list (list loop-first-flag t)) loop-bindings) - (push (list 'setq loop-first-flag nil) loop-steps))) + (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))) @@ -658,16 +658,16 @@ (list 'block '--cl-finish-- (subst (if (eq (car ands) t) while-body - (cons (list 'or (car ands) - '(return-from --cl-finish-- - nil)) + (cons `(or ,(car ands) + (return-from --cl-finish-- + nil)) while-body)) '--cl-map loop-map-form)) (list* 'while (car ands) while-body))) (if loop-finish-flag (if (equal epilogue '(nil)) (list loop-result-var) - (list (list 'if loop-finish-flag - (cons 'progn epilogue) loop-result-var))) + `((if ,loop-finish-flag + (progn ,@epilogue) ,loop-result-var))) epilogue)))) (if loop-result-var (push (list loop-result-var) loop-bindings)) (while loop-bindings @@ -682,7 +682,7 @@ (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) (list* 'block loop-name body))))) -(defun cl-parse-loop-clause () ; uses args, loop-* +(defun cl-parse-loop-clause () ; uses args, loop-* (let ((word (pop args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs @@ -715,7 +715,7 @@ (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) (ands nil)) (while - (let ((var (or (pop args) (gensym)))) + (let ((var (or (pop args) (make-symbol "--cl-var--")))) (setq word (pop args)) (if (eq word 'being) (setq word (pop args))) (if (memq word '(the each)) (setq word (pop args))) @@ -738,26 +738,28 @@ '(to upto downto above below)) (cl-pop2 args))) (step (and (eq (car args) 'by) (cl-pop2 args))) - (end-var (and (not (cl-const-expr-p end)) (gensym))) + (end-var (and (not (cl-const-expr-p end)) + (make-symbol "--cl-var--"))) (step-var (and (not (cl-const-expr-p step)) - (gensym)))) + (make-symbol "--cl-var--")))) (and step (numberp step) (<= step 0) (error "Loop `by' value is not positive: %s" step)) (push (list var (or start 0)) loop-for-bindings) (if end-var (push (list end-var end) loop-for-bindings)) (if step-var (push (list step-var step) - loop-for-bindings)) + loop-for-bindings)) (if end (push (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) loop-body)) + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)) loop-body)) (push (list var (list (if down '- '+) var - (or step-var step 1))) - loop-for-steps))) + (or step-var step 1))) + loop-for-steps))) ((memq word '(in in-ref on)) (let* ((on (eq word 'on)) - (temp (if (and on (symbolp var)) var (gensym)))) + (temp (if (and on (symbolp var)) + var (make-symbol "--cl-var--")))) (push (list temp (pop args)) loop-for-bindings) (push (list 'consp temp) loop-body) (if (eq word 'in-ref) @@ -766,18 +768,18 @@ (progn (push (list var nil) loop-for-bindings) (push (list var (if on temp (list 'car temp))) - loop-for-sets)))) + loop-for-sets)))) (push (list temp - (if (eq (car args) 'by) - (let ((step (cl-pop2 args))) - (if (and (memq (car-safe step) - '(quote function - function*)) - (symbolp (nth 1 step))) - (list (nth 1 step) temp) - (list 'funcall step temp))) - (list 'cdr temp))) - loop-for-steps))) + (if (eq (car args) 'by) + (let ((step (cl-pop2 args))) + (if (and (memq (car-safe step) + '(quote function + function*)) + (symbolp (nth 1 step))) + (list (nth 1 step) temp) + (list 'funcall step temp))) + (list 'cdr temp))) + loop-for-steps))) ((eq word '=) (let* ((start (pop args)) @@ -785,68 +787,68 @@ (push (list var nil) loop-for-bindings) (if (or ands (eq (car args) 'and)) (progn - (push (list var - (list 'if - (or loop-first-flag - (setq loop-first-flag - (gensym))) - start var)) - loop-for-sets) + (push `(,var + (if ,(or loop-first-flag + (setq loop-first-flag + (make-symbol "--cl-var--"))) + ,start ,var)) + loop-for-sets) (push (list var then) loop-for-steps)) (push (list var - (if (eq start then) start - (list 'if - (or loop-first-flag - (setq loop-first-flag (gensym))) - start then))) - loop-for-sets)))) + (if (eq start then) start + `(if ,(or loop-first-flag + (setq loop-first-flag + (make-symbol "--cl-var--"))) + ,start ,then))) + loop-for-sets)))) ((memq word '(across across-ref)) - (let ((temp-vec (gensym)) (temp-idx (gensym))) + (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-idx -1) loop-for-bindings) (push (list '< (list 'setq temp-idx (list '1+ temp-idx)) - (list 'length temp-vec)) loop-body) + (list 'length temp-vec)) loop-body) (if (eq word 'across-ref) (push (list var (list 'aref temp-vec temp-idx)) - loop-symbol-macs) + loop-symbol-macs) (push (list var nil) loop-for-bindings) (push (list var (list 'aref temp-vec temp-idx)) - loop-for-sets)))) + loop-for-sets)))) ((memq word '(element elements)) (let ((ref (or (memq (car args) '(in-ref of-ref)) (and (not (memq (car args) '(in of))) (error "Expected `of'")))) (seq (cl-pop2 args)) - (temp-seq (gensym)) + (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)) (error "Bad `using' clause")) - (gensym)))) + (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) (push (list temp-idx 0) loop-for-bindings) (if ref - (let ((temp-len (gensym))) + (let ((temp-len (make-symbol "--cl-len--"))) (push (list temp-len (list 'length temp-seq)) - loop-for-bindings) + loop-for-bindings) (push (list var (list 'elt temp-seq temp-idx)) - loop-symbol-macs) + loop-symbol-macs) (push (list '< temp-idx temp-len) loop-body)) (push (list var nil) loop-for-bindings) (push (list 'and temp-seq - (list 'or (list 'consp temp-seq) - (list '< temp-idx - (list 'length temp-seq)))) - loop-body) + (list 'or (list 'consp temp-seq) + (list '< temp-idx + (list 'length temp-seq)))) + loop-body) (push (list var (list 'if (list 'consp temp-seq) - (list 'pop temp-seq) - (list 'aref temp-seq temp-idx))) - loop-for-sets)) + (list 'pop temp-seq) + (list 'aref temp-seq temp-idx))) + loop-for-sets)) (push (list temp-idx (list '1+ temp-idx)) - loop-for-steps))) + loop-for-steps))) ((memq word hash-types) (or (memq (car args) '(in of)) (error "Expected `of'")) @@ -857,21 +859,17 @@ (not (eq (caadr args) word))) (cadr (cl-pop2 args)) (error "Bad `using' clause")) - (gensym)))) + (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) (setq var (prog1 other (setq other var)))) (setq loop-map-form - (list 'maphash (list 'function - (list* 'lambda (list var other) - '--cl-map)) table)))) + `(maphash (lambda (,var ,other) . --cl-map) ,table)))) ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) (setq loop-map-form - (list 'mapatoms (list 'function - (list* 'lambda (list var) - '--cl-map)) ob)))) + `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) @@ -880,14 +878,15 @@ ((eq (car args) 'to) (setq to (cl-pop2 args))) (t (setq buf (cl-pop2 args))))) (setq loop-map-form - (list 'cl-map-extents - (list 'function (list 'lambda (list var (gensym)) - '(progn . --cl-map) nil)) - buf from to)))) + `(cl-map-extents + (lambda (,var ,(make-symbol "--cl-var--")) + (progn . --cl-map) nil) + ,buf ,from ,to)))) ((memq word '(interval intervals)) (let ((buf nil) (prop nil) (from nil) (to nil) - (var1 (gensym)) (var2 (gensym))) + (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))) @@ -898,10 +897,9 @@ (setq var1 (car var) var2 (cdr var)) (push (list var (list 'cons var1 var2)) loop-for-sets)) (setq loop-map-form - (list 'cl-map-intervals - (list 'function (list 'lambda (list var1 var2) - '(progn . --cl-map))) - buf prop from to)))) + `(cl-map-intervals + (lambda (,var1 ,var2) . --cl-map) + ,buf ,prop ,from ,to)))) ((memq word key-types) (or (memq (car args) '(in of)) (error "Expected `of'")) @@ -912,37 +910,36 @@ (not (eq (caadr args) word))) (cadr (cl-pop2 args)) (error "Bad `using' clause")) - (gensym)))) + (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) (setq var (prog1 other (setq other var)))) (setq loop-map-form - (list (if (memq word '(key-seq key-seqs)) - 'cl-map-keymap-recursively 'map-keymap) - (list 'function (list* 'lambda (list var other) - '--cl-map)) map)))) + `(,(if (memq word '(key-seq key-seqs)) + 'cl-map-keymap-recursively 'map-keymap) + (lambda (,var ,other) . --cl-map) ,map)))) ((memq word '(frame frames screen screens)) - (let ((temp (gensym))) + (let ((temp (make-symbol "--cl-var--"))) (push (list var '(selected-frame)) - loop-for-bindings) + loop-for-bindings) (push (list temp nil) loop-for-bindings) (push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) + (list 'or temp (list 'setq temp var))) + loop-body) (push (list var (list 'next-frame var)) - loop-for-steps))) + loop-for-steps))) ((memq word '(window windows)) (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) - (temp (gensym))) + (temp (make-symbol "--cl-var--"))) (push (list var (if scr - (list 'frame-selected-window scr) - '(selected-window))) - loop-for-bindings) + (list 'frame-selected-window scr) + '(selected-window))) + loop-for-bindings) (push (list temp nil) loop-for-bindings) (push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) + (list 'or temp (list 'setq temp var))) + loop-body) (push (list var (list 'next-window var)) loop-for-steps))) (t @@ -960,15 +957,15 @@ loop-bindings))) (if loop-for-sets (push (list 'progn - (cl-loop-let (nreverse loop-for-sets) 'setq ands) - t) loop-body)) + (cl-loop-let (nreverse loop-for-sets) 'setq ands) + t) loop-body)) (if loop-for-steps (push (cons (if ands 'psetq 'setq) - (apply 'append (nreverse loop-for-steps))) - loop-steps)))) + (apply 'append (nreverse loop-for-steps))) + loop-steps)))) ((eq word 'repeat) - (let ((temp (gensym))) + (let ((temp (make-symbol "--cl-var--"))) (push (list (list temp (pop args))) loop-bindings) (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) @@ -978,23 +975,23 @@ (if (eq var loop-accum-var) (push (list 'progn (list 'push what var) t) loop-body) (push (list 'progn - (list 'setq var (list 'nconc var (list 'list what))) - t) loop-body)))) + (list 'setq var (list 'nconc var (list 'list what))) + t) loop-body)))) ((memq word '(nconc nconcing append appending)) (let ((what (pop args)) (var (cl-loop-handle-accum nil 'nreverse))) (push (list 'progn - (list 'setq var - (if (eq var loop-accum-var) - (list 'nconc - (list (if (memq word '(nconc nconcing)) - 'nreverse 'reverse) - what) - var) - (list (if (memq word '(nconc nconcing)) - 'nconc 'append) - var what))) t) loop-body))) + (list 'setq var + (if (eq var loop-accum-var) + (list 'nconc + (list (if (memq word '(nconc nconcing)) + 'nreverse 'reverse) + what) + var) + (list (if (memq word '(nconc nconcing)) + 'nconc 'append) + var what))) t) loop-body))) ((memq word '(concat concating)) (let ((what (pop args)) @@ -1018,19 +1015,19 @@ ((memq word '(minimize minimizing maximize maximizing)) (let* ((what (pop args)) - (temp (if (cl-simple-expr-p what) what (gensym))) + (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 'setq var (list 'if var (list func var temp) temp)))) (push (list 'progn (if (eq temp what) set - (list 'let (list (list temp what)) set)) - t) loop-body))) + (list 'let (list (list temp what)) set)) + t) loop-body))) ((eq word 'with) (let ((bindings nil)) (while (progn (push (list (pop args) - (and (eq (car args) '=) (cl-pop2 args))) - bindings) + (and (eq (car args) '=) (cl-pop2 args))) + bindings) (eq (car args) 'and)) (pop args)) (push (nreverse bindings) loop-bindings))) @@ -1042,22 +1039,22 @@ (push (list 'not (pop args)) loop-body)) ((eq word 'always) - (or loop-finish-flag (setq loop-finish-flag (gensym))) + (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (push (list 'setq loop-finish-flag (pop args)) loop-body) (setq loop-result t)) ((eq word 'never) - (or loop-finish-flag (setq loop-finish-flag (gensym))) + (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (push (list 'setq loop-finish-flag (list 'not (pop args))) - loop-body) + loop-body) (setq loop-result t)) ((eq word 'thereis) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (or loop-result-var (setq loop-result-var (gensym))) + (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)))) - loop-body)) + (list 'not (list 'setq loop-result-var (pop args)))) + loop-body)) ((memq word '(if when unless)) (let* ((cond (pop args)) @@ -1074,7 +1071,7 @@ (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) (if (cl-expr-contains form 'it) - (let ((temp (gensym))) + (let ((temp (make-symbol "--cl-var--"))) (push (list temp) loop-bindings) (setq form (list* 'if (list 'setq temp cond) (subst temp 'it form)))) @@ -1088,10 +1085,10 @@ (push (cons 'progn (nreverse (cons t body))) loop-body))) ((eq word 'return) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (or loop-result-var (setq loop-result-var (gensym))) + (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) - loop-finish-flag nil) loop-body)) + loop-finish-flag nil) loop-body)) (t (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) @@ -1109,7 +1106,7 @@ (setq par nil p specs) (while p (or (cl-const-expr-p (cadar p)) - (let ((temp (gensym))) + (let ((temp (make-symbol "--cl-var--"))) (push (list temp (cadar p)) temps) (setcar (cdar p) temp))) (setq p (cdr p))))) @@ -1119,8 +1116,8 @@ (expr (cadr (pop specs))) (temp (cdr (or (assq spec loop-destr-temps) (car (push (cons spec (or (last spec 0) - (gensym))) - loop-destr-temps)))))) + (make-symbol "--cl-var--"))) + loop-destr-temps)))))) (push (list temp expr) new) (while (consp spec) (push (list (pop spec) @@ -1143,7 +1140,7 @@ var) (or loop-accum-var (progn - (push (list (list (setq loop-accum-var (gensym)) def)) + (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) def)) loop-bindings) (setq loop-result (if func (list func loop-accum-var) loop-accum-var)) @@ -1214,7 +1211,7 @@ Then evaluate RESULT to get return value, default nil. \(fn (VAR LIST [RESULT]) BODY...)" - (let ((temp (gensym "--dolist-temp--"))) + (let ((temp (make-symbol "--cl-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)) @@ -1231,7 +1228,7 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" - (let ((temp (gensym "--dotimes-temp--"))) + (let ((temp (make-symbol "--cl-dotimes-temp--"))) (list 'block nil (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) (list* 'while (list '< (car spec) temp) @@ -1317,7 +1314,7 @@ \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) (while bindings - (let ((var (gensym))) + (let ((var (make-symbol "--cl-var--"))) (push var vars) (push (list 'function* (cons 'lambda (cdar bindings))) sets) (push var sets) @@ -1370,8 +1367,8 @@ (vars (mapcar (function (lambda (x) (or (consp x) (setq x (list x))) - (push (gensym (format "--%s--" (car x))) - cl-closure-vars) + (push (make-symbol (format "--cl-%s--" (car x))) + cl-closure-vars) (set (car cl-closure-vars) [bad-lexical-ref]) (list (car x) (cadr x) (car cl-closure-vars)))) bindings)) @@ -1432,7 +1429,7 @@ a synonym for (list A B C). \(fn (SYM SYM...) FORM BODY)" - (let ((temp (gensym)) (n -1)) + (let ((temp (make-symbol "--cl-var--")) (n -1)) (list* 'let* (cons (list temp form) (mapcar (function (lambda (v) @@ -1451,7 +1448,7 @@ (cond ((null vars) (list 'progn form nil)) ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) (t - (let* ((temp (gensym)) (n 0)) + (let* ((temp (make-symbol "--cl-var--")) (n 0)) (list 'let (list (list temp form)) (list 'prog1 (list 'setq (pop vars) (list 'car temp)) (cons 'setq (apply 'nconc @@ -1590,44 +1587,41 @@ (setq largsr largs tempsr temps)) (let ((p1 largs) (p2 temps)) (while p1 - (setq lets1 (cons (list (car p2) - (list 'gensym (format "--%s--" (car p1)))) + (setq lets1 (cons `(,(car p2) + (make-symbol ,(format "--cl-%s--" (car p1)))) lets1) lets2 (cons (list (car p1) (car p2)) lets2) p1 (cdr p1) p2 (cdr p2)))) (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) - (append (list 'define-setf-method func arg1) - (and docstr (list docstr)) - (list - (list 'let* - (nreverse - (cons (list store-temp - (list 'gensym (format "--%s--" store-var))) - (if restarg - (append - (list - (list rest-temps - (list 'mapcar '(quote gensym) - restarg))) - lets1) - lets1))) - (list 'list ; 'values - (cons (if restarg 'list* 'list) tempsr) - (cons (if restarg 'list* 'list) largsr) - (list 'list store-temp) - (cons 'let* - (cons (nreverse - (cons (list store-var store-temp) - lets2)) - args)) - (cons (if restarg 'list* 'list) - (cons (list 'quote func) tempsr))))))) - (list 'defsetf func '(&rest args) '(store) - (let ((call (list 'cons (list 'quote arg1) - '(append args (list store))))) - (if (car args) - (list 'list '(quote progn) call 'store) - call))))) + `(define-setf-method ,func ,arg1 + ,@(and docstr (list docstr)) + (let* + ,(nreverse + (cons `(,store-temp + (make-symbol ,(format "--cl-%s--" store-var))) + (if restarg + `((,rest-temps + (mapcar (lambda (_) (make-symbol "--cl-var--")) + ,restarg)) + ,@lets1) + lets1))) + (list ; 'values + (,(if restarg 'list* 'list) ,@tempsr) + (,(if restarg 'list* 'list) ,@largsr) + (list ,store-temp) + (let* + ,(nreverse + (cons (list store-var store-temp) + lets2)) + ,@args) + (,(if restarg 'list* 'list) + ,@(cons (list 'quote func) tempsr)))))) + `(defsetf ,func (&rest args) (store) + ,(let ((call `(cons ',arg1 + (append args (list store))))) + (if (car args) + `(list 'progn ,call store) + call))))) ;;; Some standard place types from Common Lisp. (defsetf aref aset) @@ -1781,8 +1775,8 @@ (define-setf-method nthcdr (n place) (let ((method (get-setf-method place cl-macro-environment)) - (n-temp (gensym "--nthcdr-n--")) - (store-temp (gensym "--nthcdr-store--"))) + (n-temp (make-symbol "--cl-nthcdr-n--")) + (store-temp (make-symbol "--cl-nthcdr-store--"))) (list (cons n-temp (car method)) (cons n (nth 1 method)) (list store-temp) @@ -1794,9 +1788,9 @@ (define-setf-method getf (place tag &optional def) (let ((method (get-setf-method place cl-macro-environment)) - (tag-temp (gensym "--getf-tag--")) - (def-temp (gensym "--getf-def--")) - (store-temp (gensym "--getf-store--"))) + (tag-temp (make-symbol "--cl-getf-tag--")) + (def-temp (make-symbol "--cl-getf-def--")) + (store-temp (make-symbol "--cl-getf-store--"))) (list (append (car method) (list tag-temp def-temp)) (append (nth 1 method) (list tag def)) (list store-temp) @@ -1808,9 +1802,9 @@ (define-setf-method substring (place from &optional to) (let ((method (get-setf-method place cl-macro-environment)) - (from-temp (gensym "--substring-from--")) - (to-temp (gensym "--substring-to--")) - (store-temp (gensym "--substring-store--"))) + (from-temp (make-symbol "--cl-substring-from--")) + (to-temp (make-symbol "--cl-substring-to--")) + (store-temp (make-symbol "--cl-substring-store--"))) (list (append (car method) (list from-temp to-temp)) (append (nth 1 method) (list from to)) (list store-temp) @@ -1826,7 +1820,7 @@ PLACE may be any Lisp form which can appear as the PLACE argument to a macro like `setf' or `incf'." (if (symbolp place) - (let ((temp (gensym "--setf--"))) + (let ((temp (make-symbol "--cl-setf--"))) (list nil nil (list temp) (list 'setq place temp) place)) (or (and (symbolp (car place)) (let* ((func (car place)) @@ -1933,7 +1927,7 @@ (if (cl-simple-expr-p place) (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) (let* ((method (cl-setf-do-modify place t)) - (temp (gensym "--pop--"))) + (temp (make-symbol "--cl-pop--"))) (list 'let* (append (car method) (list (list temp (nth 2 method)))) @@ -1946,9 +1940,9 @@ PLACE may be a symbol, or any generalized variable allowed by `setf'. The form returns true if TAG was found and removed, nil otherwise." (let* ((method (cl-setf-do-modify place t)) - (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--"))) + (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--"))) (val-temp (and (not (cl-simple-expr-p place)) - (gensym "--remf-place--"))) + (make-symbol "--cl-remf-place--"))) (ttag (or tag-temp tag)) (tval (or val-temp (nth 2 method)))) (list 'let* @@ -1990,7 +1984,7 @@ (setq sets (nconc sets (list (pop args) (car args))))) (nconc (list 'psetf) sets (list (car args) first)))) (let* ((places (reverse args)) - (temp (gensym "--rotatef--")) + (temp (make-symbol "--cl-rotatef--")) (form temp)) (while (cdr places) (let ((method (cl-setf-do-modify (pop places) 'unsafe))) @@ -2022,11 +2016,11 @@ (caar rev))) (value (cadar rev)) (method (cl-setf-do-modify place 'no-opt)) - (save (gensym "--letf-save--")) + (save (make-symbol "--cl-letf-save--")) (bound (and (memq (car place) '(symbol-value symbol-function)) - (gensym "--letf-bound--"))) + (make-symbol "--cl-letf-bound--"))) (temp (and (not (cl-const-expr-p value)) (cdr bindings) - (gensym "--letf-val--")))) + (make-symbol "--cl-letf-val--")))) (setq lets (nconc (car method) (if bound (list (list bound @@ -2097,7 +2091,7 @@ (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) (list 'setf place (list* func arg1 place args)) (let* ((method (cl-setf-do-modify place (cons 'list args))) - (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--"))) + (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--"))) (rargs (list* (or temp arg1) (nth 2 method) args))) (list 'let* (append (and temp (list (list temp arg1))) (car method)) (cl-setf-do-store (nth 1 method) @@ -2110,7 +2104,7 @@ If NAME is called, it combines its PLACE argument with the other arguments from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) - (let ((place (gensym "--place--"))) + (let ((place (make-symbol "--cl-place--"))) (list 'defmacro* name (cons place arglist) doc (list* (if (memq '&rest arglist) 'list* 'list) '(quote callf) (list 'quote func) place @@ -2334,7 +2328,7 @@ (cons 'progn (nreverse (cons (list 'quote name) forms))))) (defun cl-struct-setf-expander (x name accessor pred-form pos) - (let* ((temp (gensym "--x--")) (store (gensym "--store--"))) + (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--"))) (list (list temp) (list x) (list store) (append '(progn) (and pred-form @@ -2410,7 +2404,8 @@ STRING is an optional description of the desired type." (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let* ((temp (if (cl-simple-expr-p form 3) form (gensym))) + (let* ((temp (if (cl-simple-expr-p form 3) + form (make-symbol "--cl-var--"))) (body (list 'or (cl-make-type-test temp type) (list 'signal '(quote wrong-type-argument) (list 'list (or string (list 'quote type)) @@ -2607,48 +2602,47 @@ (let ((res (cl-make-type-test val (cl-const-expr-val type)))) (if (or (memq (cl-expr-contains res val) '(nil 1)) (cl-simple-expr-p val)) res - (let ((temp (gensym))) + (let ((temp (make-symbol "--cl-var--"))) (list 'let (list (list temp val)) (subst temp val res))))) form)) -(mapcar (function - (lambda (y) - (put (car y) 'side-effect-free t) - (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) - (put (car y) 'cl-compiler-macro - (list 'lambda '(w x) - (if (symbolp (cadr y)) - (list 'list (list 'quote (cadr y)) - (list 'list (list 'quote (caddr y)) 'x)) - (cons 'list (cdr y))))))) - '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) - (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) - (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) - (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) - (caaar car caar) (caadr car cadr) (cadar car cdar) - (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) - (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) - (caaadr car caadr) (caadar car cadar) (caaddr car caddr) - (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) - (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) - (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) - (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) +(mapc (lambda (y) + (put (car y) 'side-effect-free t) + (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) + (put (car y) 'cl-compiler-macro + `(lambda (w x) + ,(if (symbolp (cadr y)) + `(list ',(cadr y) + (list ',(caddr y) x)) + (cons 'list (cdr y)))))) + '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) + (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) + (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) + (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) + (caaar car caar) (caadr car cadr) (cadar car cdar) + (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) + (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) + (caaadr car caadr) (caadar car cadar) (caaddr car caddr) + (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) + (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) + (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) + (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) ;;; Things that are inline. (proclaim '(inline floatp-safe acons map concatenate notany notevery cl-set-elt revappend nreconc gethash)) ;;; Things that are side-effect-free. -(mapcar (function (lambda (x) (put x 'side-effect-free t))) - '(oddp evenp signum last butlast ldiff pairlis gcd lcm - isqrt floor* ceiling* truncate* round* mod* rem* subseq - list-length get* getf)) +(mapc (lambda (x) (put x 'side-effect-free t)) + '(oddp evenp signum last butlast ldiff pairlis gcd lcm + isqrt floor* ceiling* truncate* round* mod* rem* subseq + list-length get* getf)) ;;; Things that are side-effect-and-error-free. -(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) - '(eql floatp-safe list* subst acons equalp random-state-p - copy-tree sublis)) +(mapc (lambda (x) (put x 'side-effect-free 'error-free)) + '(eql floatp-safe list* subst acons equalp random-state-p + copy-tree sublis)) (run-hooks 'cl-macs-load-hook) @@ -2657,5 +2651,5 @@ ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime) ;;; End: -;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 +;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 ;;; cl-macs.el ends here