;;; 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
(set `(setq ,temp ,form)))
(if (and (fboundp 'byte-compile-file-form-defmumble)
(boundp 'this-kind) (boundp 'that-one))
- (fset 'byte-compile-file-form
- `(lambda (form)
- (fset 'byte-compile-file-form
- ',(symbol-function 'byte-compile-file-form))
- (byte-compile-file-form ',set)
- (byte-compile-file-form form)))
- (print set (symbol-value 'byte-compile--outbuffer)))
- `(symbol-value ',temp))
+ ;; Else, we can't output right away, so we have to delay it to the
+ ;; next time we're at the top-level.
+ ;; FIXME: Use advice-add/remove.
+ (fset 'byte-compile-file-form
+ (let ((old (symbol-function 'byte-compile-file-form)))
+ (lambda (form)
+ (fset 'byte-compile-file-form old)
+ (byte-compile-file-form set)
+ (byte-compile-file-form form))))
+ ;; If we're not in the middle of compiling something, we can
+ ;; output directly to byte-compile-outbuffer, to make sure
+ ;; temp is set before we use it.
+ (print set byte-compile--outbuffer))
+ temp)
`',(eval form)))
(defmacro cl-flet (bindings &rest body)
"Make local function definitions.
Like `cl-labels' but the definitions are not recursive.
+Each binding can take the form (FUNC EXP) where
+FUNC is the function name, and EXP is an expression that returns the
+function value to which it should be bound, or it can take the more common
+form \(FUNC ARGLIST BODY...) which is a shorthand
+for (FUNC (lambda ARGLIST BODY)).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body)))
(let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings)
- (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
- (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+ (let ((var (make-symbol (format "--cl-%s--" (car binding))))
+ (args-and-body (cdr binding)))
+ (if (and (= (length args-and-body) 1) (symbolp (car args-and-body)))
+ ;; Optimize (cl-flet ((fun var)) body).
+ (setq var (car args-and-body))
+ (push (list var (if (= (length args-and-body) 1)
+ (car args-and-body)
+ `(cl-function (lambda . ,args-and-body))))
+ binds))
(push (cons (car binding)
- `(lambda (&rest cl-labels-args)
- (cl-list* 'funcall ',var
- cl-labels-args)))
+ (lambda (&rest cl-labels-args)
+ (cl-list* 'funcall var cl-labels-args)))
newenv)))
+ ;; FIXME: Eliminate those functions which aren't referenced.
`(let ,(nreverse binds)
,@(macroexp-unprogn
(macroexpand-all
(let ((var (make-symbol (format "--cl-%s--" (car binding)))))
(push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
(push (cons (car binding)
- `(lambda (&rest cl-labels-args)
- (cl-list* 'funcall ',var
- cl-labels-args)))
+ (lambda (&rest cl-labels-args)
+ (cl-list* 'funcall var cl-labels-args)))
newenv)))
(macroexpand-all `(letrec ,(nreverse binds) ,@body)
;; Don't override lexical-let's macro-expander.
(res (cl--transform-lambda (cdar bindings) name)))
(eval (car res))
(macroexpand-all (macroexp-progn body)
- (cons (cons name `(lambda ,@(cdr res)))
+ (cons (cons name
+ (eval `(cl-function (lambda ,@(cdr res))) t))
macroexpand-all-environment))))))
(defconst cl--old-macroexpand
(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))
(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)))
(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) `(funcall #',(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