X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/3d136b1b7246eae2a86b4444904f02b77dc8951d..4d3b8872ad53ef6352f769df84c26b0f835ede3a:/lisp/emacs-lisp/cl-macs.el diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b1861cf7df..5b608f0093 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -89,10 +89,11 @@ ;; 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)) +(eval-and-compile + (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))) (defun cl--simple-expr-p (x &optional size) "Check if no side effects, and executes quickly." @@ -113,16 +114,17 @@ (setq xs (cdr xs))) (not xs)) -(defun cl--safe-expr-p (x) - "Check if no side effects." - (or (not (and (consp x) (not (memq (car x) '(quote function cl-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))))) +(eval-and-compile + (defun cl--safe-expr-p (x) + "Check if no side effects." + (or (not (and (consp x) (not (memq (car x) '(quote function cl-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) @@ -135,22 +137,29 @@ (t t))) (defun cl--const-expr-val (x) - (and (macroexp-const-p x) (if (consp x) (nth 1 x) x))) - -(defun cl--expr-contains (x y) - "Count number of times X refers to Y. Return nil for 0 times." - ;; FIXME: This is naive, and it will cl-count Y as referred twice in - ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on - ;; non-macroexpanded code, so it may also miss some occurrences that would - ;; only appear in the expanded code. - (cond ((equal y x) 1) - ((and (consp x) (not (memq (car x) '(quote function cl-function)))) - (let ((sum 0)) - (while (consp x) - (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0)))) - (setq sum (+ sum (or (cl--expr-contains x y) 0))) - (and (> sum 0) sum))) - (t nil))) + "Return the value of X known at compile-time. +If X is not known at compile time, return nil. Before testing +whether X is known at compile time, macroexpand it completely in +`macroexpand-all-environment'." + (let ((x (macroexpand-all x macroexpand-all-environment))) + (if (macroexp-const-p x) + (if (consp x) (nth 1 x) x)))) + +(eval-and-compile + (defun cl--expr-contains (x y) + "Count number of times X refers to Y. Return nil for 0 times." + ;; FIXME: This is naive, and it will cl-count Y as referred twice in + ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on + ;; non-macroexpanded code, so it may also miss some occurrences that would + ;; only appear in the expanded code. + (cond ((equal y x) 1) + ((and (consp x) (not (memq (car x) '(quote function cl-function)))) + (let ((sum 0)) + (while (consp x) + (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0)))) + (setq sum (+ sum (or (cl--expr-contains x y) 0))) + (and (> sum 0) sum))) + (t nil)))) (defun cl--expr-contains-any (x y) (while (and y (not (cl--expr-contains x (car y)))) (pop y)) @@ -211,71 +220,73 @@ The name is made by appending a number to PREFIX, default \"G\"." (def-edebug-spec cl-type-spec sexp) -(defconst cl--lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) +(eval-and-compile + (defconst cl--lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) -(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) -(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) + (defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) + (defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)) -(defun cl--transform-lambda (form bind-block) - "Transform a function form FORM of name BIND-BLOCK. +(eval-and-compile + (defun cl--transform-lambda (form bind-block) + "Transform a function form FORM of name BIND-BLOCK. BIND-BLOCK is the name of the symbol to which the function will be bound, and which will be used for the name of the `cl-block' surrounding the function's body. FORM is of the form (ARGS . BODY)." - (let* ((args (car form)) (body (cdr form)) (orig-args args) - (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) - (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) - (header nil) (simple-args nil)) - (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare cl-declare))) - (push (pop body) header)) - (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) - (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq cl--bind-defs args)) - cl--bind-defs (cadr cl--bind-defs))) - (if (setq cl--bind-enquote (memq '&cl-quote args)) - (setq args (delq '&cl-quote args))) - (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p)) - (env-exp 'macroexpand-all-environment)) - (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v env-exp)))))) - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or cl--bind-defs (consp (cadr args)))))) - (push (pop args) simple-args)) - (or (eq cl--bind-block 'cl-none) - (setq body (list `(cl-block ,cl--bind-block ,@body)))) - (if (null args) - (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) - (if (memq '&optional simple-args) (push '&optional args)) - (cl--do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq cl--bind-lets (nreverse cl--bind-lets)) - (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) - ,@(nreverse cl--bind-inits))) - (nconc (nreverse simple-args) - (list '&rest (car (pop cl--bind-lets)))) - (nconc (let ((hdr (nreverse header))) - ;; Macro expansion can take place in the middle of - ;; apparently harmless computation, so it should not - ;; touch the match-data. - (save-match-data - (require 'help-fns) - (cons (help-add-fundoc-usage - (if (stringp (car hdr)) (pop hdr)) - ;; Be careful with make-symbol and (back)quote, - ;; see bug#12884. - (let ((print-gensym nil) (print-quoted t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args))))) - hdr))) - (list `(let* ,cl--bind-lets - ,@(nreverse cl--bind-forms) - ,@body))))))) + (let* ((args (car form)) (body (cdr form)) (orig-args args) + (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) + (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) + (header nil) (simple-args nil)) + (while (or (stringp (car body)) + (memq (car-safe (car body)) '(interactive declare cl-declare))) + (push (pop body) header)) + (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) + (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) + (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) + (setq args (delq '&cl-defs (delq cl--bind-defs args)) + cl--bind-defs (cadr cl--bind-defs))) + (if (setq cl--bind-enquote (memq '&cl-quote args)) + (setq args (delq '&cl-quote args))) + (if (memq '&whole args) (error "&whole not currently implemented")) + (let* ((p (memq '&environment args)) (v (cadr p)) + (env-exp 'macroexpand-all-environment)) + (if p (setq args (nconc (delq (car p) (delq v args)) + (list '&aux (list v env-exp)))))) + (while (and args (symbolp (car args)) + (not (memq (car args) '(nil &rest &body &key &aux))) + (not (and (eq (car args) '&optional) + (or cl--bind-defs (consp (cadr args)))))) + (push (pop args) simple-args)) + (or (eq cl--bind-block 'cl-none) + (setq body (list `(cl-block ,cl--bind-block ,@body)))) + (if (null args) + (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (if (memq '&optional simple-args) (push '&optional args)) + (cl--do-arglist args nil (- (length simple-args) + (if (memq '&optional simple-args) 1 0))) + (setq cl--bind-lets (nreverse cl--bind-lets)) + (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) + ,@(nreverse cl--bind-inits))) + (nconc (nreverse simple-args) + (list '&rest (car (pop cl--bind-lets)))) + (nconc (let ((hdr (nreverse header))) + ;; Macro expansion can take place in the middle of + ;; apparently harmless computation, so it should not + ;; touch the match-data. + (save-match-data + (require 'help-fns) + (cons (help-add-fundoc-usage + (if (stringp (car hdr)) (pop hdr)) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + (let ((print-gensym nil) (print-quoted t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args))))) + hdr))) + (list `(let* ,cl--bind-lets + ,@(nreverse cl--bind-forms) + ,@body)))))))) ;;;###autoload (defmacro cl-defun (name args &rest body) @@ -376,8 +387,6 @@ its argument list allows full Common Lisp conventions." (if (car res) `(progn ,(car res) ,form) form)) `(function ,func))) -(declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) - (defun cl--make-usage-var (x) "X can be a var or a (destructuring) lambda-list." (cond @@ -503,7 +512,7 @@ its argument list allows full Common Lisp conventions." (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) - (look `(memq ',karg ,restarg))) + (look `(plist-member ,restarg ',karg))) (and def cl--bind-enquote (setq def `',def)) (if (cddr arg) (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) @@ -549,17 +558,18 @@ its argument list allows full Common Lisp conventions." (cl--do-arglist (pop args) nil)))) (if args (error "Malformed argument list %s" save-args))))) -(defun cl--arglist-args (args) - (if (nlistp args) (list args) - (let ((res nil) (kind nil) arg) - (while (consp args) - (setq arg (pop args)) - (if (memq arg cl--lambda-list-keywords) (setq kind arg) - (if (eq arg '&cl-defs) (pop args) - (and (consp arg) kind (setq arg (car arg))) - (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) - (setq res (nconc res (cl--arglist-args arg)))))) - (nconc res (and args (list args)))))) +(eval-and-compile + (defun cl--arglist-args (args) + (if (nlistp args) (list args) + (let ((res nil) (kind nil) arg) + (while (consp args) + (setq arg (pop args)) + (if (memq arg cl--lambda-list-keywords) (setq kind arg) + (if (eq arg '&cl-defs) (pop args) + (and (consp arg) kind (setq arg (car arg))) + (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) + (setq res (nconc res (cl--arglist-args arg)))))) + (nconc res (and args (list args))))))) ;;;###autoload (defmacro cl-destructuring-bind (args expr &rest body) @@ -755,16 +765,17 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "cl-loop" macro. -(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) -(defvar cl--loop-bindings) (defvar cl--loop-body) -(defvar cl--loop-finally) -(defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? -(defvar cl--loop-first-flag) -(defvar cl--loop-initially) (defvar cl--loop-iterator-function) -(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) +(eval-and-compile + (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) + (defvar cl--loop-bindings) (defvar cl--loop-body) + (defvar cl--loop-finally) + (defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? + (defvar cl--loop-first-flag) + (defvar cl--loop-initially) (defvar cl--loop-iterator-function) + (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)) (defun cl--loop-set-iterator-function (kind iterator) (if cl--loop-iterator-function @@ -1542,12 +1553,14 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (if (and (cl--unused-var-p temp) (null expr)) nil ;; Don't bother declaring/setting `temp' since it won't ;; be used when `expr' is nil, anyway. - (when (and (eq body 'setq) (cl--unused-var-p temp)) + (when (or (null temp) + (and (eq body 'setq) (cl--unused-var-p temp))) ;; Prefer a fresh uninterned symbol over "_to", to avoid ;; warnings that we set an unused variable. (setq temp (make-symbol "--cl-var--")) ;; Make sure this temp variable is locally declared. - (push (list (list temp)) cl--loop-bindings)) + (when (eq body 'setq) + (push (list (list temp)) cl--loop-bindings))) (push (list temp expr) new)) (while (consp spec) (push (list (pop spec) @@ -1878,13 +1891,13 @@ This is like `cl-flet', but for macros instead of functions. cl-declarations body))) (if (cdr bindings) `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) - (if (null bindings) (cons 'progn body) + (if (null bindings) (macroexp-progn body) (let* ((name (caar bindings)) (res (cl--transform-lambda (cdar bindings) name))) (eval (car res)) - (macroexpand-all (cons 'progn body) - (cons (cons name `(lambda ,@(cdr res))) - macroexpand-all-environment)))))) + (macroexpand-all (macroexp-progn body) + (cons (cons name `(lambda ,@(cdr res))) + macroexpand-all-environment)))))) (defconst cl--old-macroexpand (if (and (boundp 'cl--old-macroexpand) @@ -2057,10 +2070,21 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (declare (debug t)) (cons 'progn body)) ;;;###autoload -(defmacro cl-the (_type form) - "At present this ignores TYPE and is simply equivalent to FORM." +(defmacro cl-the (type form) + "Return FORM. If type-checking is enabled, assert that it is of TYPE." (declare (indent 1) (debug (cl-type-spec form))) - form) + (if (not (or (not (cl--compiling-file)) + (< cl--optimize-speed 3) + (= cl--optimize-safety 3))) + form + (let* ((temp (if (cl--simple-expr-p form 3) + form (make-symbol "--cl-var--"))) + (body `(progn (unless ,(cl--make-type-test temp type) + (signal 'wrong-type-argument + (list ',type ,temp ',form))) + ,temp))) + (if (eq temp form) body + `(let ((,temp ,form)) ,body))))) (defvar cl--proclaim-history t) ; for future compilers (defvar cl--declare-stack t) ; for future compilers @@ -2572,21 +2596,38 @@ non-nil value, that slot cannot be set via `setf'. (put ',name 'cl-struct-include ',include) (put ',name 'cl-struct-print ,print-auto) ,@(mapcar (lambda (x) - `(put ',(car x) 'side-effect-free ',(cdr x))) + `(function-put ',(car x) 'side-effect-free ',(cdr x))) side-eff)) forms) `(progn ,@(nreverse (cons `',name forms))))) -;;; Types and assertions. - -;;;###autoload -(defmacro cl-deftype (name arglist &rest body) - "Define NAME as a new data type. -The type name can then be used in `cl-typecase', `cl-check-type', etc." - (declare (debug cl-defmacro) (doc-string 3)) - `(cl-eval-when (compile load eval) - (put ',name 'cl-deftype-handler - (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body))))) +(defun cl-struct-sequence-type (struct-type) + "Return the sequence used to build STRUCT-TYPE. +STRUCT-TYPE is a symbol naming a struct type. Return 'vector or +'list, or nil if STRUCT-TYPE is not a struct type. " + (declare (side-effect-free t) (pure t)) + (car (get struct-type 'cl-struct-type))) + +(defun cl-struct-slot-info (struct-type) + "Return a list of slot names of struct STRUCT-TYPE. +Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a +slot name symbol and OPTS is a list of slot options given to +`cl-defstruct'. Dummy slots that represent the struct name and +slots skipped by :initial-offset may appear in the list." + (declare (side-effect-free t) (pure t)) + (get struct-type 'cl-struct-slots)) + +(defun cl-struct-slot-offset (struct-type slot-name) + "Return the offset of slot SLOT-NAME in STRUCT-TYPE. +The returned zero-based slot index is relative to the start of +the structure data type and is adjusted for any structure name +and :initial-offset slots. Signal error if struct STRUCT-TYPE +does not contain SLOT-NAME." + (declare (side-effect-free t) (pure t)) + (or (cl-position slot-name + (cl-struct-slot-info struct-type) + :key #'car :test #'eq) + (error "struct %s has no slot %s" struct-type slot-name))) (defvar byte-compile-function-environment) (defvar byte-compile-macro-environment) @@ -2873,19 +2914,47 @@ The function's arguments should be treated as immutable. ;;; Things that are inline. (cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany - cl-notevery cl--set-elt cl-revappend cl-nreconc gethash)) + cl-notevery cl-revappend cl-nreconc gethash)) ;;; Things that are side-effect-free. -(mapc (lambda (x) (put x 'side-effect-free t)) +(mapc (lambda (x) (function-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)) ;;; Things that are side-effect-and-error-free. -(mapc (lambda (x) (put x 'side-effect-free 'error-free)) +(mapc (lambda (x) (function-put x 'side-effect-free 'error-free)) '(eql cl-list* cl-subst cl-acons cl-equalp cl-random-state-p copy-tree cl-sublis)) +;;; Types and assertions. + +;;;###autoload +(defmacro cl-deftype (name arglist &rest body) + "Define NAME as a new data type. +The type name can then be used in `cl-typecase', `cl-check-type', etc." + (declare (debug cl-defmacro) (doc-string 3) (indent 2)) + `(cl-eval-when (compile load eval) + (put ',name 'cl-deftype-handler + (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body))))) + +;;; Additional functions that we can now define because we've defined +;;; `cl-defsubst' and `cl-typep'. + +(cl-defsubst cl-struct-slot-value (struct-type slot-name inst) + ;; The use of `cl-defsubst' here gives us both a compiler-macro + ;; and a gv-expander "for free". + "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. +STRUCT and SLOT-NAME are symbols. INST is a structure instance." + (declare (side-effect-free t)) + (unless (cl-typep inst struct-type) + (signal 'wrong-type-argument (list struct-type inst))) + ;; We could use `elt', but since the byte compiler will resolve the + ;; branch below at compile time, it's more efficient to use the + ;; type-specific accessor. + (if (eq (cl-struct-sequence-type struct-type) 'vector) + (aref inst (cl-struct-slot-offset struct-type slot-name)) + (nth (cl-struct-slot-offset struct-type slot-name) inst))) (run-hooks 'cl-macs-load-hook)