diff --git a/src/tests/2am.lisp b/src/tests/2am.lisp index 865828f11..28a3449b2 100644 --- a/src/tests/2am.lisp +++ b/src/tests/2am.lisp @@ -24,7 +24,7 @@ #| to avoid conflict with the library name package 2am-ecl |# (defpackage #:2am-ecl (:use #:cl) - (:export #:test #:test-with-timeout #:is #:signals #:finishes + (:export #:deftest #:test #:test-with-timeout #:is #:signals #:finishes #:run #:suite)) (in-package #:2am-ecl) @@ -152,13 +152,16 @@ (%run fn)) (values))) -(defmacro test (name &body body) +(defmacro deftest (name () &body body) `(progn (defun ,name () (call-test ',name (lambda () ,@body))) (pushnew ',name (gethash *tests* *suites*)) ',name)) +(defmacro test (name &body body) + `(deftest ,name () ,@body)) + (defun kill-processes (process-list &optional original) "Kills a list of processes, which may be the difference between two lists." (let ((process-list (set-difference process-list original))) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 0ee963a99..5600caa21 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -2394,3 +2394,74 @@ (signals type-error (funcall 'foo.0098b :y :bad-arg)) (signals type-error (funcall 'foo.0098b :x nil :y :bad-arg)) (signals type-error (funcall 'foo.0098b :x "" :y :bad-arg))) + +;;; Date 2024-12-17 +;;; Description +;;; +;;; The bytecodes compiler does not enclose FLET/LABELS functions with their +;;; macroexpansion environment, leading to miscompilation in the C later. +;;; +(test cmp.0099.bytecodes-flet-labels-enclose-macrolet + (dolist (op '( flet labels)) + (let* ((form `(lambda () + (macrolet ((plops () 42)) + (,op ((a () (plops))) #'a)))) + (f1 (funcall (ext::bc-compile nil form))) + (f2 (compile nil f1))) + (is (nth-value 1 (function-lambda-expression f1))) + (is (eql (funcall f1) 42)) + (finishes (is (eql (funcall f2) 42)))) + (let* ((form `(lambda () + (symbol-macrolet ((klops 96)) + (,op ((a () klops)) #'a)))) + (f1 (funcall (ext::bc-compile nil form))) + (f2 (compile nil f1))) + (is (nth-value 1 (function-lambda-expression f1))) + (is (eql (funcall f1) 96)) + (finishes (is (eql (funcall f2) 96)))))) + +;;; Date 2024-12-17 +;;; Description +;;; +;;; While writing cmp.0099 and adding LABELS variant I've hit a stack +;;; overflow. This test encodes that particular failure. SET-CLOSURE-ENV +;;; recursively adds the reference to the function leading to the error. In +;;; this test we check whether this pitfall is avoided and whether compiled +;;; LABELS can still reference itself. +;;; +(test cmp.0100.bytecodes-labels-stack-overflow + (let ((fun (labels ((a (n) + (if (zerop n) + 'banzai + (a (1- n))))) + #'a))) + (multiple-value-bind (fun wrn err) + (compile nil fun) + (finishes (is (eql (funcall fun 4) 'banzai))) + (is (null wrn)) + (is (null err))))) + +;;; Date 2024-12-18 +;;; Description +;;; +;;; Test for an uncommited regression in the bytecodes compiler that was +;;; introduced while fixing cmp.0100 where we've made the single label share +;;; bindings among all function closures, or we've restored invalid lexenv, +;;; or that we've miscompiled closure by C compiler. +;;; +(deftest cmp.0101.bytecodes-labels-false-sharing () + (flet ((make (start) + (macrolet ((start-result () 'start)) + (labels ((fun (n) + (if (zerop n) + (start-result) + (1+ (fun (1- n)))))) + #'fun)))) + (let ((f1 (make 3)) + (f2 (make 2))) + (print (= (funcall f1 3) 6)) + (print (= (funcall f2 3) 5)) + (finishes (is (null (nth-value 2 (compile nil f1))))) + (finishes (is (null (nth-value 2 (compile nil f2))))) + (print (= (funcall f1 3) 6)) + (print (= (funcall f2 3) 5)))))