(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)
(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
(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
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
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
(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)))
(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
(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
(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)))
'(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)
(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))
(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'"))
(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))
((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)))
(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'"))
(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
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)))
(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))
((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)))
(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))
(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))))
(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))))
(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)))))
(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)
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))
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))
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)
\(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)
(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))
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)
(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
(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)
(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)
(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)
(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)
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))
(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))))
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*
(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)))
(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
(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)
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
(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
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))
(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)
;;; 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
HCoop / bpt / emacs.git / commitdiff