-;;; 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
;;; 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
(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))
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))
- (rest (cdr (pop constrs)))
- (args (car rest))
- (doc (cadr rest))
- (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) (list doc)
- (if (stringp docstring) (list docstring)))
+ ,(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))
;;;###autoload
(pcase-defmacro cl-struct (type &rest fields)
"Pcase patterns to match cl-structs.
-Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
-field NAME is matched against UPAT, or they can be of the form NAME which
+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-UPAT) sexp])))
+ (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp])))
`(and (pred (pcase--flip cl-typep ',type))
,@(mapcar
(lambda (field)
(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