mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-06 06:20:55 -08:00
042dc5929b
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-reify-function): * test/lisp/emacs-lisp/cl-extra-tests.el (cl-getf): * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs-loop-for-as-arith-order-side-effects) (cl-macs-loop-for-as-equals-then, cl-macs-loop-do, cl-macs-loop-finally) (cl-macs-loop-in-ref, cl-macs-loop-being-elements-of-ref) (cl-macs-test--symbol-macrolet, cl-the): * test/lisp/emacs-lisp/cl-seq-tests.el (cl-lib-test-remove) (cl-lib-test-remove-if-not): * test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el (edebug-test-code-range): * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests-deduplicate): * test/lisp/emacs-lisp/generator-tests.el (cps-while-incf): (cps-test-iter-cleanup-once-only): * test/lisp/emacs-lisp/hierarchy-tests.el (hierarchy-labelfn-button-if-does-not-button-unless-condition) (hierarchy-labelfn-button-if-does-button-when-condition): * test/lisp/emacs-lisp/let-alist-tests.el (let-alist-evaluate-once): * test/lisp/emacs-lisp/lisp-mode-tests.el (indent-sexp, lisp-indent-region): * test/lisp/emacs-lisp/map-tests.el (test-map-elt-gv) (test-setf-map-with-function): * test/lisp/emacs-lisp/multisession-tests.el (multi-test-sqlite-simple) (multi-test-sqlite-busy, multi-test-files-simple) (multi-test-files-busy): * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test, oclosure-test-mutate): * test/lisp/emacs-lisp/track-changes-tests.el (track-changes-tests--random): * test/lisp/files-tests.el (files-tests--with-buffer-offer-save): * test/lisp/net/shr-tests.el (shr-test/zoom-image): * test/lisp/replace-tests.el (replace-tests-with-undo): * test/src/buffer-tests.el (test-overlay-randomly): * test/src/data-tests.el (test-bool-vector-bv-from-hex-string): * test/src/fns-tests.el (fns-tests-sort): * test/src/json-tests.el (json-insert/signal, json-insert/throw): * test/src/minibuf-tests.el (minibuf-tests--strings-to-symbol-alist) (minibuf-tests--strings-to-string-alist) (minibuf-tests--strings-to-string-hashtable) (minibuf-tests--strings-to-symbol-hashtable): * test/src/process-tests.el (make-process/file-handler/found): Prefer incf to cl-incf.
166 lines
6.2 KiB
EmacsLisp
166 lines
6.2 KiB
EmacsLisp
;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2021-2025 Free Software Foundation, Inc.
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs 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.
|
|
|
|
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'oclosure)
|
|
(require 'cl-lib)
|
|
(require 'eieio)
|
|
|
|
(oclosure-define (oclosure-test
|
|
(:copier oclosure-test-copy)
|
|
(:copier oclosure-test-copy1 (fst)))
|
|
"Simple OClosure."
|
|
fst snd (name :mutable t))
|
|
|
|
(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>")
|
|
|
|
(cl-defmethod oclosure-test-gen ((_x interpreted-function)) "#<interpreted-function>")
|
|
|
|
(cl-defmethod oclosure-test-gen ((_x oclosure))
|
|
(format "#<oclosure:%s>" (cl-call-next-method)))
|
|
|
|
(cl-defmethod oclosure-test-gen ((_x oclosure-test))
|
|
(format "#<oclosure-test:%s>" (cl-call-next-method)))
|
|
|
|
(ert-deftest oclosure-test ()
|
|
(let* ((i 42)
|
|
(ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi"))
|
|
()
|
|
(list fst snd i)))
|
|
(ocl2 (oclosure-lambda (oclosure-test (name (incf i)) (fst (incf i)))
|
|
()
|
|
(list fst snd 152 i))))
|
|
(should (equal (list (oclosure-test--fst ocl1)
|
|
(oclosure-test--snd ocl1)
|
|
(oclosure-test--name ocl1))
|
|
'(1 2 "hi")))
|
|
(should (equal (list (oclosure-test--fst ocl2)
|
|
(oclosure-test--snd ocl2)
|
|
(oclosure-test--name ocl2))
|
|
'(44 nil 43)))
|
|
(should (equal (funcall ocl1) '(1 2 44)))
|
|
(should (equal (funcall ocl2) '(44 nil 152 44)))
|
|
(should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44)))
|
|
(should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44)))
|
|
(should (cl-typep ocl1 'oclosure-test))
|
|
(should (cl-typep ocl1 'oclosure))
|
|
(should (member (oclosure-test-gen ocl1)
|
|
'("#<oclosure-test:#<oclosure:#<interpreted-function>>>"
|
|
"#<oclosure-test:#<oclosure:#<bytecode>>>")))
|
|
(should (stringp (documentation #'oclosure-test--fst)))
|
|
))
|
|
|
|
(ert-deftest oclosure-test-limits ()
|
|
(defvar byte-compile-debug)
|
|
(should
|
|
(condition-case err
|
|
(let ((lexical-binding t)
|
|
(byte-compile-debug t))
|
|
(byte-compile '(lambda ()
|
|
(let ((inc-fst nil))
|
|
(oclosure-lambda (oclosure-test (fst 'foo)) ()
|
|
(setq inc-fst (lambda () (setq fst (1+ fst))))
|
|
fst))))
|
|
nil)
|
|
(error
|
|
(and (eq 'error (car err))
|
|
(string-match "fst.*mutated" (cadr err))))))
|
|
(should
|
|
(condition-case err
|
|
(progn (macroexpand-all '(oclosure-define oclosure--foo a a))
|
|
nil)
|
|
(error
|
|
(and (eq 'error (car err))
|
|
(string-match "Duplicate slot name: a$" (cadr err))))))
|
|
(should
|
|
(condition-case err
|
|
(progn (macroexpand-all
|
|
'(oclosure-define (oclosure--foo (:parent oclosure-test)) fst))
|
|
nil)
|
|
(error
|
|
(and (eq 'error (car err))
|
|
(string-match "Duplicate slot name: fst$" (cadr err))))))
|
|
(should
|
|
(condition-case err
|
|
(progn (macroexpand '(oclosure-lambda (oclosure-test (fst 1) (fst 2))
|
|
() fst))
|
|
nil)
|
|
(error
|
|
(and (eq 'error (car err))
|
|
(string-match "Duplicate slot: fst$" (cadr err)))))))
|
|
|
|
(cl-defmethod oclosure-interactive-form ((ot oclosure-test))
|
|
(let ((snd (oclosure-test--snd ot)))
|
|
(if (stringp snd) (list 'interactive snd))))
|
|
|
|
(ert-deftest oclosure-test-interactive-form ()
|
|
(should (equal (interactive-form
|
|
(oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst))
|
|
nil))
|
|
(should (equal (interactive-form
|
|
(oclosure-lambda (oclosure-test (fst 1) (snd 2)) ()
|
|
(interactive "r")
|
|
fst))
|
|
'(interactive "r")))
|
|
(should (equal (interactive-form
|
|
(oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst))
|
|
'(interactive "P")))
|
|
(should (not (commandp
|
|
(oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst))))
|
|
(should (commandp
|
|
(oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst))))
|
|
|
|
(oclosure-define (oclosure-test-mut
|
|
(:parent oclosure-test)
|
|
(:copier oclosure-test-mut-copy))
|
|
"Simple OClosure with a mutable field."
|
|
(mut :mutable t))
|
|
|
|
(ert-deftest oclosure-test-mutate ()
|
|
(let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3))
|
|
(x)
|
|
(+ x fst mut)))
|
|
(f2 (oclosure-test-mut-copy f :fst 50)))
|
|
(should (equal (oclosure-test-mut--mut f) 3))
|
|
(should (equal (funcall f 5) 8))
|
|
(should (equal (funcall f2 5) 58))
|
|
(incf (oclosure-test-mut--mut f) 7)
|
|
(should (equal (oclosure-test-mut--mut f) 10))
|
|
(should (equal (funcall f 5) 15))
|
|
(should (equal (funcall f2 15) 68))))
|
|
|
|
(ert-deftest oclosure-test-slot-value ()
|
|
(require 'eieio)
|
|
(let ((ocl (oclosure-lambda
|
|
(oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1))
|
|
(x)
|
|
(list name fst snd x))))
|
|
(should (equal 'fst1 (slot-value ocl 'fst)))
|
|
(should (equal 'snd1 (slot-value ocl 'snd)))
|
|
(should (equal 'name1 (slot-value ocl 'name)))
|
|
(setf (slot-value ocl 'name) 'new-name)
|
|
(should (equal 'new-name (slot-value ocl 'name)))
|
|
(should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg)))
|
|
(should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant)
|
|
(should (equal 'fst1 (slot-value ocl 'fst)))
|
|
))
|
|
|
|
;;; oclosure-tests.el ends here.
|