;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*-
-;; Copyright (C) 1993 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2003, 2004 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;;; Code:
-(require 'help-fns) ;For help-add-fundoc-usage.
-
(or (memq 'cl-19 features)
(error "Tried to load `cl-macs' before `cl'!"))
(run-hooks 'cl-hack-bytecomp-hook))
+;;; Some predicates for analyzing Lisp forms. These are used by various
+;;; macro expanders to optimize the results in certain common cases.
+
+(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
+ car-safe cdr-safe progn prog1 prog2))
+(defconst cl-safe-funcs '(* / % length memq list vector vectorp
+ < > <= >= = error))
+
+;;; Check if no side effects, and executes quickly.
+(defun cl-simple-expr-p (x &optional size)
+ (or size (setq size 10))
+ (if (and (consp x) (not (memq (car x) '(quote function function*))))
+ (and (symbolp (car x))
+ (or (memq (car x) cl-simple-funcs)
+ (get (car x) 'side-effect-free))
+ (progn
+ (setq size (1- size))
+ (while (and (setq x (cdr x))
+ (setq size (cl-simple-expr-p (car x) size))))
+ (and (null x) (>= size 0) size)))
+ (and (> size 0) (1- size))))
+
+(defun cl-simple-exprs-p (xs)
+ (while (and xs (cl-simple-expr-p (car xs)))
+ (setq xs (cdr xs)))
+ (not xs))
+
+;;; Check if no side effects.
+(defun cl-safe-expr-p (x)
+ (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
+ (and (symbolp (car x))
+ (or (memq (car x) cl-simple-funcs)
+ (memq (car x) cl-safe-funcs)
+ (get (car x) 'side-effect-free))
+ (progn
+ (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
+ (null x)))))
+
+;;; Check if constant (i.e., no side effects or dependencies).
+(defun cl-const-expr-p (x)
+ (cond ((consp x)
+ (or (eq (car x) 'quote)
+ (and (memq (car x) '(function function*))
+ (or (symbolp (nth 1 x))
+ (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
+ ((symbolp x) (and (memq x '(nil t)) t))
+ (t t)))
+
+(defun cl-const-exprs-p (xs)
+ (while (and xs (cl-const-expr-p (car xs)))
+ (setq xs (cdr xs)))
+ (not xs))
+
+(defun cl-const-expr-val (x)
+ (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
+
+(defun cl-expr-access-order (x v)
+ (if (cl-const-expr-p x) v
+ (if (consp x)
+ (progn
+ (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
+ v)
+ (if (eq x (car v)) (cdr v) '(t)))))
+
+;;; Count number of times X refers to Y. Return nil for 0 times.
+(defun cl-expr-contains (x y)
+ (cond ((equal y x) 1)
+ ((and (consp x) (not (memq (car-safe x) '(quote function function*))))
+ (let ((sum 0))
+ (while x
+ (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
+ (and (> sum 0) sum)))
+ (t nil)))
+
+(defun cl-expr-contains-any (x y)
+ (while (and y (not (cl-expr-contains x (car y)))) (pop y))
+ y)
+
+;;; Check whether X may depend on any of the symbols in Y.
+(defun cl-expr-depends-p (x y)
+ (and (not (cl-const-expr-p x))
+ (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))
+
;;; Symbols.
(defvar *gensym-counter*)
(nconc (nreverse simple-args)
(list '&rest (car (pop bind-lets))))
(nconc (let ((hdr (nreverse header)))
+ (require 'help-fns)
(cons (help-add-fundoc-usage
- (if (stringp (car hdr)) (pop hdr)) orig-args)
+ (if (stringp (car hdr)) (pop hdr))
+ ;; orig-args can contain &cl-defs (an internal CL
+ ;; thingy that I do not understand), so remove it.
+ (let ((x (memq '&cl-defs orig-args)))
+ (if (null x) orig-args
+ (delq (car x) (remq (cadr x) orig-args)))))
hdr))
(list (nconc (list 'let* bind-lets)
(nreverse bind-forms) body)))))))
Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared
against each key in each KEYLIST; the corresponding BODY is evaluated.
If no clause succeeds, case returns nil. A single atom may be used in
-place of a KEYLIST of one atom. A KEYLIST of `t' or `otherwise' is
+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)))
"Evals EXPR, chooses from CLAUSES on that value.
Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it
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
+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)))
(type-list nil)
(setq var (prog1 other (setq other var))))
(setq loop-map-form
(list (if (memq word '(key-seq key-seqs))
- 'cl-map-keymap-recursively 'cl-map-keymap)
+ 'cl-map-keymap-recursively 'map-keymap)
(list 'function (list* 'lambda (list var other)
'--cl-map)) map))))
(set (car cl-closure-vars) [bad-lexical-ref])
(list (car x) (cadr x) (car cl-closure-vars))))
bindings))
- (ebody
+ (ebody
(cl-macroexpand-all
(cons 'progn body)
(nconc (mapcar (function (lambda (x)
(defsetf process-buffer set-process-buffer)
(defsetf process-filter set-process-filter)
(defsetf process-sentinel set-process-sentinel)
+(defsetf process-get process-put)
(defsetf read-mouse-position (scr) (store)
(list 'set-mouse-position scr (list 'car store) (list 'cdr store)))
(defsetf screen-height set-screen-height t)
(list (list 'or pred-check
(list 'error
(format "%s accessing a non-%s"
- accessor name)
- 'cl-x))))
+ accessor name)))))
(list (if (eq type 'vector) (list 'aref 'cl-x pos)
(if (= pos 0) '(car cl-x)
(list 'nth pos 'cl-x)))))) forms)
(list (list 'or (subst temp 'cl-x pred-form)
(list 'error
(format
- "%s storing a non-%s" accessor name)
- temp))))
+ "%s storing a non-%s" accessor name)))))
(list (if (eq (car (get name 'cl-struct-type)) 'vector)
(list 'aset temp pos store)
(list 'setcar
`(condition-case nil (progn ,@body) (error nil)))
-;;; Some predicates for analyzing Lisp forms. These are used by various
-;;; macro expanders to optimize the results in certain common cases.
-
-(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
- car-safe cdr-safe progn prog1 prog2))
-(defconst cl-safe-funcs '(* / % length memq list vector vectorp
- < > <= >= = error))
-
-;;; Check if no side effects, and executes quickly.
-(defun cl-simple-expr-p (x &optional size)
- (or size (setq size 10))
- (if (and (consp x) (not (memq (car x) '(quote function function*))))
- (and (symbolp (car x))
- (or (memq (car x) cl-simple-funcs)
- (get (car x) 'side-effect-free))
- (progn
- (setq size (1- size))
- (while (and (setq x (cdr x))
- (setq size (cl-simple-expr-p (car x) size))))
- (and (null x) (>= size 0) size)))
- (and (> size 0) (1- size))))
-
-(defun cl-simple-exprs-p (xs)
- (while (and xs (cl-simple-expr-p (car xs)))
- (setq xs (cdr xs)))
- (not xs))
-
-;;; Check if no side effects.
-(defun cl-safe-expr-p (x)
- (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
- (and (symbolp (car x))
- (or (memq (car x) cl-simple-funcs)
- (memq (car x) cl-safe-funcs)
- (get (car x) 'side-effect-free))
- (progn
- (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
- (null x)))))
-
-;;; Check if constant (i.e., no side effects or dependencies).
-(defun cl-const-expr-p (x)
- (cond ((consp x)
- (or (eq (car x) 'quote)
- (and (memq (car x) '(function function*))
- (or (symbolp (nth 1 x))
- (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
- ((symbolp x) (and (memq x '(nil t)) t))
- (t t)))
-
-(defun cl-const-exprs-p (xs)
- (while (and xs (cl-const-expr-p (car xs)))
- (setq xs (cdr xs)))
- (not xs))
-
-(defun cl-const-expr-val (x)
- (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
-
-(defun cl-expr-access-order (x v)
- (if (cl-const-expr-p x) v
- (if (consp x)
- (progn
- (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
- v)
- (if (eq x (car v)) (cdr v) '(t)))))
-
-;;; Count number of times X refers to Y. Return nil for 0 times.
-(defun cl-expr-contains (x y)
- (cond ((equal y x) 1)
- ((and (consp x) (not (memq (car-safe x) '(quote function function*))))
- (let ((sum 0))
- (while x
- (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
- (and (> sum 0) sum)))
- (t nil)))
-
-(defun cl-expr-contains-any (x y)
- (while (and y (not (cl-expr-contains x (car y)))) (pop y))
- y)
-
-;;; Check whether X may depend on any of the symbols in Y.
-(defun cl-expr-depends-p (x y)
- (and (not (cl-const-expr-p x))
- (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))
-
-
;;; Compiler macros.
(defmacro define-compiler-macro (func args &rest body)
(list 'progn
(if p nil ; give up if defaults refer to earlier args
(list 'define-compiler-macro name
- (list* '&whole 'cl-whole '&cl-quote args)
+ (if (memq '&key args)
+ (list* '&whole 'cl-whole '&cl-quote args)
+ (cons '&cl-quote args))
(list* 'cl-defsubst-expand (list 'quote argns)
(list 'quote (list* 'block name body))
(not (or unsafe (cl-expr-access-order pbody argns)))
(run-hooks 'cl-macs-load-hook)
+;;; Local variables:
+;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime)
+;;; End:
+
+;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
;;; cl-macs.el ends here