X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/190644a0115a592f237b5f7c91f0f96e82edb864..7e09ef09a479731d01b1ca46e94ddadd73ac98e3:/lisp/emacs-lisp/cl-macs.el diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index e4a73d1a4d..fff5b27315 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,6 +1,6 @@ ;;; 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 ;; Old-Version: 2.02 @@ -822,7 +822,8 @@ For more details, see Info node `(cl)Loop Facility'. "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 @@ -1136,7 +1137,8 @@ For more details, see Info node `(cl)Loop Facility'. (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))) @@ -1194,7 +1196,8 @@ For more details, see Info node `(cl)Loop Facility'. (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) @@ -1370,7 +1373,8 @@ For more details, see Info node `(cl)Loop Facility'. (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))) @@ -1388,7 +1392,8 @@ For more details, see Info node `(cl)Loop Facility'. (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)) @@ -1403,7 +1408,9 @@ For more details, see Info node `(cl)Loop Facility'. ,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)) @@ -1434,7 +1441,8 @@ For more details, see Info node `(cl)Loop Facility'. (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)) @@ -1505,7 +1513,8 @@ For more details, see Info node `(cl)Loop Facility'. (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"). @@ -2398,7 +2407,8 @@ non-nil value, that slot cannot be set via `setf'. 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))) @@ -2477,6 +2487,8 @@ non-nil value, that slot cannot be set via `setf'. (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) @@ -2492,7 +2504,8 @@ non-nil value, that slot cannot be set via `setf'. 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)) @@ -2547,12 +2560,14 @@ non-nil value, that slot cannot be set via `setf'. (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))) @@ -2568,7 +2583,8 @@ non-nil value, that slot cannot be set via `setf'. 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))) @@ -2635,46 +2651,48 @@ Of course, we really can't know that for sure, so it's just a heuristic." (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 @@ -2749,7 +2767,12 @@ and then returning foo." (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) @@ -2883,9 +2906,8 @@ The function's arguments should be treated as immutable. ;;;###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