Commit 9def17e9 authored by Stefan Monnier's avatar Stefan Monnier

* lisp/emacs-lisp/cl-generic.el: New file.

* lisp/emacs-lisp/cl-macs.el (cl-flet): Allow (FUN EXP) forms.
(cl-load-time-value, cl-labels): Use closures rather than
backquoted lambdas.
(cl-macrolet): Use `eval' to create the function value, and support CL
style arguments in for the defined macros.
* test/automated/cl-generic-tests.el: New file.
parent e7db8e8d
......@@ -480,6 +480,8 @@ As a result of the above, these commands are now obsolete:
* New Modes and Packages in Emacs 25.1
** cl-generic.el provides CLOS-style multiple-dispatch generic functions.
** scss-mode (a minor variant of css-mode)
** let-alist is a new macro (and a package) that allows one to easily
......
2015-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl-generic.el: New file.
* emacs-lisp/cl-macs.el (cl-flet): Allow (FUN EXP) forms.
(cl-load-time-value, cl-labels): Use closures rather than
backquoted lambdas.
(cl-macrolet): Use `eval' to create the function value, and support CL
style arguments in for the defined macros.
2015-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
* net/eww.el: Use lexical-binding.
......
This diff is collapsed.
......@@ -625,14 +625,20 @@ The result of the body appears to the compiler as a quoted constant."
(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)))
......@@ -1824,18 +1830,30 @@ a `let' form, except that the list of symbols can be computed at run-time."
(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
......@@ -1869,9 +1887,8 @@ in closures will only work if `lexical-binding' is in use.
(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.
......@@ -1898,7 +1915,8 @@ This is like `cl-flet', but for macros instead of functions.
(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
......
2015-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/cl-generic-tests.el: New file.
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/eieio-tests.el (eieio-test-23-inheritance-check): Don't use
......
;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*-
;; Copyright (C) 2015 Stefan Monnier
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(require 'cl-lib)
(cl-defgeneric cl--generic-1 (x y))
(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.")
(ert-deftest cl-generic-test-0 ()
(cl-defgeneric cl--generic-1 (x y))
(cl-defmethod cl--generic-1 ((x t) y) (cons x y))
(should (equal (cl--generic-1 'a 'b) '(a . b))))
(ert-deftest cl-generic-test-1-eql ()
(cl-defgeneric cl--generic-1 (x y))
(cl-defmethod cl--generic-1 ((x t) y) (cons x y))
(cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
(cons "quatre" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_x (eql 5)) _y)
(cons "cinq" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_x (eql 6)) y)
(cons "six" (cl-call-next-method 'a y)))
(should (equal (cl--generic-1 'a nil) '(a)))
(should (equal (cl--generic-1 4 nil) '("quatre" 4)))
(should (equal (cl--generic-1 5 nil) '("cinq" 5)))
(should (equal (cl--generic-1 6 nil) '("six" a))))
(cl-defstruct cl-generic-struct-parent a b)
(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c)
(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d)
(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e)
(ert-deftest cl-generic-test-2-struct ()
(cl-defgeneric cl--generic-1 (x y) "My doc.")
(cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y))
(cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y)
"Doc 2." (cons "parent" (cl-call-next-method 'a y)))
(cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y)
(cons "child1" (cl-call-next-method)))
(cl-defmethod cl--generic-1 :around ((_x t) _y)
(cons "around" (cl-call-next-method)))
(cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y)
(cons "child11" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y)
(cons "child2" (cl-call-next-method)))
(should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil)
'("around" "child1" "parent" a)))
(should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil)
'("around""child2" "parent" a)))
(should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil)
'("child11" "around""child1" "parent" a))))
(ert-deftest cl-generic-test-3-setf ()
(cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z))
(cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z))
(should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b)))
(should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b)))
(let ((x ()))
(should (equal (setf (cl--generic-1 (progn (push 1 x) 'a)
(progn (push 2 x) 'b))
(progn (push 3 x) 'v))
'(v a b)))
(should (equal x '(3 2 1)))))
(ert-deftest cl-generic-test-4-overlapping-tagcodes ()
(cl-defgeneric cl--generic-1 (x y) "My doc.")
(cl-defmethod cl--generic-1 ((y t) z) (list y z))
(cl-defmethod cl--generic-1 ((_y (eql 4)) _z)
(cons "four" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_y integer) _z)
(cons "integer" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_y number) _z)
(cons "number" (cl-call-next-method)))
(should (equal (cl--generic-1 'a 'b) '(a b)))
(should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b)))
(should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b))))
(ert-deftest cl-generic-test-5-alias ()
(cl-defgeneric cl--generic-1 (x y) "My doc.")
(defalias 'cl--generic-2 #'cl--generic-1)
(cl-defmethod cl--generic-1 ((y t) z) (list y z))
(cl-defmethod cl--generic-2 ((_y (eql 4)) _z)
(cons "four" (cl-call-next-method)))
(should (equal (cl--generic-1 4 'b) '("four" 4 b))))
(ert-deftest cl-generic-test-6-multiple-dispatch ()
(cl-defgeneric cl--generic-1 (x y) "My doc.")
(cl-defmethod cl--generic-1 (x y) (list x y))
(cl-defmethod cl--generic-1 (_x (_y integer))
(cons "y-int" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_x integer) _y)
(cons "x-int" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_x integer) (_y integer))
(cons "x&y-int" (cl-call-next-method)))
(should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2))))
(ert-deftest cl-generic-test-7-apo ()
(cl-defgeneric cl--generic-1 (x y)
(:documentation "My doc.") (:argument-precedence-order y x))
(cl-defmethod cl--generic-1 (x y) (list x y))
(cl-defmethod cl--generic-1 (_x (_y integer))
(cons "y-int" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_x integer) _y)
(cons "x-int" (cl-call-next-method)))
(cl-defmethod cl--generic-1 ((_x integer) (_y integer))
(cons "x&y-int" (cl-call-next-method)))
(should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
(provide 'cl-generic-tests)
;;; cl-generic-tests.el ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment