-;;; cl-macs.el --- Common Lisp macros
+;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*-
;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
(defvar cl-optimize-safety)
(defvar cl-optimize-speed)
-
-;; This kludge allows macros which use cl--transform-function-property
-;; to be called at compile-time.
-
-(eval-and-compile
- (or (fboundp 'cl--transform-function-property)
- (defun cl--transform-function-property (n p f)
- `(put ',n ',p #'(lambda . ,f)))))
-
;;; Initialization.
;;; Some predicates for analyzing Lisp forms.
(def-edebug-spec cl-&key-arg
(&or ([&or (symbolp arg) arg] &optional def-form arg) arg))
+(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)
+
+(defun cl--transform-lambda (form bind-block)
+ (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 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))
+ (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)
"Define NAME as a function.
(if (car res) `(progn ,(car res) ,form) form))
`(function ,func)))
-(defun cl--transform-function-property (func prop form)
- (let ((res (cl--transform-lambda form func)))
- `(progn ,@(cdr (cdr (car res)))
- (put ',func ',prop #'(lambda . ,(cdr res))))))
-
-(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)
-
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
(defun cl--make-usage-var (x)
))))
arglist)))
-(defun cl--transform-lambda (form cl-bind-block)
- (let* ((args (car form)) (body (cdr form)) (orig-args args)
- (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 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))
- (format "%S"
- (cons 'fn
- (cl--make-usage-args orig-args))))
- hdr)))
- (list `(let* ,cl-bind-lets
- ,@(nreverse cl-bind-forms)
- ,@body)))))))
-
(defun cl--do-arglist (args expr &optional num) ; uses bind-*
(if (nlistp args)
- (if (or (memq args cl-lambda-list-keywords) (not (symbolp args)))
+ (if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
(error "Invalid argument name: %s" args)
- (push (list args expr) cl-bind-lets))
+ (push (list args expr) cl--bind-lets))
(setq args (cl-copy-list args))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(let ((p (memq '&body args))) (if p (setcar p '&rest)))
(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))
(if (listp (cadr restarg))
(setq restarg (make-symbol "--cl-rest--"))
(setq restarg (cadr restarg)))
- (push (list restarg expr) cl-bind-lets)
+ (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)))
+ (while (and p (not (memq (car p) cl--lambda-list-keywords)))
(or (eq p args) (setq minarg (list 'cdr minarg)))
(setq p (cdr p)))
(if (memq (car p) '(nil &aux))
(setq minarg `(= (length ,restarg)
,(length (cl-ldiff args p)))
exactarg (not (eq args p)))))
- (while (and args (not (memq (car args) cl-lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
restarg)))
(cl--do-arglist
(if (or laterarg (= safety 0)) poparg
`(if ,minarg ,poparg
(signal 'wrong-number-of-arguments
- (list ,(and (not (eq cl-bind-block 'cl-none))
- `',cl-bind-block)
+ (list ,(and (not (eq cl--bind-block 'cl-none))
+ `',cl--bind-block)
(length ,restarg)))))))
(setq num (1+ num) laterarg t))
(while (and (eq (car args) '&optional) (pop args))
- (while (and args (not (memq (car args) cl-lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t)))
(let ((def (if (cdr arg) (nth 1 arg)
- (or (car cl-bind-defs)
- (nth 1 (assq (car arg) cl-bind-defs)))))
+ (or (car cl--bind-defs)
+ (nth 1 (assq (car arg) cl--bind-defs)))))
(poparg `(pop ,restarg)))
- (and def cl-bind-enquote (setq def `',def))
+ (and def cl--bind-enquote (setq def `',def))
(cl--do-arglist (car arg)
(if def `(if ,restarg ,poparg ,def) poparg))
(setq num (1+ num))))))
(push `(if ,restarg
(signal 'wrong-number-of-arguments
(list
- ,(and (not (eq cl-bind-block 'cl-none))
- `',cl-bind-block)
+ ,(and (not (eq cl--bind-block 'cl-none))
+ `',cl--bind-block)
(+ ,num (length ,restarg)))))
- cl-bind-forms)))
+ cl--bind-forms)))
(while (and (eq (car args) '&key) (pop args))
- (while (and args (not (memq (car args) cl-lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(let* ((karg (if (consp (car arg)) (caar arg)
(intern (format ":%s" (car arg)))))
(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)))))
+ (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs)))))
(look `(memq ',karg ,restarg)))
- (and def cl-bind-enquote (setq def `',def))
+ (and def cl--bind-enquote (setq def `',def))
(if (cddr arg)
(let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
(val `(car (cdr ,temp))))
,(format "Keyword argument %%s not one of %s"
keys)
(car ,var)))))))
- (push `(let ((,var ,restarg)) ,check) cl-bind-forms)))
+ (push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
(while (and (eq (car args) '&aux) (pop args))
- (while (and args (not (memq (car args) cl-lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl--lambda-list-keywords)))
(if (consp (car args))
- (if (and cl-bind-enquote (cl-cadar args))
+ (if (and cl--bind-enquote (cl-cadar args))
(cl--do-arglist (caar args)
`',(cadr (pop args)))
(cl--do-arglist (caar args) (cadr (pop 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 (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)))
(defmacro cl-destructuring-bind (args expr &rest body)
(declare (indent 2)
(debug (&define cl-macro-list def-form cl-declarations def-body)))
- (let* ((cl-bind-lets nil) (cl-bind-forms nil) (cl-bind-inits nil)
- (cl-bind-defs nil) (cl-bind-block 'cl-none) (cl-bind-enquote nil))
+ (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil)
+ (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil))
(cl--do-arglist (or args '(&aux)) expr)
- (append '(progn) cl-bind-inits
- (list `(let* ,(nreverse cl-bind-lets)
- ,@(nreverse cl-bind-forms) ,@body)))))
+ (append '(progn) cl--bind-inits
+ (list `(let* ,(nreverse cl--bind-lets)
+ ,@(nreverse cl--bind-forms) ,@body)))))
;;; The `cl-eval-when' form.
\(fn (WHEN...) BODY...)"
(declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body)))
- (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
+ (if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
(not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
(cl-not-toplevel t))
(t (eval form) form)))
;;;###autoload
-(defmacro cl-load-time-value (form &optional read-only)
+(defmacro cl-load-time-value (form &optional _read-only)
"Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
(declare (debug (form &optional sexp)))
- (if (cl-compiling-file)
+ (if (cl--compiling-file)
(let* ((temp (cl-gentemp "--cl-load-time--"))
(set `(set ',temp ,form)))
(if (and (fboundp 'byte-compile-file-form-defmumble)
called from BODY."
(declare (indent 1) (debug (symbolp body)))
(if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body)
- `(cl-block-wrapper
+ `(cl--block-wrapper
(catch ',(intern (format "--cl-block-%s--" name))
,@body))))
`defmacro' do not create implicit blocks as they do in Common Lisp."
(declare (indent 1) (debug (symbolp &optional form)))
(let ((name2 (intern (format "--cl-block-%s--" name))))
- `(cl-block-throw ',name2 ,result)))
+ `(cl--block-throw ',name2 ,result)))
;;; The "cl-loop" macro.
(defvar cl--loop-result-var) (defvar cl--loop-steps) (defvar cl--loop-symbol-macs)
;;;###autoload
-(defmacro cl-loop (&rest cl--loop-args)
+(defmacro cl-loop (&rest loop-args)
"The Common Lisp `cl-loop' macro.
Valid clauses are:
for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
\(fn CLAUSE...)"
(declare (debug (&rest &or symbolp form)))
- (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list cl--loop-args))))))
- `(cl-block nil (while t ,@cl--loop-args))
- (let ((cl--loop-name nil) (cl--loop-bindings nil)
+ (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-result nil) (cl--loop-result-explicit nil)
(cl--loop-result-var nil) (cl--loop-finish-flag nil)
(let ((temp-len (make-symbol "--cl-len--")))
(push (list temp-len `(length ,temp-seq))
loop-for-bindings)
- (push (list var `(elt ,temp-seq temp-idx))
+ (push (list var `(elt ,temp-seq ,temp-idx))
cl--loop-symbol-macs)
(push `(< ,temp-idx ,temp-len) cl--loop-body))
(push (list var nil) loop-for-bindings)
((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-extents
+ `(cl--map-overlays
(lambda (,var ,(make-symbol "--cl-var--"))
(progn . --cl-map) nil)
,buf ,from ,to))))
(setq var1 (car var) var2 (cdr var))
(push (list var `(cons ,var1 ,var2)) loop-for-sets))
(setq cl--loop-map-form
- `(cl-map-intervals
+ `(cl--map-intervals
(lambda (,var1 ,var2) . --cl-map)
,buf ,prop ,from ,to))))
(setq var (prog1 other (setq other var))))
(setq cl--loop-map-form
`(,(if (memq word '(key-seq key-seqs))
- 'cl-map-keymap-recursively 'map-keymap)
+ 'cl--map-keymap-recursively 'map-keymap)
(lambda (,var ,other) . --cl-map) ,cl-map))))
((memq word '(frame frames screen screens))
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 ((cl-progv-save nil))
+ `(let ((cl--progv-save nil))
(unwind-protect
- (progn (cl-progv-before ,symbols ,values) ,@body)
- (cl-progv-after))))
+ (progn (cl--progv-before ,symbols ,values) ,@body)
+ (cl--progv-after))))
(defvar cl--labels-convert-cache nil)
(declare (debug t))
(cons 'progn body))
;;;###autoload
-(defmacro cl-the (type form)
+(defmacro cl-the (_type form)
(declare (indent 1) (debug (cl-type-spec form)))
form)
will turn off byte-compile warnings in the function.
See Info node `(cl)Declarations' for details."
- (if (cl-compiling-file)
+ (if (cl--compiling-file)
(while specs
(if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
(cl-do-proclaim (pop specs) nil)))
`(cl-eval-when (compile load eval)
,@(if (stringp (car body))
(list `(put ',func 'setf-documentation ,(pop body))))
- ,(cl--transform-function-property
- func 'setf-method (cons args body))))
+ (put ',func 'setf-method (cl-function (lambda ,args ,@body)))))
;;;###autoload
(defmacro cl-defsetf (func arg1 &rest args)
(cl-defsetf buffer-name rename-buffer t)
(cl-defsetf buffer-string () (store)
`(progn (erase-buffer) (insert ,store)))
-(cl-defsetf buffer-substring cl-set-buffer-substring)
+(cl-defsetf buffer-substring cl--set-buffer-substring)
(cl-defsetf current-buffer set-buffer)
(cl-defsetf current-case-table set-case-table)
(cl-defsetf current-column move-to-column t)
(cl-defsetf file-modes set-file-modes t)
(cl-defsetf frame-height set-screen-height t)
(cl-defsetf frame-parameters modify-frame-parameters t)
-(cl-defsetf frame-visible-p cl-set-frame-visible-p)
+(cl-defsetf frame-visible-p cl--set-frame-visible-p)
(cl-defsetf frame-width set-screen-width t)
(cl-defsetf frame-parameter set-frame-parameter t)
(cl-defsetf terminal-parameter set-terminal-parameter)
(cons n (nth 1 method))
(list store-temp)
`(let ((,(car (nth 2 method))
- (cl-set-nthcdr ,n-temp ,(nth 4 method)
- ,store-temp)))
+ (cl--set-nthcdr ,n-temp ,(nth 4 method)
+ ,store-temp)))
,(nth 3 method) ,store-temp)
`(nthcdr ,n-temp ,(nth 4 method)))))
(append (nth 1 method) (list tag def))
(list store-temp)
`(let ((,(car (nth 2 method))
- (cl-set-getf ,(nth 4 method) ,tag-temp ,store-temp)))
+ (cl--set-getf ,(nth 4 method) ,tag-temp ,store-temp)))
,(nth 3 method) ,store-temp)
`(cl-getf ,(nth 4 method) ,tag-temp ,def-temp))))
(append (nth 1 method) (list from to))
(list store-temp)
`(let ((,(car (nth 2 method))
- (cl-set-substring ,(nth 4 method)
- ,from-temp ,to-temp ,store-temp)))
+ (cl--set-substring ,(nth 4 method)
+ ,from-temp ,to-temp ,store-temp)))
,(nth 3 method) ,store-temp)
`(substring ,(nth 4 method) ,from-temp ,to-temp))))
(if (eq ,ttag (car ,tval))
(progn ,(cl-setf-do-store (nth 1 method) `(cddr ,tval))
t)
- `(cl-do-remf ,tval ,ttag)))))
+ (cl--do-remf ,tval ,ttag)))))
;;;###autoload
(defmacro cl-shiftf (place &rest args)
(declare (indent 1) (debug ((&rest (gate place &optional form)) body)))
(if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
`(let ,bindings ,@body)
- (let ((lets nil) (sets nil)
- (unsets nil) (rev (reverse bindings)))
+ (let ((lets nil)
+ (rev (reverse bindings)))
(while rev
(let* ((place (if (symbolp (caar rev))
`(symbol-value ',(caar rev))
(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)))
(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
(push (cons name t) side-eff))))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
- (if print-func
- (push `(push
- ;; The auto-generated function does not pay attention to
- ;; the depth argument cl-n.
- (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
- (and ,pred-form ,print-func))
- cl-custom-print-functions)
- forms))
+ ;; Don't bother adding to cl-custom-print-functions since it's not used
+ ;; by anything anyway!
+ ;;(if print-func
+ ;; (push `(if (boundp 'cl-custom-print-functions)
+ ;; (push
+ ;; ;; The auto-generated function does not pay attention to
+ ;; ;; the depth argument cl-n.
+ ;; (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
+ ;; (and ,pred-form ,print-func))
+ ;; cl-custom-print-functions))
+ ;; forms))
(push `(setq ,tag-symbol (list ',tag)) forms)
(push `(cl-eval-when (compile load eval)
(put ',name 'cl-struct-slots ',descs)
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)
- ,(cl--transform-function-property
- name 'cl-deftype-handler (cons `(&cl-defs '('*) ,@arglist) body))))
+ (put ',name 'cl-deftype-handler
+ (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
(defun cl--make-type-test (val type)
(if (symbolp type)
((eq (car type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
+(defvar cl--object)
;;;###autoload
(defun cl-typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
- (eval (cl--make-type-test 'object type)))
+ (let ((cl--object object)) ;; Yuck!!
+ (eval (cl--make-type-test 'cl--object type))))
;;;###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))
+ (and (or (not (cl--compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let* ((temp (if (cl--simple-expr-p form 3)
form (make-symbol "--cl-var--")))
They are not evaluated unless the assertion fails. If STRING is
omitted, a default message listing FORM itself is used."
(declare (debug (form &rest form)))
- (and (or (not (cl-compiling-file))
+ (and (or (not (cl--compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let ((sargs (and show-args
(delq nil (mapcar (lambda (x)
(while (consp p) (push (pop p) res))
(setq args (nconc (nreverse res) (and p (list '&rest p)))))
`(cl-eval-when (compile load eval)
- ,(cl--transform-function-property
- func 'compiler-macro
- (cons (if (memq '&whole args) (delq '&whole args)
- (cons '_cl-whole-arg args)) body))
+ (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
(defvar cl--active-block-names nil)
-(cl-define-compiler-macro cl-block-wrapper (cl-form)
+(cl-define-compiler-macro cl--block-wrapper (cl-form)
(let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
(cl--active-block-names (cons cl-entry cl--active-block-names))
(cl-body (macroexpand-all ;Performs compiler-macro expansions.
`(catch ,(nth 1 cl-form) ,@(cdr cl-body))
cl-body)))
-(cl-define-compiler-macro cl-block-throw (cl-tag cl-value)
+(cl-define-compiler-macro cl--block-throw (cl-tag cl-value)
(let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names)))
(if cl-found (setcdr cl-found t)))
`(throw ,cl-tag ,cl-value))
,(if (memq '&key args)
`(&whole cl-whole &cl-quote ,@args)
(cons '&cl-quote args))
- (cl-defsubst-expand
+ (cl--defsubst-expand
',argns '(cl-block ,name ,@body)
;; We used to pass `simple' as
;; (not (or unsafe (cl-expr-access-order pbody argns)))
,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns)))
(cl-defun ,name ,args ,@body))))
-(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
+(defun cl--defsubst-expand (argns body simple whole unsafe &rest argvs)
(if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
(if (cl--simple-exprs-p argvs) (setq simple t))
(let* ((substs ())
;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
;; mainly to make sure these macros will be present.
-(put 'eql 'byte-compile nil)
-(cl-define-compiler-macro eql (&whole form a b)
- (cond ((macroexp-const-p a)
- (let ((val (cl--const-expr-val a)))
- (if (and (numberp val) (not (integerp val)))
- `(equal ,a ,b)
- `(eq ,a ,b))))
- ((macroexp-const-p b)
- (let ((val (cl--const-expr-val b)))
- (if (and (numberp val) (not (integerp val)))
- `(equal ,a ,b)
- `(eq ,a ,b))))
- ((cl--simple-expr-p a 5)
- `(if (numberp ,a)
- (equal ,a ,b)
- (eq ,a ,b)))
- ((and (cl--safe-expr-p a)
- (cl--simple-expr-p b 5))
- `(if (numberp ,b)
- (equal ,a ,b)
- (eq ,a ,b)))
- (t form)))
-
-(cl-define-compiler-macro cl-member (&whole form a list &rest keys)
+(defun cl--compiler-macro-member (form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(cl--const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) `(memq ,a ,list))
((or (null keys) (eq test 'eql)) `(memql ,a ,list))
(t form))))
-(cl-define-compiler-macro cl-assoc (&whole form a list &rest keys)
+(defun cl--compiler-macro-assoc (form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(cl--const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) `(assq ,a ,list))
`(assoc ,a ,list) `(assq ,a ,list)))
(t form))))
-(cl-define-compiler-macro cl-adjoin (&whole form a list &rest keys)
+;;;###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))
-(cl-define-compiler-macro cl-list* (arg &rest others)
+;;;###autoload
+(defun cl--compiler-macro-list* (_form arg &rest others)
(let* ((args (reverse (cons arg others)))
(form (car args)))
(while (setq args (cdr args))
(setq form `(cons ,(car args) ,form)))
form))
-(cl-define-compiler-macro cl-get (sym prop &optional def)
+(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)
- (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 (make-symbol "--cl-var--")))
- `(let ((,temp ,val)) ,(cl-subst temp val res)))))
+ (macroexp-let² macroexp-copyable-p temp val
+ (cl--make-type-test temp (cl--const-expr-val type)))
form))
-
-(mapc (lambda (y)
- (put (car y) 'side-effect-free t)
- (put (car y) 'compiler-macro
- `(lambda (_w x)
- ,(if (symbolp (cadr y))
- `(list ',(cadr y)
- (list ',(cl-caddr y) x))
- (cons 'list (cdr y))))))
- '((cl-first 'car x) (cl-second 'cadr x) (cl-third 'cl-caddr x) (cl-fourth 'cl-cadddr x)
- (cl-fifth 'nth 4 x) (cl-sixth 'nth 5 x) (cl-seventh 'nth 6 x)
- (cl-eighth 'nth 7 x) (cl-ninth 'nth 8 x) (cl-tenth 'nth 9 x)
- (cl-rest 'cdr x) (cl-endp 'null x) (cl-plusp '> x 0) (cl-minusp '< x 0)
- (cl-caaar car caar) (cl-caadr car cadr) (cl-cadar car cdar)
- (cl-caddr car cddr) (cl-cdaar cdr caar) (cl-cdadr cdr cadr)
- (cl-cddar cdr cdar) (cl-cdddr cdr cddr) (cl-caaaar car cl-caaar)
- (cl-caaadr car cl-caadr) (cl-caadar car cl-cadar) (cl-caaddr car cl-caddr)
- (cl-cadaar car cl-cdaar) (cl-cadadr car cl-cdadr) (cl-caddar car cl-cddar)
- (cl-cadddr car cl-cdddr) (cl-cdaaar cdr cl-caaar) (cl-cdaadr cdr cl-caadr)
- (cl-cdadar cdr cl-cadar) (cl-cdaddr cdr cl-caddr) (cl-cddaar cdr cl-cdaar)
- (cl-cddadr cdr cl-cdadr) (cl-cdddar cdr cl-cddar) (cl-cddddr cdr cl-cdddr) ))
+;;;###autoload
+(defun cl--compiler-macro-cXXr (form x)
+ (let* ((head (car form))
+ (n (symbol-name (car form)))
+ (i (- (length n) 2)))
+ (if (not (string-match "c[ad]+r\\'" n))
+ (if (and (fboundp head) (symbolp (symbol-function head)))
+ (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form))
+ x)
+ (error "Compiler macro for cXXr applied to non-cXXr form"))
+ (while (> i (match-beginning 0))
+ (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
+ (setq i (1- i)))
+ x)))
+
+(dolist (y '(cl-first cl-second cl-third cl-fourth
+ cl-fifth cl-sixth cl-seventh
+ cl-eighth cl-ninth cl-tenth
+ cl-rest cl-endp cl-plusp cl-minusp
+ cl-caaar cl-caadr cl-cadar
+ cl-caddr cl-cdaar cl-cdadr
+ cl-cddar cl-cdddr cl-caaaar
+ cl-caaadr cl-caadar cl-caaddr
+ cl-cadaar cl-cadadr cl-caddar
+ cl-cadddr cl-cdaaar cl-cdaadr
+ cl-cdadar cl-cdaddr cl-cddaar
+ cl-cddadr cl-cdddar cl-cddddr))
+ (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-notevery
- cl-set-elt cl-revappend cl-nreconc gethash))
+ cl--set-elt cl-revappend cl-nreconc gethash))
;;; Things that are side-effect-free.
(mapc (lambda (x) (put x 'side-effect-free t))
HCoop / bpt / emacs.git / blobdiff