;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*-
-;; Copyright (C) 1993, 2001-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Old-Version: 2.02
(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
"repeat" "while" "until" "always" "never"
"thereis" "collect" "append" "nconc" "sum"
"count" "maximize" "minimize" "if" "unless"
- "return"] form]
+ "return"]
+ form]
;; Simple default, which covers 99% of the cases.
symbolp form)))
(if (not (memq t (mapcar #'symbolp
(if end
(push (list
(if down (if excl '> '>=) (if excl '< '<=))
- var (or end-var end)) cl--loop-body))
+ var (or end-var end))
+ cl--loop-body))
(push (list var (list (if down '- '+) var
(or step-var step 1)))
loop-for-steps)))
(push (list temp-vec (pop cl--loop-args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
(push `(< (setq ,temp-idx (1+ ,temp-idx))
- (length ,temp-vec)) cl--loop-body)
+ (length ,temp-vec))
+ cl--loop-body)
(if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx))
cl--loop-symbol-macs)
(if loop-for-sets
(push `(progn
,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
- t) cl--loop-body))
+ t)
+ cl--loop-body))
(if loop-for-steps
(push (cons (if ands 'cl-psetq 'setq)
(apply 'append (nreverse loop-for-steps)))
(push `(progn (push ,what ,var) t) cl--loop-body)
(push `(progn
(setq ,var (nconc ,var (list ,what)))
- t) cl--loop-body))))
+ t)
+ cl--loop-body))))
((memq word '(nconc nconcing append appending))
(let ((what (pop cl--loop-args))
,var)
`(,(if (memq word '(nconc nconcing))
#'nconc #'append)
- ,var ,what))) t) cl--loop-body)))
+ ,var ,what)))
+ t)
+ cl--loop-body)))
((memq word '(concat concating))
(let ((what (pop cl--loop-args))
(set `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
(push `(progn ,(if (eq temp what) set
`(let ((,temp ,what)) ,set))
- t) cl--loop-body)))
+ t)
+ cl--loop-body)))
((eq word 'with)
(let ((bindings nil))
(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))
+ ,cl--loop-finish-flag nil)
+ cl--loop-body))
(t
;; This is an advertised interface: (info "(cl)Other Clauses").
(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 (or (null temp) (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--"))
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)
pred-form pred-check)
(if (stringp (car descs))
(push `(put ',name 'structure-documentation
- ,(pop descs)) forms))
+ ,(pop descs))
+ forms))
(setq descs (cons '(cl-tag-slot)
(mapcar (function (lambda (x) (if (consp x) x (list x))))
descs)))
(setq type 'vector named 'true)))
(or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
(push `(defvar ,tag-symbol) forms)
+ (when (and (null predicate) named)
+ (setq predicate (intern (format "cl--struct-%s-p" name))))
(setq pred-form (and named
(let ((pos (- (length descs)
(length (memq (assq 'cl-tag-slot descs)
pred-check (and pred-form (> safety 0)
(if (and (eq (cl-caadr pred-form) 'vectorp)
(= safety 1))
- (cons 'and (cl-cdddr pred-form)) pred-form)))
+ (cons 'and (cl-cdddr pred-form))
+ `(,predicate cl-x))))
(let ((pos 0) (descp descs))
(while descp
(let* ((desc (pop descp))
',accessor ',name))))
,(if (eq type 'vector) `(aref cl-x ,pos)
(if (= pos 0) '(car cl-x)
- `(nth ,pos cl-x)))) forms)
+ `(nth ,pos cl-x))))
+ forms)
(push (cons accessor t) side-eff)
(if (cadr (memq :read-only (cddr desc)))
(push `(gv-define-expander ,accessor
(setq pos (1+ pos))))
(setq slots (nreverse slots)
defaults (nreverse defaults))
- (and predicate pred-form
- (progn (push `(cl-defsubst ,predicate (cl-x)
- ,(if (eq (car pred-form) 'and)
- (append pred-form '(t))
- `(and ,pred-form t))) forms)
- (push (cons predicate 'error-free) side-eff)))
+ (when pred-form
+ (push `(cl-defsubst ,predicate (cl-x)
+ ,(if (eq (car pred-form) 'and)
+ (append pred-form '(t))
+ `(and ,pred-form t)))
+ forms)
+ (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)
+ (push (cons predicate 'error-free) side-eff))
(and copier
(progn (push `(defun ,copier (x) (copy-sequence x)) forms)
(push (cons copier t) side-eff)))
slots defaults)))
(push `(cl-defsubst ,name
(&cl-defs '(nil ,@descs) ,@args)
- (,type ,@make)) forms)
+ (,type ,@make))
+ forms)
(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)))
(cdr (assq sym byte-compile-macro-environment))))))
(defun cl--make-type-test (val type)
- (if (symbolp type)
- (cond ((get type 'cl-deftype-handler)
- (cl--make-type-test val (funcall (get type 'cl-deftype-handler))))
- ((memq type '(nil t)) type)
- ((eq type 'null) `(null ,val))
- ((eq type 'atom) `(atom ,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
- ((memq type '(character string-char)) `(characterp ,val))
- (t
- (let* ((name (symbol-name type))
- (namep (intern (concat name "p"))))
- (cond
- ((cl--macroexp-fboundp namep) (list namep val))
- ((cl--macroexp-fboundp
- (setq namep (intern (concat name "-p"))))
- (list namep val))
- (t (list type val))))))
- (cond ((get (car type) 'cl-deftype-handler)
- (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler)
- (cdr type))))
- ((memq (car type) '(integer float real number))
- (delq t `(and ,(cl--make-type-test val (car type))
- ,(if (memq (cadr type) '(* nil)) t
- (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))
- `(<= ,val ,(cl-caddr type)))))))
- ((memq (car type) '(and or not))
- (cons (car type)
- (mapcar (function (lambda (x) (cl--make-type-test val x)))
- (cdr type))))
- ((memq (car type) '(member cl-member))
- `(and (cl-member ,val ',(cdr type)) t))
- ((eq (car type) 'satisfies) (list (cadr type) val))
- (t (error "Bad type spec: %s" type)))))
+ (pcase type
+ ((and `(,name . ,args) (guard (get name 'cl-deftype-handler)))
+ (cl--make-type-test val (apply (get name 'cl-deftype-handler)
+ args)))
+ (`(,(and name (or 'integer 'float 'real 'number))
+ . ,(or `(,min ,max) pcase--dontcare))
+ `(and ,(cl--make-type-test val name)
+ ,(if (memq min '(* nil)) t
+ (if (consp min) `(> ,val ,(car min))
+ `(>= ,val ,min)))
+ ,(if (memq max '(* nil)) t
+ (if (consp max)
+ `(< ,val ,(car max))
+ `(<= ,val ,max)))))
+ (`(,(and name (or 'and 'or 'not)) . ,args)
+ (cons name (mapcar (lambda (x) (cl--make-type-test val x)) args)))
+ (`(member . ,args)
+ `(and (cl-member ,val ',args) t))
+ (`(satisfies ,pred) `(funcall #',pred ,val))
+ ((and (pred symbolp) (guard (get type 'cl-deftype-handler)))
+ (cl--make-type-test val (funcall (get type 'cl-deftype-handler))))
+ ((and (pred symbolp) (guard (get type 'cl-deftype-satisfies)))
+ `(funcall #',(get type 'cl-deftype-satisfies) ,val))
+ ((or 'nil 't) type)
+ ('null `(null ,val))
+ ('atom `(atom ,val))
+ ('float `(floatp ,val))
+ ('real `(numberp ,val))
+ ('fixnum `(integerp ,val))
+ ;; FIXME: Implement `base-char' and `extended-char'.
+ ('character `(characterp ,val))
+ ((pred symbolp)
+ (let* ((name (symbol-name type))
+ (namep (intern (concat name "p"))))
+ (cond
+ ((cl--macroexp-fboundp namep) (list namep val))
+ ((cl--macroexp-fboundp
+ (setq namep (intern (concat name "-p"))))
+ (list namep val))
+ ((cl--macroexp-fboundp type) (list type val))
+ (t (error "Unknown type %S" type)))))
+ (_ (error "Bad type spec: %s" type))))
(defvar cl--object)
;;;###autoload
(let ((p args) (res nil))
(while (consp p) (push (pop p) res))
(setq args (nconc (nreverse res) (and p (list '&rest p)))))
- (let ((fname (make-symbol (concat (symbol-name func) "--cmacro"))))
+ ;; FIXME: The code in bytecomp mishandles top-level expressions that define
+ ;; uninterned functions. E.g. it would generate code like:
+ ;; (defalias '#1=#:foo--cmacro #[514 ...])
+ ;; (put 'foo 'compiler-macro '#:foo--cmacro)
+ ;; So we circumvent this by using an interned name.
+ (let ((fname (intern (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)
;;;###autoload
(defun cl--compiler-macro-adjoin (form a list &rest keys)
(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))))))
+ (macroexp-let2* macroexp-copyable-p ((va a) (vlist list))
+ `(if (cl-member ,va ,vlist ,@keys) ,vlist (cons ,va ,vlist)))))
(defun cl--compiler-macro-get (_form sym prop &optional def)
(if def
(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))
+ (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)))))