;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*-
-;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
-;; Version: 2.02
+;; Old-Version: 2.02
;; Keywords: extensions
;; Package: emacs
;; `gv' is required here because cl-macs can be loaded before loaddefs.el.
(require 'gv)
-(defmacro cl-pop2 (place)
+(defmacro cl--pop2 (place)
(declare (debug edebug-sexps))
`(prog1 (car (cdr ,place))
(setq ,place (cdr (cdr ,place)))))
-(defvar cl-optimize-safety)
-(defvar cl-optimize-speed)
+(defvar cl--optimize-safety)
+(defvar cl--optimize-speed)
;;; Initialization.
(if (memq '&environment args) (error "&environment used incorrectly"))
(let ((save-args args)
(restarg (memq '&rest args))
- (safety (if (cl--compiling-file) cl-optimize-safety 3))
+ (safety (if (cl--compiling-file) cl--optimize-safety 3))
(keys nil)
(laterarg nil) (exactarg nil) minarg)
(or num (setq num 0))
(setq restarg (cadr restarg)))
(push (list restarg expr) cl--bind-lets)
(if (eq (car args) '&whole)
- (push (list (cl-pop2 args) restarg) cl--bind-lets))
+ (push (list (cl--pop2 args) restarg) cl--bind-lets))
(let ((p args))
(setq minarg restarg)
(while (and p (not (memq (car p) cl--lambda-list-keywords)))
(if def `(if ,restarg ,poparg ,def) poparg))
(setq num (1+ num))))))
(if (eq (car args) '&rest)
- (let ((arg (cl-pop2 args)))
+ (let ((arg (cl--pop2 args)))
(if (consp arg) (cl--do-arglist arg restarg)))
(or (eq (car args) '&key) (= safety 0) exactarg
(push `(if ,restarg
;;; The `cl-eval-when' form.
-(defvar cl-not-toplevel nil)
+(defvar cl--not-toplevel nil)
;;;###autoload
(defmacro cl-eval-when (when &rest body)
If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
\(fn (WHEN...) BODY...)"
- (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body)))
+ (declare (indent 1) (debug (sexp body)))
(if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
- (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
+ (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge.
(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
- (cl-not-toplevel t))
+ (cl--not-toplevel t))
(if (or (memq 'load when) (memq :load-toplevel when))
(if comp (cons 'progn (mapcar 'cl--compile-time-too body))
`(if nil nil ,@body))
(defvar cl--loop-first-flag)
(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name)
(defvar cl--loop-result) (defvar cl--loop-result-explicit)
-(defvar cl--loop-result-var) (defvar cl--loop-steps) (defvar cl--loop-symbol-macs)
+(defvar cl--loop-result-var) (defvar cl--loop-steps)
+(defvar cl--loop-symbol-macs)
;;;###autoload
(defmacro cl-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,
- for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
- for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND,
- always COND, never COND, thereis COND, collect EXPR into VAR,
- append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR,
- count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR,
- if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
- unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
- do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
- finally return EXPR, named NAME.
+Valid clauses include:
+ For clauses:
+ for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 by EXPR3
+ for VAR = EXPR1 then EXPR2
+ for VAR in/on/in-ref LIST by FUNC
+ for VAR across/across-ref ARRAY
+ for VAR being:
+ the elements of/of-ref SEQUENCE [using (index VAR2)]
+ the symbols [of OBARRAY]
+ the hash-keys/hash-values of HASH-TABLE [using (hash-values/hash-keys V2)]
+ the key-codes/key-bindings/key-seqs of KEYMAP [using (key-bindings VAR2)]
+ the overlays/intervals [of BUFFER] [from POS1] [to POS2]
+ the frames/buffers
+ the windows [of FRAME]
+ Iteration clauses:
+ repeat INTEGER
+ while/until/always/never/thereis CONDITION
+ Accumulation clauses:
+ collect/append/nconc/concat/vconcat/count/sum/maximize/minimize FORM
+ [into VAR]
+ Miscellaneous clauses:
+ with VAR = INIT
+ if/when/unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...]
+ named NAME
+ initially/finally [do] EXPRS...
+ do EXPRS...
+ [finally] return EXPR
+
+For more details, see Info node `(cl)Loop Facility'.
\(fn CLAUSE...)"
(declare (debug (&rest &or
"return"] form]
;; Simple default, which covers 99% of the cases.
symbolp form)))
- (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list loop-args))))))
+ (if (not (memq t (mapcar #'symbolp
+ (delq nil (delq t (cl-copy-list loop-args))))))
`(cl-block nil (while t ,@loop-args))
(let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil)
(cl--loop-body nil) (cl--loop-steps nil)
(cl--loop-map-form nil) (cl--loop-first-flag nil)
(cl--loop-destr-temps nil) (cl--loop-symbol-macs nil))
(setq cl--loop-args (append cl--loop-args '(cl-end-loop)))
- (while (not (eq (car cl--loop-args) 'cl-end-loop)) (cl-parse-loop-clause))
+ (while (not (eq (car cl--loop-args) 'cl-end-loop))
+ (cl--parse-loop-clause))
(if cl--loop-finish-flag
(push `((,cl--loop-finish-flag t)) cl--loop-bindings))
(if cl--loop-first-flag
(progn (push `((,cl--loop-first-flag t)) cl--loop-bindings)
(push `(setq ,cl--loop-first-flag nil) cl--loop-steps)))
(let* ((epilogue (nconc (nreverse cl--loop-finally)
- (list (or cl--loop-result-explicit cl--loop-result))))
+ (list (or cl--loop-result-explicit
+ cl--loop-result))))
(ands (cl--loop-build-ands (nreverse cl--loop-body)))
(while-body (nconc (cadr ands) (nreverse cl--loop-steps)))
(body (append
`((if ,cl--loop-finish-flag
(progn ,@epilogue) ,cl--loop-result-var)))
epilogue))))
- (if cl--loop-result-var (push (list cl--loop-result-var) cl--loop-bindings))
+ (if cl--loop-result-var
+ (push (list cl--loop-result-var) cl--loop-bindings))
(while cl--loop-bindings
(if (cdar cl--loop-bindings)
(setq body (list (cl--loop-let (pop cl--loop-bindings) body t)))
(push (car (pop cl--loop-bindings)) lets))
(setq body (list (cl--loop-let lets body nil))))))
(if cl--loop-symbol-macs
- (setq body (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body))))
+ (setq body
+ (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body))))
`(cl-block ,cl--loop-name ,@body)))))
;; Below is a complete spec for cl-loop, in several parts that correspond
-(defun cl-parse-loop-clause () ; uses loop-*
+(defun cl--parse-loop-clause () ; uses loop-*
(let ((word (pop cl--loop-args))
(hash-types '(hash-key hash-keys hash-value hash-values))
(key-types '(key-code key-codes key-seq key-seqs
((eq word 'initially)
(if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args))
- (or (consp (car cl--loop-args)) (error "Syntax error on `initially' clause"))
+ (or (consp (car cl--loop-args))
+ (error "Syntax error on `initially' clause"))
(while (consp (car cl--loop-args))
(push (pop cl--loop-args) cl--loop-initially)))
((eq word 'finally)
(if (eq (car cl--loop-args) 'return)
- (setq cl--loop-result-explicit (or (cl-pop2 cl--loop-args) '(quote nil)))
+ (setq cl--loop-result-explicit
+ (or (cl--pop2 cl--loop-args) '(quote nil)))
(if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args))
- (or (consp (car cl--loop-args)) (error "Syntax error on `finally' clause"))
+ (or (consp (car cl--loop-args))
+ (error "Syntax error on `finally' clause"))
(if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name))
- (setq cl--loop-result-explicit (or (nth 1 (pop cl--loop-args)) '(quote nil)))
+ (setq cl--loop-result-explicit
+ (or (nth 1 (pop cl--loop-args)) '(quote nil)))
(while (consp (car cl--loop-args))
(push (pop cl--loop-args) cl--loop-finally)))))
(if (eq word 'being) (setq word (pop cl--loop-args)))
(if (memq word '(the each)) (setq word (pop cl--loop-args)))
(if (memq word '(buffer buffers))
- (setq word 'in cl--loop-args (cons '(buffer-list) cl--loop-args)))
+ (setq word 'in
+ cl--loop-args (cons '(buffer-list) cl--loop-args)))
(cond
((memq word '(from downfrom upfrom to downto upto
(if (memq (car cl--loop-args) '(downto above))
(error "Must specify `from' value for downward cl-loop"))
(let* ((down (or (eq (car cl--loop-args) 'downfrom)
- (memq (cl-caddr cl--loop-args) '(downto above))))
+ (memq (cl-caddr cl--loop-args)
+ '(downto above))))
(excl (or (memq (car cl--loop-args) '(above below))
- (memq (cl-caddr cl--loop-args) '(above below))))
- (start (and (memq (car cl--loop-args) '(from upfrom downfrom))
- (cl-pop2 cl--loop-args)))
+ (memq (cl-caddr cl--loop-args)
+ '(above below))))
+ (start (and (memq (car cl--loop-args)
+ '(from upfrom downfrom))
+ (cl--pop2 cl--loop-args)))
(end (and (memq (car cl--loop-args)
'(to upto downto above below))
- (cl-pop2 cl--loop-args)))
- (step (and (eq (car cl--loop-args) 'by) (cl-pop2 cl--loop-args)))
+ (cl--pop2 cl--loop-args)))
+ (step (and (eq (car cl--loop-args) 'by)
+ (cl--pop2 cl--loop-args)))
(end-var (and (not (macroexp-const-p end))
(make-symbol "--cl-var--")))
(step-var (and (not (macroexp-const-p step))
loop-for-sets))))
(push (list temp
(if (eq (car cl--loop-args) 'by)
- (let ((step (cl-pop2 cl--loop-args)))
+ (let ((step (cl--pop2 cl--loop-args)))
(if (and (memq (car-safe step)
'(quote function
cl-function))
((eq word '=)
(let* ((start (pop cl--loop-args))
- (then (if (eq (car cl--loop-args) 'then) (cl-pop2 cl--loop-args) start)))
+ (then (if (eq (car cl--loop-args) 'then)
+ (cl--pop2 cl--loop-args) start)))
(push (list var nil) loop-for-bindings)
(if (or ands (eq (car cl--loop-args) 'and))
(progn
(let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref))
(and (not (memq (car cl--loop-args) '(in of)))
(error "Expected `of'"))))
- (seq (cl-pop2 cl--loop-args))
+ (seq (cl--pop2 cl--loop-args))
(temp-seq (make-symbol "--cl-seq--"))
- (temp-idx (if (eq (car cl--loop-args) 'using)
- (if (and (= (length (cadr cl--loop-args)) 2)
- (eq (cl-caadr cl--loop-args) 'index))
- (cadr (cl-pop2 cl--loop-args))
- (error "Bad `using' clause"))
- (make-symbol "--cl-idx--"))))
+ (temp-idx
+ (if (eq (car cl--loop-args) 'using)
+ (if (and (= (length (cadr cl--loop-args)) 2)
+ (eq (cl-caadr cl--loop-args) 'index))
+ (cadr (cl--pop2 cl--loop-args))
+ (error "Bad `using' clause"))
+ (make-symbol "--cl-idx--"))))
(push (list temp-seq seq) loop-for-bindings)
(push (list temp-idx 0) loop-for-bindings)
(if ref
loop-for-steps)))
((memq word hash-types)
- (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'"))
- (let* ((table (cl-pop2 cl--loop-args))
- (other (if (eq (car cl--loop-args) 'using)
- (if (and (= (length (cadr cl--loop-args)) 2)
- (memq (cl-caadr cl--loop-args) hash-types)
- (not (eq (cl-caadr cl--loop-args) word)))
- (cadr (cl-pop2 cl--loop-args))
- (error "Bad `using' clause"))
- (make-symbol "--cl-var--"))))
+ (or (memq (car cl--loop-args) '(in of))
+ (error "Expected `of'"))
+ (let* ((table (cl--pop2 cl--loop-args))
+ (other
+ (if (eq (car cl--loop-args) 'using)
+ (if (and (= (length (cadr cl--loop-args)) 2)
+ (memq (cl-caadr cl--loop-args) hash-types)
+ (not (eq (cl-caadr cl--loop-args) word)))
+ (cadr (cl--pop2 cl--loop-args))
+ (error "Bad `using' clause"))
+ (make-symbol "--cl-var--"))))
(if (memq word '(hash-value hash-values))
(setq var (prog1 other (setq other var))))
(setq cl--loop-map-form
((memq word '(symbol present-symbol external-symbol
symbols present-symbols external-symbols))
- (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args))))
+ (let ((ob (and (memq (car cl--loop-args) '(in of))
+ (cl--pop2 cl--loop-args))))
(setq cl--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 cl--loop-args) '(in of from to))
- (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args)))
- ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args)))
- (t (setq buf (cl-pop2 cl--loop-args)))))
+ (cond ((eq (car cl--loop-args) 'from)
+ (setq from (cl--pop2 cl--loop-args)))
+ ((eq (car cl--loop-args) 'to)
+ (setq to (cl--pop2 cl--loop-args)))
+ (t (setq buf (cl--pop2 cl--loop-args)))))
(setq cl--loop-map-form
`(cl--map-overlays
(lambda (,var ,(make-symbol "--cl-var--"))
(var1 (make-symbol "--cl-var1--"))
(var2 (make-symbol "--cl-var2--")))
(while (memq (car cl--loop-args) '(in of property from to))
- (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args)))
- ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args)))
+ (cond ((eq (car cl--loop-args) 'from)
+ (setq from (cl--pop2 cl--loop-args)))
+ ((eq (car cl--loop-args) 'to)
+ (setq to (cl--pop2 cl--loop-args)))
((eq (car cl--loop-args) 'property)
- (setq prop (cl-pop2 cl--loop-args)))
- (t (setq buf (cl-pop2 cl--loop-args)))))
+ (setq prop (cl--pop2 cl--loop-args)))
+ (t (setq buf (cl--pop2 cl--loop-args)))))
(if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
(setq var1 (car var) var2 (cdr var))
(push (list var `(cons ,var1 ,var2)) loop-for-sets))
,buf ,prop ,from ,to))))
((memq word key-types)
- (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'"))
- (let ((cl-map (cl-pop2 cl--loop-args))
- (other (if (eq (car cl--loop-args) 'using)
- (if (and (= (length (cadr cl--loop-args)) 2)
- (memq (cl-caadr cl--loop-args) key-types)
- (not (eq (cl-caadr cl--loop-args) word)))
- (cadr (cl-pop2 cl--loop-args))
- (error "Bad `using' clause"))
- (make-symbol "--cl-var--"))))
+ (or (memq (car cl--loop-args) '(in of))
+ (error "Expected `of'"))
+ (let ((cl-map (cl--pop2 cl--loop-args))
+ (other
+ (if (eq (car cl--loop-args) 'using)
+ (if (and (= (length (cadr cl--loop-args)) 2)
+ (memq (cl-caadr cl--loop-args) key-types)
+ (not (eq (cl-caadr cl--loop-args) word)))
+ (cadr (cl--pop2 cl--loop-args))
+ (error "Bad `using' clause"))
+ (make-symbol "--cl-var--"))))
(if (memq word '(key-binding key-bindings))
(setq var (prog1 other (setq other var))))
(setq cl--loop-map-form
loop-for-steps)))
((memq word '(window windows))
- (let ((scr (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args)))
+ (let ((scr (and (memq (car cl--loop-args) '(in of))
+ (cl--pop2 cl--loop-args)))
(temp (make-symbol "--cl-var--"))
(minip (make-symbol "--cl-minip--")))
(push (list var (if scr
((memq word '(minimize minimizing maximize maximizing))
(let* ((what (pop cl--loop-args))
- (temp (if (cl--simple-expr-p what) what (make-symbol "--cl-var--")))
+ (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 `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
((eq word 'with)
(let ((bindings nil))
(while (progn (push (list (pop cl--loop-args)
- (and (eq (car cl--loop-args) '=) (cl-pop2 cl--loop-args)))
+ (and (eq (car cl--loop-args) '=)
+ (cl--pop2 cl--loop-args)))
bindings)
(eq (car cl--loop-args) 'and))
(pop cl--loop-args))
(push `(not ,(pop cl--loop-args)) cl--loop-body))
((eq word 'always)
- (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
+ (or cl--loop-finish-flag
+ (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
(push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body)
(setq cl--loop-result t))
((eq word 'never)
- (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
+ (or cl--loop-finish-flag
+ (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
(push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args)))
cl--loop-body)
(setq cl--loop-result t))
((eq word 'thereis)
- (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
- (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--")))
+ (or cl--loop-finish-flag
+ (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
+ (or cl--loop-result-var
+ (setq cl--loop-result-var (make-symbol "--cl-var--")))
(push `(setq ,cl--loop-finish-flag
(not (setq ,cl--loop-result-var ,(pop cl--loop-args))))
cl--loop-body))
((memq word '(if when unless))
(let* ((cond (pop cl--loop-args))
(then (let ((cl--loop-body nil))
- (cl-parse-loop-clause)
+ (cl--parse-loop-clause)
(cl--loop-build-ands (nreverse cl--loop-body))))
(else (let ((cl--loop-body nil))
(if (eq (car cl--loop-args) 'else)
- (progn (pop cl--loop-args) (cl-parse-loop-clause)))
+ (progn (pop cl--loop-args) (cl--parse-loop-clause)))
(cl--loop-build-ands (nreverse cl--loop-body))))
(simple (and (eq (car then) t) (eq (car else) t))))
(if (eq (car cl--loop-args) 'end) (pop cl--loop-args))
(push (cons 'progn (nreverse (cons t body))) cl--loop-body)))
((eq word 'return)
- (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-var--")))
- (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--")))
+ (or cl--loop-finish-flag
+ (setq cl--loop-finish-flag (make-symbol "--cl-var--")))
+ (or cl--loop-result-var
+ (setq cl--loop-result-var (make-symbol "--cl-var--")))
(push `(setq ,cl--loop-result-var ,(pop cl--loop-args)
,cl--loop-finish-flag nil) cl--loop-body))
(or handler (error "Expected a cl-loop keyword, found %s" word))
(funcall handler))))
(if (eq (car cl--loop-args) 'and)
- (progn (pop cl--loop-args) (cl-parse-loop-clause)))))
+ (progn (pop cl--loop-args) (cl--parse-loop-clause)))))
(defun cl--loop-let (specs body par) ; uses loop-*
(let ((p specs) (temps nil) (new nil))
(if (and (consp (car specs)) (listp (caar specs)))
(let* ((spec (caar specs)) (nspecs nil)
(expr (cadr (pop specs)))
- (temp (cdr (or (assq spec cl--loop-destr-temps)
- (car (push (cons spec (or (last spec 0)
- (make-symbol "--cl-var--")))
- cl--loop-destr-temps))))))
+ (temp
+ (cdr (or (assq spec cl--loop-destr-temps)
+ (car (push (cons spec
+ (or (last spec 0)
+ (make-symbol "--cl-var--")))
+ cl--loop-destr-temps))))))
(push (list temp expr) new)
(while (consp spec)
(push (list (pop spec)
(setq specs (nconc (nreverse nspecs) specs)))
(push (pop specs) new)))
(if (eq body 'setq)
- (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new)))))
+ (let ((set (cons (if par 'cl-psetq 'setq)
+ (apply 'nconc (nreverse new)))))
(if temps `(let* ,(nreverse temps) ,set) set))
`(,(if par 'let 'let*)
,(nconc (nreverse temps) (nreverse new)) ,@body))))
-(defun cl--loop-handle-accum (def &optional func) ; uses loop-*
+(defun cl--loop-handle-accum (def &optional func) ; uses loop-*
(if (eq (car cl--loop-args) 'into)
- (let ((var (cl-pop2 cl--loop-args)))
+ (let ((var (cl--pop2 cl--loop-args)))
(or (memq var cl--loop-accum-vars)
(progn (push (list (list var def)) cl--loop-bindings)
(push var cl--loop-accum-vars)))
var)
(or cl--loop-accum-var
(progn
- (push (list (list (setq cl--loop-accum-var (make-symbol "--cl-var--")) def))
- cl--loop-bindings)
+ (push (list (list
+ (setq cl--loop-accum-var (make-symbol "--cl-var--"))
+ def))
+ cl--loop-bindings)
(setq cl--loop-result (if func (list func cl--loop-accum-var)
- cl--loop-accum-var))
+ cl--loop-accum-var))
cl--loop-accum-var))))
(defun cl--loop-build-ands (clauses)
((&rest &or symbolp (symbolp &optional form form))
(form body)
cl-declarations body)))
- (cl-expand-do-loop steps endtest body nil))
+ (cl--expand-do-loop steps endtest body nil))
;;;###autoload
(defmacro cl-do* (steps endtest &rest body)
\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
(declare (indent 2) (debug cl-do))
- (cl-expand-do-loop steps endtest body t))
+ (cl--expand-do-loop steps endtest body t))
-(defun cl-expand-do-loop (steps endtest body star)
+(defun cl--expand-do-loop (steps endtest body star)
`(cl-block nil
(,(if star 'let* 'let)
,(mapcar (lambda (c) (if (consp c) (list (car c) (nth 1 c)) c))
(if (advice-member-p #'cl--wrap-in-nil-block 'dotimes)
loop `(cl-block nil ,loop))))
+(defvar cl--tagbody-alist nil)
+
+;;;###autoload
+(defmacro cl-tagbody (&rest labels-or-stmts)
+ "Execute statements while providing for control transfers to labels.
+Each element of LABELS-OR-STMTS can be either a label (integer or symbol)
+or a `cons' cell, in which case it's taken to be a statement.
+This distinction is made before performing macroexpansion.
+Statements are executed in sequence left to right, discarding any return value,
+stopping only when reaching the end of LABELS-OR-STMTS.
+Any statement can transfer control at any time to the statements that follow
+one of the labels with the special form (go LABEL).
+Labels have lexical scope and dynamic extent."
+ (let ((blocks '())
+ (first-label (if (consp (car labels-or-stmts))
+ 'cl--preamble (pop labels-or-stmts))))
+ (let ((block (list first-label)))
+ (dolist (label-or-stmt labels-or-stmts)
+ (if (consp label-or-stmt) (push label-or-stmt block)
+ ;; Add a "go to next block" to implement the fallthrough.
+ (unless (eq 'go (car-safe (car-safe block)))
+ (push `(go ,label-or-stmt) block))
+ (push (nreverse block) blocks)
+ (setq block (list label-or-stmt))))
+ (unless (eq 'go (car-safe (car-safe block)))
+ (push `(go cl--exit) block))
+ (push (nreverse block) blocks))
+ (let ((catch-tag (make-symbol "cl--tagbody-tag")))
+ (push (cons 'cl--exit catch-tag) cl--tagbody-alist)
+ (dolist (block blocks)
+ (push (cons (car block) catch-tag) cl--tagbody-alist))
+ (macroexpand-all
+ `(let ((next-label ',first-label))
+ (while
+ (not (eq (setq next-label
+ (catch ',catch-tag
+ (cl-case next-label
+ ,@blocks)))
+ 'cl--exit))))
+ `((go . ,(lambda (label)
+ (let ((catch-tag (cdr (assq label cl--tagbody-alist))))
+ (unless catch-tag
+ (error "Unknown cl-tagbody go label `%S'" label))
+ `(throw ',catch-tag ',label))))
+ ,@macroexpand-all-environment)))))
+
;;;###autoload
(defmacro cl-do-symbols (spec &rest body)
"Loop over all symbols.
BODY forms are executed and their result is returned. This is much like
a `let' form, except that the list of symbols can be computed at run-time."
(declare (indent 2) (debug (form form body)))
- (let ((bodyfun (make-symbol "cl--progv-body"))
+ (let ((bodyfun (make-symbol "body"))
(binds (make-symbol "binds"))
(syms (make-symbol "syms"))
(vals (make-symbol "vals")))
`(progn
- (defvar ,bodyfun)
(let* ((,syms ,symbols)
(,vals ,values)
(,bodyfun (lambda () ,@body))
(,binds ()))
(while ,syms
(push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds))
- (eval (list 'let ,binds '(funcall ,bodyfun)))))))
+ (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun))))))))
(defvar cl--labels-convert-cache nil)
(declare (indent 1) (debug (cl-type-spec form)))
form)
-(defvar cl-proclaim-history t) ; for future compilers
-(defvar cl-declare-stack t) ; for future compilers
+(defvar cl--proclaim-history t) ; for future compilers
+(defvar cl--declare-stack t) ; for future compilers
-(defun cl-do-proclaim (spec hist)
- (and hist (listp cl-proclaim-history) (push spec cl-proclaim-history))
+(defun cl--do-proclaim (spec hist)
+ (and hist (listp cl--proclaim-history) (push spec cl--proclaim-history))
(cond ((eq (car-safe spec) 'special)
(if (boundp 'byte-compile-bound-variables)
(setq byte-compile-bound-variables
'((0 nil) (1 t) (2 t) (3 t))))
(safety (assq (nth 1 (assq 'safety (cdr spec)))
'((0 t) (1 t) (2 t) (3 nil)))))
- (if speed (setq cl-optimize-speed (car speed)
+ (if speed (setq cl--optimize-speed (car speed)
byte-optimize (nth 1 speed)))
- (if safety (setq cl-optimize-safety (car safety)
+ (if safety (setq cl--optimize-safety (car safety)
byte-compile-delete-errors (nth 1 safety)))))
((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
nil)
;;; Process any proclamations made before cl-macs was loaded.
-(defvar cl-proclaims-deferred)
-(let ((p (reverse cl-proclaims-deferred)))
- (while p (cl-do-proclaim (pop p) t))
- (setq cl-proclaims-deferred nil))
+(defvar cl--proclaims-deferred)
+(let ((p (reverse cl--proclaims-deferred)))
+ (while p (cl--do-proclaim (pop p) t))
+ (setq cl--proclaims-deferred nil))
;;;###autoload
(defmacro cl-declare (&rest specs)
See Info node `(cl)Declarations' for details."
(if (cl--compiling-file)
(while specs
- (if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
- (cl-do-proclaim (pop specs) nil)))
+ (if (listp cl--declare-stack) (push (car specs) cl--declare-stack))
+ (cl--do-proclaim (pop specs) nil)))
nil)
;;; The standard modify macros.
KEYWORD can be one of :conc-name, :constructor, :copier, :predicate,
:type, :named, :initial-offset, :print-function, or :include.
-Each SLOT may instead take the form (SLOT SLOT-OPTS...), where
-SLOT-OPTS are keyword-value pairs for that slot. Currently, only
-one keyword is supported, `:read-only'. If this has a non-nil
+Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where
+SDEFAULT is the default value of that slot and SOPTIONS are keyword-value
+pairs for that slot.
+Currently, only one keyword is supported, `:read-only'. If this has a non-nil
value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)"
(copier (intern (format "copy-%s" name)))
(predicate (intern (format "%s-p" name)))
(print-func nil) (print-auto nil)
- (safety (if (cl--compiling-file) cl-optimize-safety 3))
+ (safety (if (cl--compiling-file) cl--optimize-safety 3))
(include nil)
(tag (intern (format "cl-struct-%s" name)))
(tag-symbol (intern (format "cl-struct-%s-tags" name)))
((memq type '(nil t)) type)
((eq type 'null) `(null ,val))
((eq type 'atom) `(atom ,val))
- ((eq type 'float) `(cl-floatp-safe ,val))
+ ((eq type 'float) `(floatp ,val))
((eq type 'real) `(numberp ,val))
((eq type 'fixnum) `(integerp ,val))
;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef
(if (consp (cadr type)) `(> ,val ,(cl-caadr type))
`(>= ,val ,(cadr type))))
,(if (memq (cl-caddr type) '(* nil)) t
- (if (consp (cl-caddr type)) `(< ,val ,(cl-caaddr type))
+ (if (consp (cl-caddr type))
+ `(< ,val ,(cl-caaddr type))
`(<= ,val ,(cl-caddr type)))))))
((memq (car type) '(and or not))
(cons (car type)
(defun cl-typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
+ (declare (compiler-macro cl--compiler-macro-typep))
(let ((cl--object object)) ;; Yuck!!
(eval (cl--make-type-test 'cl--object type))))
+(defun cl--compiler-macro-typep (form val type)
+ (if (macroexp-const-p type)
+ (macroexp-let2 macroexp-copyable-p temp val
+ (cl--make-type-test temp (cl--const-expr-val type)))
+ form))
+
;;;###autoload
(defmacro cl-check-type (form type &optional string)
"Verify that FORM is of type TYPE; signal an error if not.
STRING is an optional description of the desired type."
(declare (debug (place cl-type-spec &optional stringp)))
(and (or (not (cl--compiling-file))
- (< cl-optimize-speed 3) (= cl-optimize-safety 3))
+ (< cl--optimize-speed 3) (= cl--optimize-safety 3))
(let* ((temp (if (cl--simple-expr-p form 3)
form (make-symbol "--cl-var--")))
(body `(or ,(cl--make-type-test temp type)
omitted, a default message listing FORM itself is used."
(declare (debug (form &rest form)))
(and (or (not (cl--compiling-file))
- (< cl-optimize-speed 3) (= cl-optimize-safety 3))
+ (< cl--optimize-speed 3) (= cl--optimize-safety 3))
(let ((sargs (and show-args
(delq nil (mapcar (lambda (x)
(unless (macroexp-const-p x)
(let ((p args) (res nil))
(while (consp p) (push (pop p) res))
(setq args (nconc (nreverse res) (and p (list '&rest p)))))
- `(cl-eval-when (compile load eval)
- (put ',func 'compiler-macro
- (cl-function (lambda ,(if (memq '&whole args) (delq '&whole args)
- (cons '_cl-whole-arg args))
- ,@body)))
- ;; This is so that describe-function can locate
- ;; the macro definition.
- (let ((file ,(or buffer-file-name
- (and (boundp 'byte-compile-current-file)
- (stringp byte-compile-current-file)
- byte-compile-current-file))))
- (if file (put ',func 'compiler-macro-file
- (purecopy (file-name-nondirectory file)))))))
+ (let ((fname (make-symbol (concat (symbol-name func) "--cmacro"))))
+ `(eval-and-compile
+ ;; Name the compiler-macro function, so that `symbol-file' can find it.
+ (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args)
+ (cons '_cl-whole-arg args))
+ ,@body)
+ (put ',func 'compiler-macro #',fname))))
;;;###autoload
(defun cl-compiler-macroexpand (form)
(setq body (cond ((null substs) body)
((null (cdr substs))
(cl-subst (cdar substs) (caar substs) body))
- (t (cl-sublis substs body))))
+ (t (cl--sublis substs body))))
(if lets `(let ,lets ,body) body))))
+(defun cl--sublis (alist tree)
+ "Perform substitutions indicated by ALIST in TREE (non-destructively)."
+ (let ((x (assq tree alist)))
+ (cond
+ (x (cdr x))
+ ((consp tree)
+ (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree))))
+ (t tree))))
;; Compile-time optimizations for some functions defined in this package.
(cond ((eq test 'eq) `(assq ,a ,list))
((eq test 'equal) `(assoc ,a ,list))
((and (macroexp-const-p a) (or (null keys) (eq test 'eql)))
- (if (cl-floatp-safe (cl--const-expr-val a))
+ (if (floatp (cl--const-expr-val a))
`(assoc ,a ,list) `(assq ,a ,list)))
(t form))))
;;;###autoload
(defun cl--compiler-macro-adjoin (form a list &rest keys)
- (if (and (cl--simple-expr-p a) (cl--simple-expr-p list)
- (not (memq :key keys)))
- `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list))
- form))
+ (if (memq :key keys) form
+ (macroexp-let2 macroexp-copyable-p va a
+ (macroexp-let2 macroexp-copyable-p vlist list
+ `(if (cl-member ,va ,vlist ,@keys) ,vlist (cons ,va ,vlist))))))
(defun cl--compiler-macro-get (_form sym prop &optional def)
(if def
`(cl-getf (symbol-plist ,sym) ,prop ,def)
`(get ,sym ,prop)))
-(cl-define-compiler-macro cl-typep (&whole form val type)
- (if (macroexp-const-p type)
- (macroexp-let2 macroexp-copyable-p temp val
- (cl--make-type-test temp (cl--const-expr-val type)))
- form))
-
(dolist (y '(cl-first cl-second cl-third cl-fourth
cl-fifth cl-sixth cl-seventh
cl-eighth cl-ninth cl-tenth
(put y 'side-effect-free t))
;;; Things that are inline.
-(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany
+(cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany
cl-notevery cl--set-elt cl-revappend cl-nreconc gethash))
;;; Things that are side-effect-free.
(mapc (lambda (x) (put x 'side-effect-free t))
- '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd cl-lcm
- cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq
- cl-list-length cl-get cl-getf))
+ '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd
+ cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem
+ cl-subseq cl-list-length cl-get cl-getf))
;;; Things that are side-effect-and-error-free.
(mapc (lambda (x) (put x 'side-effect-free 'error-free))
- '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp cl-random-state-p
- copy-tree cl-sublis))
+ '(eql cl-list* cl-subst cl-acons cl-equalp
+ cl-random-state-p copy-tree cl-sublis))
(run-hooks 'cl-macs-load-hook)
HCoop / bpt / emacs.git / blobdiff