-;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*-
+;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t -*-
-;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2016 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Old-Version: 2.02
(setq form `(cons ,(car args) ,form)))
form))
+;; Note: `cl--compiler-macro-cXXr' has been copied to
+;; `internal--compiler-macro-cXXr' in subr.el. If you amend either
+;; one, you may want to amend the other, too.
;;;###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)))
+(define-obsolete-function-alias 'cl--compiler-macro-cXXr
+ 'internal--compiler-macro-cXXr "25.1")
;;; Some predicates for analyzing Lisp forms.
;; These are used by various
;;; Symbols.
-(defvar cl--gensym-counter)
+(defvar cl--gensym-counter 0)
;;;###autoload
(defun cl-gensym (&optional prefix)
"Generate a new uninterned symbol.
;; 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 header)) (pop header))
;; 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)))))
+ (help--docstring-quote
+ (let ((print-gensym nil) (print-quoted t)
+ (print-escape-newlines t))
+ (format "%S" (cons 'fn (cl--make-usage-args
+ orig-args))))))
header)))
;; FIXME: we'd want to choose an arg name for the &rest param
;; and pass that as `expr' to cl--do-arglist, but that ends up
"The Common Lisp `loop' macro.
Valid clauses include:
For clauses:
- for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 by EXPR3
+ 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 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)]
(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)
+ (memq (nth 2 cl--loop-args)
'(downto above))))
(excl (or (memq (car cl--loop-args) '(above below))
- (memq (cl-caddr cl--loop-args)
+ (memq (nth 2 cl--loop-args)
'(above below))))
(start (and (memq (car cl--loop-args)
'(from upfrom downfrom))
(declare (debug ((symbolp form &optional form) cl-declarations body))
(indent 1))
(let ((loop `(dolist ,spec ,@body)))
- (if (advice-member-p #'cl--wrap-in-nil-block 'dolist)
+ (if (advice-member-p 'cl--wrap-in-nil-block 'dolist)
loop `(cl-block nil ,loop))))
;;;###autoload
\(fn (VAR COUNT [RESULT]) BODY...)"
(declare (debug cl-dolist) (indent 1))
(let ((loop `(dotimes ,spec ,@body)))
- (if (advice-member-p #'cl--wrap-in-nil-block 'dotimes)
+ (if (advice-member-p 'cl--wrap-in-nil-block 'dotimes)
loop `(cl-block nil ,loop))))
(defvar cl--tagbody-alist nil)
(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")))
+ (let ((catch-tag (make-symbol "cl--tagbody-tag"))
+ (cl--tagbody-alist cl--tagbody-alist))
(push (cons 'cl--exit catch-tag) cl--tagbody-alist)
(dolist (block blocks)
(push (cons (car block) catch-tag) cl--tagbody-alist))
(let (,(car spec))
(mapatoms #'(lambda (,(car spec)) ,@body)
,@(and (cadr spec) (list (cadr spec))))
- ,(cl-caddr spec))))
+ ,(nth 2 spec))))
;;;###autoload
(defmacro cl-do-all-symbols (spec &rest body)
macroexpand-all-environment))))
(if (or (null (cdar bindings)) (cl-cddar bindings))
(macroexp--warn-and-return
- (format "Malformed `cl-symbol-macrolet' binding: %S"
- (car bindings))
+ (format-message "Malformed `cl-symbol-macrolet' binding: %S"
+ (car bindings))
expansion)
expansion)))
(fset 'macroexpand previous-macroexpand))))))
(let ((accessor (intern (format "%s%s" conc-name slot))))
(push slot slots)
(push (nth 1 desc) defaults)
+ ;; The arg "cl-x" is referenced by name in eg pred-form
+ ;; and pred-check, so changing it is not straightforward.
(push `(cl-defsubst ,accessor (cl-x)
+ ,(format "Access slot \"%s\" of `%s' struct CL-X."
+ slot struct)
(declare (side-effect-free t))
,@(and pred-check
(list `(or ,pred-check
(push `(defalias ',copier #'copy-sequence) forms))
(if constructor
(push (list constructor
- (cons '&key (delq nil (copy-sequence slots))))
- constrs))
- (while constrs
- (let* ((name (caar constrs))
- (args (cadr (pop constrs)))
- (anames (cl--arglist-args args))
+ (cons '&key (delq nil (copy-sequence slots))))
+ constrs))
+ (pcase-dolist (`(,cname ,args ,doc) constrs)
+ (let* ((anames (cl--arglist-args args))
(make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
slots defaults)))
- (push `(cl-defsubst ,name
+ (push `(cl-defsubst ,cname
(&cl-defs (nil ,@descs) ,@args)
+ ,(if (stringp doc) doc
+ (format "Constructor for objects of type `%s'." name))
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
'((declare (side-effect-free t))))
(,(or type #'vector) ,@make))
',print-auto))
',name)))
+;;; Add cl-struct support to pcase
+
+(defun cl--struct-all-parents (class)
+ (when (cl--struct-class-p class)
+ (let ((res ())
+ (classes (list class)))
+ ;; BFS precedence.
+ (while (let ((class (pop classes)))
+ (push class res)
+ (setq classes
+ (append classes
+ (cl--class-parents class)))))
+ (nreverse res))))
+
+;;;###autoload
+(pcase-defmacro cl-struct (type &rest fields)
+ "Pcase patterns to match cl-structs.
+Elements of FIELDS can be of the form (NAME PAT) in which case the contents of
+field NAME is matched against PAT, or they can be of the form NAME which
+is a shorthand for (NAME NAME)."
+ (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp])))
+ `(and (pred (pcase--flip cl-typep ',type))
+ ,@(mapcar
+ (lambda (field)
+ (let* ((name (if (consp field) (car field) field))
+ (pat (if (consp field) (cadr field) field)))
+ `(app ,(if (eq (cl-struct-sequence-type type) 'list)
+ `(nth ,(cl-struct-slot-offset type name))
+ `(pcase--flip aref ,(cl-struct-slot-offset type name)))
+ ,pat)))
+ fields)))
+
+(defun cl--pcase-mutually-exclusive-p (orig pred1 pred2)
+ "Extra special cases for `cl-typep' predicates."
+ (let* ((x1 pred1) (x2 pred2)
+ (t1
+ (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1))
+ (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1))
+ (null (cdr-safe x1)) (setq x1 (car x1))
+ (eq 'quote (car-safe x1)) (cadr x1)))
+ (t2
+ (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2))
+ (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2))
+ (null (cdr-safe x2)) (setq x2 (car x2))
+ (eq 'quote (car-safe x2)) (cadr x2))))
+ (or
+ (and (symbolp t1) (symbolp t2)
+ (let ((c1 (cl--find-class t1))
+ (c2 (cl--find-class t2)))
+ (and c1 c2
+ (not (or (memq c1 (cl--struct-all-parents c2))
+ (memq c2 (cl--struct-all-parents c1)))))))
+ (let ((c1 (and (symbolp t1) (cl--find-class t1))))
+ (and c1 (cl--struct-class-p c1)
+ (funcall orig (if (eq 'list (cl-struct-sequence-type t1))
+ 'consp 'vectorp)
+ pred2)))
+ (let ((c2 (and (symbolp t2) (cl--find-class t2))))
+ (and c2 (cl--struct-class-p c2)
+ (funcall orig pred1
+ (if (eq 'list (cl-struct-sequence-type t2))
+ 'consp 'vectorp))))
+ (funcall orig pred1 pred2))))
+(advice-add 'pcase--mutually-exclusive-p
+ :around #'cl--pcase-mutually-exclusive-p)
+
+
(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. "
+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))
(cl--struct-class-type (cl--struct-get-class struct-type)))
descs)))
(nreverse descs)))
+(define-error 'cl-struct-unknown-slot "struct %S has no slot %S")
+
(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
(declare (side-effect-free t) (pure t))
(or (gethash slot-name
(cl--class-index-table (cl--struct-get-class struct-type)))
- (error "struct %s has no slot %s" struct-type slot-name)))
+ (signal 'cl-struct-unknown-slot (list struct-type slot-name))))
(defvar byte-compile-function-environment)
(defvar byte-compile-macro-environment)
(put 'real 'cl-deftype-satisfies #'numberp)
(put 'fixnum 'cl-deftype-satisfies #'integerp)
(put 'base-char 'cl-deftype-satisfies #'characterp)
-(put 'character 'cl-deftype-satisfies #'integerp)
+(put 'character 'cl-deftype-satisfies #'natnump)
;;;###autoload