From 0b775f50b12acb9d3ea9e89578457d4410cb91cf Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 12:40:37 -0400 Subject: [PATCH 01/32] Start on tests Mostly failing for the moment. --- cvm.asd | 40 ++ test/ansi/LICENSE | 20 + test/ansi/block.lisp | 96 +++++ test/ansi/compile.lisp | 97 +++++ test/ansi/dynamic-extent.lisp | 131 ++++++ test/ansi/eval-when.lisp | 146 +++++++ test/ansi/eval.lisp | 57 +++ test/ansi/flet.lisp | 592 ++++++++++++++++++++++++++++ test/ansi/if.lisp | 76 ++++ test/ansi/ignorable.lisp | 56 +++ test/ansi/ignore.lisp | 40 ++ test/ansi/labels.lisp | 440 +++++++++++++++++++++ test/ansi/lambda.lisp | 382 ++++++++++++++++++ test/ansi/let.lisp | 173 ++++++++ test/ansi/letstar.lisp | 185 +++++++++ test/ansi/locally.lisp | 49 +++ test/ansi/macrolet.lisp | 486 +++++++++++++++++++++++ test/ansi/multiple-value-call.lisp | 35 ++ test/ansi/multiple-value-prog1.lisp | 101 +++++ test/ansi/optimize.lisp | 57 +++ test/ansi/progn.lisp | 70 ++++ test/ansi/return-from.lisp | 27 ++ test/ansi/special.lisp | 36 ++ test/ansi/symbol-macrolet.lisp | 89 +++++ test/ansi/tagbody.lisp | 187 +++++++++ test/ansi/the.lisp | 159 ++++++++ test/ansi/type.lisp | 77 ++++ test/package.lisp | 4 + test/rt.lisp | 35 ++ test/suites.lisp | 6 + 30 files changed, 3949 insertions(+) create mode 100644 test/ansi/LICENSE create mode 100644 test/ansi/block.lisp create mode 100644 test/ansi/compile.lisp create mode 100644 test/ansi/dynamic-extent.lisp create mode 100644 test/ansi/eval-when.lisp create mode 100644 test/ansi/eval.lisp create mode 100644 test/ansi/flet.lisp create mode 100644 test/ansi/if.lisp create mode 100644 test/ansi/ignorable.lisp create mode 100644 test/ansi/ignore.lisp create mode 100644 test/ansi/labels.lisp create mode 100644 test/ansi/lambda.lisp create mode 100644 test/ansi/let.lisp create mode 100644 test/ansi/letstar.lisp create mode 100644 test/ansi/locally.lisp create mode 100644 test/ansi/macrolet.lisp create mode 100644 test/ansi/multiple-value-call.lisp create mode 100644 test/ansi/multiple-value-prog1.lisp create mode 100644 test/ansi/optimize.lisp create mode 100644 test/ansi/progn.lisp create mode 100644 test/ansi/return-from.lisp create mode 100644 test/ansi/special.lisp create mode 100644 test/ansi/symbol-macrolet.lisp create mode 100644 test/ansi/tagbody.lisp create mode 100644 test/ansi/the.lisp create mode 100644 test/ansi/type.lisp create mode 100644 test/package.lisp create mode 100644 test/rt.lisp create mode 100644 test/suites.lisp diff --git a/cvm.asd b/cvm.asd index 1bfb6c3..8e5bcff 100644 --- a/cvm.asd +++ b/cvm.asd @@ -14,3 +14,43 @@ (:file "compile" :depends-on ("structures" "machine")) (:file "cmpltv" :depends-on ("compile")) (:file "vm" :depends-on ("disassemble" "structures" "machine")))) + +(asdf:defsystem #:cvm/test + :author ("Bike ") + :maintainer "Bike " + :depends-on (:cvm :fiveam) + :components + ((:module "test" + :components ((:file "package") + (:file "suites" :depends-on ("package")) + (:file "rt" :depends-on ("package")) + (:module "ansi" + :depends-on ("suites" "rt" "package") + ;; These can be loaded in any order. + :components (;; eval-and-compile + (:file "compile") + (:file "dynamic-extent") + (:file "eval") + (:file "eval-when") + (:file "ignorable") + (:file "ignore") + (:file "lambda") + (:file "locally") + (:file "optimize") + (:file "special") + (:file "symbol-macrolet") + (:file "the") + (:file "type") + ;; data-and-control-flow + (:file "block") + (:file "flet") + (:file "if") + (:file "labels") + (:file "let") + (:file "letstar") + (:file "macrolet") + (:file "multiple-value-call") + (:file "multiple-value-prog1") + (:file "progn") + (:file "return-from") + (:file "tagbody"))))))) diff --git a/test/ansi/LICENSE b/test/ansi/LICENSE new file mode 100644 index 0000000..6004d1c --- /dev/null +++ b/test/ansi/LICENSE @@ -0,0 +1,20 @@ +Copyright 2004 Paul F. Dietz + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/test/ansi/block.lisp b/test/ansi/block.lisp new file mode 100644 index 0000000..c1d63c6 --- /dev/null +++ b/test/ansi/block.lisp @@ -0,0 +1,96 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 12:30:46 2002 +;;;; Contains: Tests of BLOCK + +(in-package #:cvm.test) + +(5am:def-suite block :in data-and-control-flow) +(5am:in-suite block) + +(deftest block.1 + (block foo + (return-from foo 1)) + 1) + +(deftest block.2 + (block nil + (block foo + (return 'good)) + 'bad) + good) + +(deftest block.3 + (block done + (flet ((%f (x) (return-from done x))) + (%f 'good)) + 'bad) + good) + +(deftest block.4 + (block foo + (block foo + (return-from foo 'bad)) + 'good) + good) + +(deftest block.5 + (block done + (flet ((%f (x) (return-from done x))) + (mapcar #'%f '(good bad bad))) + 'bad) + good) + +(deftest block.6 + (block b1 + (return-from b1 (values)) + 1)) + +(deftest block.7 + (block b1 + (return-from b1 (values 1 2 3 4)) + 1) + 1 2 3 4) + +(deftest block.8 + (block foo) + nil) + +(deftest block.9 + (block foo (values 'a 'b) (values 'c 'd)) + c d) + +(deftest block.10 + (block done + (flet ((%f (x) (return-from done x))) + (block done (mapcar #'%f '(good bad bad)))) + 'bad) + good) + +;;; Block has no tagbody +(deftest block.11 + (block done + (tagbody + (block nil + (go 10) + 10 + (return-from done 'bad)) + 10 + (return-from done 'good))) + good) + +;;; Macros are expanded in the appropriate environment + +(deftest block.12 + (macrolet ((%m (z) z)) + (block foo (expand-in-current-env (%m :good)))) + :good) + +#| +(deftest return.error.1 + (signals-error + (block nil + (return 'a 'b)) + program-error) + t) +|# diff --git a/test/ansi/compile.lisp b/test/ansi/compile.lisp new file mode 100644 index 0000000..1284c90 --- /dev/null +++ b/test/ansi/compile.lisp @@ -0,0 +1,97 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 10 20:54:20 2002 +;;;; Contains: Tests for COMPILE, COMPILED-FUNCTION-P, COMPILED-FUNCTION + +(in-package #:cvm.test) + +(5am:def-suite compile :in eval-and-compile) +(5am:in-suite compile) + +#+(or) +(deftest compile.1 + (progn + (fmakunbound 'compile.1-fn) + (values + (eval '(defun compile.1-fn (x) x)) + (compiled-function-p 'compile.1-fn) + (let ((x (compile 'compile.1-fn))) + (or (eqt x 'compile.1-fn) + (notnot (compiled-function-p x)))) + (compiled-function-p 'compile.1-fn) + (not (compiled-function-p #'compile.1-fn)) + (fmakunbound 'compile.1-fn))) + compile.1-fn + nil + t + nil + nil + compile.1-fn) + +;;; COMPILE returns three values (function, warnings-p, failure-p) +#+(or) +(deftest compile.2 + (let* ((results (multiple-value-list + (compile nil '(lambda (x y) (cons y x))))) + (fn (car results))) + (values (length results) + (funcall fn 'a 'b) + (second results) + (third results))) + 3 + (b . a) + nil + nil) + +;;; Compile does not coalesce literal constants +(5am:test compile.3 + (5am:is-false + (let ((x (list 'a 'b)) + (y (list 'a 'b))) + (funcall (compile nil `(lambda () (eq ',x ',y))))))) + +(5am:test compile.4 + (5am:is-false + (let ((x (copy-seq "abc")) + (y (copy-seq "abc"))) + (funcall (compile nil `(lambda () (eq ,x ,y))))))) + +(5am:test compile.5 + (5am:is-true + (let ((x (copy-seq "abc"))) + (funcall (compile nil `(lambda () (eq ,x ,x))))))) + +(5am:test compile.6 + (5am:is-true + (let ((x (copy-seq "abc"))) + (funcall (compile nil `(lambda () (eq ',x ',x))))))) + +(5am:test compile.7 + (let ((x (copy-seq "abc"))) + (5am:is (eq x (funcall (compile nil `(lambda () ,x))))))) + +(5am:test compile.8 + (let ((x (list 'a 'b))) + (5am:is (eq x (funcall (compile nil `(lambda () ',x))))))) + +#+(or) +(deftest compile.9 + (let ((i 0) a b) + (values + (funcall (compile (progn (setf a (incf i)) nil) + (progn (setf b (incf i)) '(lambda () 'z)))) + i a b)) + z 2 1 2) + +;;; Error tests + +#+(or) +(deftest compile.error.1 + (signals-error (compile) program-error) + t) + +#+(or) +(deftest compile.error.2 + (signals-error (compile nil '(lambda () nil) 'garbage) + program-error) + t) diff --git a/test/ansi/dynamic-extent.lisp b/test/ansi/dynamic-extent.lisp new file mode 100644 index 0000000..c67382a --- /dev/null +++ b/test/ansi/dynamic-extent.lisp @@ -0,0 +1,131 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 21 09:10:52 2005 +;;;; Contains: Tests of DYNAMIC-EXTENT + +(in-package #:cvm.test) + +(5am:def-suite dynamic-extent :in eval-and-compile) +(5am:in-suite dynamic-extent) + +(deftest dynamic-extent.1 + (let () (declare (dynamic-extent))) + nil) + +(deftest dynamic-extent.2 + (let ((x 'a)) + (declare (dynamic-extent x) (optimize speed (safety 0))) + x) + a) + +(deftest dynamic-extent.3 + (let ((x (list 'a 'b 'c))) + (declare (dynamic-extent x) (optimize speed (safety 0))) + (length x)) + 3) + +(deftest dynamic-extent.4 + (let ((x (vector 'a 'b 'c))) + (declare (dynamic-extent x) (optimize speed (safety 0))) + (length x)) + 3) + +(deftest dynamic-extent.5 + (flet ((%f (x) (list 'a x))) + (declare (dynamic-extent (function %f)) + (optimize speed (safety 0))) + (mapcar #'%f '(1 2 3))) + ((a 1) (a 2) (a 3))) + +(deftest dynamic-extent.6 + (labels ((%f (x) (list 'a x))) + (declare (dynamic-extent (function %f)) + (optimize speed (safety 0))) + (mapcar #'%f '(1 2 3))) + ((a 1) (a 2) (a 3))) + +(deftest dynamic-extent.7 + (labels ((%f (x) (if (consp x) + (cons (%f (car x)) (%f (cdr x))) + '*))) + (declare (dynamic-extent (function %f)) + (optimize speed (safety 0))) + (mapcar #'%f '((1) 2 (3 4 5)))) + ((* . *) * (* * * . *))) + +(deftest dynamic-extent.8 + (let ((x (+ most-positive-fixnum 2))) + (declare (dynamic-extent x) + (optimize speed (safety 0))) + (1- x)) + #.(1+ most-positive-fixnum)) + +(deftest dynamic-extent.9 + (flet ((f () (list 'a 'b))) + (let ((f (list 'c 'd))) + (declare (dynamic-extent (function f)) + (optimize speed (safety 0))) + f)) + (c d)) + +(deftest dynamic-extent.10 + (let ((x nil)) + (values + x + (locally (declare (dynamic-extent x) (notinline length) + (optimize speed (safety 0))) + (setq x (list 'a 'b 'c 'd 'e)) + (prog1 (length x) (setq x t))) + x)) + nil 5 t) + +(deftest dynamic-extent.11 + (let* ((x (list 'a 'b)) + (y (cons 'c x))) + (declare (dynamic-extent y) + (optimize speed (safety 0))) + (cdr y)) + (a b)) + +(5am:test dynamic-extent.12 + (5am:is-false + (let* ((contents '(1 0 0 1 1 0 1 1 0 1)) + (n (length contents))) + (loop for i from 1 to 32 + for type = `(unsigned-byte ,i) + for form1 = `(make-array '(,n) :initial-contents ',contents + :element-type ',type) + for form2 = `(let ((a ,form1)) + (declare (dynamic-extent a)) + (declare (type (simple-array ,type (,n)))) + (declare (notinline coerce)) + (declare (optimize speed (safety 0))) + (equal (coerce a 'list) ',contents)) + unless (eval form2) + collect i))) + nil) + +(5am:test dynamic-extent.13 + (is-true-eval + (let ((s (make-string 10 :initial-element #\a))) + (declare (dynamic-extent s) (optimize speed (safety 0))) + (every #'(lambda (c) (eql c #\a)) s)))) + +(5am:test dynamic-extent.14 + (is-true-eval + (let ((s (make-string 10 :initial-element #\a + :element-type 'base-char))) + (declare (dynamic-extent s) (notinline every) (optimize speed (safety 0))) + (every #'(lambda (c) (eql c #\a)) s)))) + +(deftest dynamic-extent.15 + (flet (((setf %f) (x y) (setf (car y) x))) + (declare (dynamic-extent #'(setf %f))) + :good) + :good) + +(deftest dynamic-extent.16 + (labels (((setf %f) (x y) (setf (car y) x))) + (declare (dynamic-extent #'(setf %f))) + :good) + :good) diff --git a/test/ansi/eval-when.lisp b/test/ansi/eval-when.lisp new file mode 100644 index 0000000..4a654d1 --- /dev/null +++ b/test/ansi/eval-when.lisp @@ -0,0 +1,146 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 6 17:00:30 2003 +;;;; Contains: Tests for EVAL-WHEN + +;;; The following test was suggested by Sam Steingold, +;;; so I've created this file to hold it. + +(in-package #:cvm.test) + +(5am:def-suite eval-when :in eval-and-compile) +(5am:in-suite eval-when) + +#+(or) +(defvar *eval-when.1-collector*) + +#+(or) +(deftest eval-when.1 + + (let ((forms nil) all (ff "generated-eval-when-test-file.lisp")) + (dolist (c '(nil (:compile-toplevel))) + (dolist (l '(nil (:load-toplevel))) + (dolist (x '(nil (:execute))) + (push `(eval-when (,@c ,@l ,@x) + (push '(,@c ,@l ,@x) *eval-when.1-collector*)) + forms)))) + (dolist (c '(nil (:compile-toplevel))) + (dolist (l '(nil (:load-toplevel))) + (dolist (x '(nil (:execute))) + (push `(let () (eval-when (,@c ,@l ,@x) + (push '(let ,@c ,@l ,@x) *eval-when.1-collector*))) + forms)))) + (with-open-file (o ff :direction :output :if-exists :supersede) + (dolist (f forms) + (prin1 f o) + (terpri o))) + (let ((*eval-when.1-collector* nil)) + (load ff) + (push (cons "load source" *eval-when.1-collector*) all)) + (let ((*eval-when.1-collector* nil)) + (compile-file ff) + (push (cons "compile source" *eval-when.1-collector*) all)) + (let ((*eval-when.1-collector* nil)) + (load (compile-file-pathname ff)) + (push (cons "load compiled" *eval-when.1-collector*) all)) + (delete-file ff) + (delete-file (compile-file-pathname ff)) + #+clisp (delete-file (make-pathname :type "lib" :defaults ff)) + (nreverse all)) + + (("load source" + (:execute) (:load-toplevel :execute) (:compile-toplevel :execute) + (:compile-toplevel :load-toplevel :execute) + (let :execute) (let :load-toplevel :execute) + (let :compile-toplevel :execute) + (let :compile-toplevel :load-toplevel :execute)) + ("compile source" + (:compile-toplevel) (:compile-toplevel :execute) + (:compile-toplevel :load-toplevel) + (:compile-toplevel :load-toplevel :execute)) + ("load compiled" + (:load-toplevel) (:load-toplevel :execute) + (:compile-toplevel :load-toplevel) + (:compile-toplevel :load-toplevel :execute) + (let :execute) (let :load-toplevel :execute) + (let :compile-toplevel :execute) + (let :compile-toplevel :load-toplevel :execute)))) + +;;; More EVAL-WHEN tests to go here + +(deftest eval-when.2 + (eval-when () :bad) + nil) + +(deftest eval-when.3 + (eval-when (:execute)) + nil) + +(deftest eval-when.4 + (eval-when (:execute) :good) + :good) + +(deftest eval-when.5 + (eval-when (:compile-toplevel) :bad) + nil) + +(deftest eval-when.6 + (eval-when (:load-toplevel) :bad) + nil) + +(deftest eval-when.7 + (eval-when (:compile-toplevel :execute) :good) + :good) + +(deftest eval-when.8 + (eval-when (:load-toplevel :execute) :good) + :good) + +(deftest eval-when.9 + (eval-when (:load-toplevel :compile-toplevel) :bad) + nil) + +(deftest eval-when.10 + (eval-when (:load-toplevel :compile-toplevel :execute) :good) + :good) + +(deftest eval-when.11 + (eval-when (:execute) (values 'a 'b 'c 'd)) + a b c d) + +(deftest eval-when.12 + (let ((x :good)) + (values (eval-when (:load-toplevel) (setq x :bad)) x)) + nil :good) + +(deftest eval-when.13 + (let ((x :good)) + (values (eval-when (:compile-toplevel) (setq x :bad)) x)) + nil :good) + +(deftest eval-when.14 + (let ((x :bad)) + (values (eval-when (:execute) (setq x :good)) x)) + :good :good) + +(deftest eval-when.15 + (let ((x :good)) + (values (eval-when (load) (setq x :bad)) x)) + nil :good) + +(deftest eval-when.16 + (let ((x :good)) + (values (eval-when (compile) (setq x :bad)) x)) + nil :good) + +(deftest eval-when.17 + (let ((x :bad)) + (values (eval-when (eval) (setq x :good)) x)) + :good :good) + +;;; Macros are expanded in the appropriate environment + +(deftest eval-when.18 + (macrolet ((%m (z) z)) + (eval-when (:execute) (expand-in-current-env (%m :good)))) + :good) diff --git a/test/ansi/eval.lisp b/test/ansi/eval.lisp new file mode 100644 index 0000000..c954343 --- /dev/null +++ b/test/ansi/eval.lisp @@ -0,0 +1,57 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Nov 21 10:43:15 2002 +;;;; Contains: Tests of EVAL + +(in-package #:cvm.test) + +(5am:def-suite eval :in eval-and-compile) +(5am:in-suite eval) + +(deftest eval.1 + 1 + 1) + +#+(or) +(deftest eval.2 + (loop for x being the symbols of "KEYWORD" + always (eq (eval x) x)) + t) + +(5am:test eval.3 + (5am:is-true (let ((s "abcd")) + (eql (eval s) s)))) + +#+(or) +(deftest eval.4 + (eval '(car '(a . b))) + a) + +(deftest eval.5 + (let ((x 0)) x) + 0) + +(5am:test eval.6 + (5am:is (eql 1 (funcall #'eval 1)))) + +#+(or) +(deftest eval.order.1 + (let ((i 0)) + (values (eval (progn (incf i) 10)) i)) + 10 1) + +;;; Error cases + +(5am:test eval.error.1 + (5am:signals program-error (eval))) + +#+(or) +(deftest eval.error.2 + (signals-error (eval nil nil) program-error) + t) + +(5am:test eval.error.3 + (5am:signals undefined-function (eval (list (gensym))))) + +(5am:test eval.error.4 + (5am:signals unbound-variable (eval (gensym)))) diff --git a/test/ansi/flet.lisp b/test/ansi/flet.lisp new file mode 100644 index 0000000..cf4badd --- /dev/null +++ b/test/ansi/flet.lisp @@ -0,0 +1,592 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Oct 8 22:55:02 2002 +;;;; Contains: Tests of FLET + +(in-package #:cvm.test) + +(5am:def-suite flet :in data-and-control-flow) +(5am:in-suite flet) + +(deftest flet.1 + (flet ((%f () 1)) + (%f)) + 1) + +(deftest flet.2 + (flet ((%f (x) x)) + (%f 2)) + 2) + +(deftest flet.3 + (flet ((%f (&rest args) args)) + (%f 'a 'b 'c)) + (a b c)) + +;;; The optional arguments are not in the block defined by +;;; the local function declaration +(deftest flet.4 + (block %f + (flet ((%f (&optional (x (return-from %f :good))) + nil)) + (%f) + :bad)) + :good) + +;;; Key arguments are not in the block defined by +;;; the local function declaration +(deftest flet.4a + (block %f + (flet ((%f (&key (x (return-from %f :good))) + nil)) + (%f) + :bad)) + :good) + +(deftest flet.5 + (flet ((%f () (return-from %f 15) 35)) + (%f)) + 15) + +;;; The aux parameters are not in the block defined by +;;; the local function declaration +(deftest flet.6 + (block %f + (flet ((%f (&aux (x (return-from %f 10))) + 20)) + (%f))) + 10) + +;;; The function is not visible inside itself +(deftest flet.7 + (flet ((%f (x) (+ x 5))) + (flet ((%f (y) (cond ((eql y 20) 30) + (t (%f 20))))) + (%f 15))) + 25) + +;;; Keyword arguments +(deftest flet.8 + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f)) + nil 0 nil) + +(deftest flet.9 + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :a 1)) + 1 0 nil) + +(deftest flet.10 + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :b 2)) + nil 2 t) + +(deftest flet.11 + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :b 2 :a 3)) + 3 2 t) + +;;; Unknown keyword parameter should throw a program-error in safe code +;;; (section 3.5.1.4) +(5am:test flet.12 + (signals-eval + program-error + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)))) + +;;; Odd # of keyword args should throw a program-error in safe code +;;; (section 3.5.1.6) +(5am:test flet.13 + (signals-eval + program-error + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)))) + +;;; Too few arguments (section 3.5.1.2) +(5am:test flet.14 + (signals-eval program-error (flet ((%f (a) a)) (%f)))) + +;;; Too many arguments (section 3.5.1.3) +(5am:test flet.15 + (signals-eval program-error (flet ((%f (a) a)) (%f 1 2)))) + +;;; Invalid keyword argument (section 3.5.1.5) +(5am:test flet.16 + (signals-eval program-error (flet ((%f (&key a) a)) (%f '(foo))))) + + +;;; Definition of a (setf ...) function + +(deftest flet.17 + (flet (((setf %f) (x y) (setf (car y) x))) + (let ((z (list 1 2))) + (setf (%f z) 'a) + z)) + (a 2)) + +;;; Body is an implicit progn +(deftest flet.18 + (flet ((%f (x) (incf x) (+ x x))) + (%f 10)) + 22) + +;;; Can handle at least 50 lambda parameters +(deftest flet.19 + (flet ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) + (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) + (%f 1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 + 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50)) + 1275) + +;;; flet works with a large (maximal?) number of arguments +#+(or) ; figure out lambda-parameters-limit +(deftest flet.20 + (let* ((n (min (1- lambda-parameters-limit) 1024)) + (vars (loop repeat n collect (gensym)))) + (eval + `(eqlt ,n + (flet ((%f ,vars (+ ,@ vars))) + (%f ,@(loop for e in vars collect 1)))))) + t) + +;;; Declarations and documentation strings are ok +(deftest flet.21 + (flet ((%f (x) + (declare (type fixnum x)) + "Add one to the fixnum x." + (1+ x))) + (declare (ftype (function (fixnum) integer) %f)) + (%f 10)) + 11) + +(deftest flet.22 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p)) + (list x y (not (not y-p)) z (not (not z-p))))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c))) + (10 1 nil 2 nil) + (20 40 t 2 nil) + (a b t c t)) + +(deftest flet.23 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r) + (list x y (not (not y-p)) z (not (not z-p)) r))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f 'g 'h))) + (10 1 nil 2 nil nil) + (20 40 t 2 nil nil) + (a b t c t nil) + (d e t f t (g h))) + +(deftest flet.24 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h) + (%f 'd 'e 'f :bar 'i) )) + (10 1 nil 2 nil nil nil nil) + (20 40 t 2 nil nil nil nil) + (a b t c t nil nil nil) + (d e t f t (:foo h) h nil) + (d e t f t (:bar i) nil i)) + +(deftest flet.25 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar + &allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :whatever nil) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z) )) + (10 1 nil 2 nil nil nil nil) + (20 40 t 2 nil nil nil nil) + (a b t c t nil nil nil) + (d e t f t (:foo h :whatever nil) h nil) + (d e t f t (:bar i :illegal t :foo z) z i)) + +(deftest flet.26 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys t) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys t) )) + (10 1 nil 2 nil nil nil nil) + (20 40 t 2 nil nil nil nil) + (a b t c t nil nil nil) + (d e t f t (:foo h :whatever nil :allow-other-keys t) h nil) + (d e t f t (:bar i :illegal t :foo z :allow-other-keys t) z i)) + +;;; Section 3.4.1.4.1: "The :allow-other-keys argument is permissible +;;; in all situations involving keyword[2] arguments, even when its +;;; associated value is false." +(deftest flet.27 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :allow-other-keys nil) + (%f 'd 'e 'f :bar 'i :allow-other-keys nil) )) + (10 1 nil 2 nil nil nil nil) + (20 40 t 2 nil nil nil nil) + (a b t c t nil nil nil) + (d e t f t (:foo h :allow-other-keys nil) h nil) + (d e t f t (:bar i :allow-other-keys nil) nil i)) + +(deftest flet.28 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r + &key foo bar allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys + r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys 100) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys 200) )) + (10 1 nil 2 nil nil nil nil nil) + (20 40 t 2 nil nil nil nil nil) + (a b t c t nil nil nil nil) + (d e t f t 100 (:foo h :whatever nil :allow-other-keys 100) h nil) + (d e t f t 200 (:bar i :illegal t :foo z :allow-other-keys 200) z i)) + +(deftest flet.29 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r + &key foo bar allow-other-keys &allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys + r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys nil :blah t) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z + :allow-other-keys nil :zzz 10) )) + (10 1 nil 2 nil nil nil nil nil) + (20 40 t 2 nil nil nil nil nil) + (a b t c t nil nil nil nil) + (d e t f t nil (:foo h :whatever nil :allow-other-keys nil :blah t) h nil) + (d e t f t nil (:bar i :illegal t :foo z :allow-other-keys nil :zzz 10) z i)) + +;;; Tests of non-keyword keywords (see section 3.4.1.4, paragrph 2). +(deftest flet.30 + (flet ((%f (&key ((foo bar) nil)) bar)) + (values (%f) (%f 'foo 10))) + nil 10) + +(deftest flet.31 + (flet ((%f (&key ((:foo bar) nil)) bar)) + (values (%f) (%f :foo 10))) + nil 10) + +;;; Multiple keyword actual parameters +(deftest flet.32 + (flet ((%f (&key a b c) (list a b c))) + (%f :a 10 :b 20 :c 30 :a 40 :b 50 :c 60)) + (10 20 30)) + +;;; More aux parameters +(deftest flet.33 + (flet ((%f (x y &aux (a (1+ x)) (b (+ x y a)) (c (list x y a b))) + c)) + (%f 5 9)) + (5 9 6 20)) + +(deftest flet.34 + (flet ((%f (x y &rest r &key foo bar &aux (c (list x y r foo bar))) + c)) + (values + (%f 1 2) + (%f 1 2 :foo 'a) + (%f 1 2 :bar 'b) + (%f 1 2 :foo 'a :bar 'b) + (%f 1 2 :bar 'b :foo 'a))) + (1 2 nil nil nil) + (1 2 (:foo a) a nil) + (1 2 (:bar b) nil b) + (1 2 (:foo a :bar b) a b) + (1 2 (:bar b :foo a) a b)) + +;;; Binding of formal parameters that are also special variables +(deftest flet.35 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (x) + (declare (special x)) + (%f))) + (%g 'good)))) + good) + +(deftest flet.36 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&aux (x 'good)) + (declare (special x)) + (%f))) + (%g)))) + good) + +(deftest flet.37 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&rest x) + (declare (special x)) + (%f))) + (%g 'good)))) + (good)) + +(deftest flet.38 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&key (x 'good)) + (declare (special x)) + (%f))) + (%g)))) + good) + +(deftest flet.39 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&key (x 'bad)) + (declare (special x)) + (%f))) + (%g :x 'good)))) + good) + +(deftest flet.40 + (let ((x 'good)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&key (x 'bad)) + (%f))) + (%g :x 'worse)))) + good) + + +(deftest flet.45 + (flet ((nil () 'a)) (nil)) + a) + +(deftest flet.46 + (flet ((t () 'b)) (t)) + b) + +;;; Keywords can be function names +(deftest flet.47 + (flet ((:foo () 'bar)) (:foo)) + bar) + +(deftest flet.48 + (flet ((:foo () 'bar)) (funcall #':foo)) + bar) + +#+(or) +(deftest flet.49 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(ignore-errors (flet ((,s () 'a)) (,s))) + unless (eq (eval form) 'a) + collect s) + nil) + +#+(or) +(deftest flet.50 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(ignore-errors (flet ((,s () 'a)) + (declare (ftype (function () symbol) + ,s)) + (,s))) + unless (eq (eval form) 'a) + collect s) + nil) + +;;; Binding SETF functions of certain COMMON-LISP symbols +#+(or) +(deftest flet.51 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(ignore-errors + (flet (((setf ,s) (&rest args) + (declare (ignore args)) + 'a)) + (setf (,s) 10))) + unless (eq (eval form) 'a) + collect s) + nil) + +;;; Check that FLET does not have a tagbody +(deftest flet.52 + (block done + (tagbody + (flet ((%f () (go 10) 10 (return-from done 'bad))) + (%f)) + 10 + (return-from done 'good))) + good) + +;;; Check that nil keyword arguments do not enable the default values + +(deftest flet.53 + (flet ((%f (&key (a 'wrong)) a)) (%f :a nil)) + nil) + +(deftest flet.54 + (flet ((%f (&key (a 'wrong a-p)) (list a (not a-p)))) (%f :a nil)) + (nil nil)) + +(deftest flet.55 + (flet ((%f (&key ((:a b) 'wrong)) b)) (%f :a nil)) + nil) + +(deftest flet.56 + (flet ((%f (&key ((:a b) 'wrong present?)) (list b (not present?)))) (%f :a nil)) + (nil nil)) + +(deftest flet.57 + (flet ((%f (&key) 'good)) + (%f :allow-other-keys nil)) + good) + +(deftest flet.58 + (flet ((%f (&key) 'good)) + (%f :allow-other-keys t)) + good) + +(deftest flet.59 + (flet ((%f (&key) 'good)) + (%f :allow-other-keys t :a 1 :b 2)) + good) + +(deftest flet.60 + (flet ((%f (&key &allow-other-keys) 'good)) + (%f :a 1 :b 2)) + good) + +;;; NIL as a disallowed keyword argument +(5am:test flet.61 + (signals-eval + program-error + (flet ((%f (&key) :bad)) (%f nil nil)))) + +;;; Free declarations do not affect argument forms + +(deftest flet.62 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (flet ((%f (&optional (y x)) + (declare (special x)) + y)) + (%f)))) + :good) + +(deftest flet.63 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (flet ((%f (&key (y x)) + (declare (special x)) + y)) + (%f)))) + :good) + +(deftest flet.64 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (flet () (declare (special x))) + x)) + :good) + +(deftest flet.65 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (flet ((%f () (declare (special x))))) + x)) + :good) + +(deftest flet.66 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (flet ((%f () (declare (special x)))) + x))) + :good) + +(deftest flet.67 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (flet ((%f (&aux (y x)) + (declare (special x)) + y)) + (%f)))) + :good) + +(deftest flet.68 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (flet ((%f () x)) + (declare (special x)) + (%f)))) + :good) + +(deftest flet.69 + (let ((*x* 0)) + (declare (special *x*)) + (flet ((%f (i) + #'(lambda (arg) + (declare (ignore arg)) + (incf *x* i)))) + (values + (mapcar (%f 1) '(a b c)) + (mapcar (%f 2) '(a b c))))) + (1 2 3) + (5 7 9)) + +;;; Macros are expanded in the appropriate environment + +(deftest flet.70 + (macrolet ((%m (z) z)) + (flet () (expand-in-current-env (%m :good)))) + :good) + +(deftest flet.71 + (macrolet ((%m (z) z)) + (flet ((%f () (expand-in-current-env (%m :good)))) + (%f))) + :good) + +;;; local function bindings shadow global functions, macros +;;; and compiler-macros + +#+(or) +(defun flet.72 () :bad) + +#+(or) +(deftest flet.72 + (flet ((flet.72 () :good)) + (flet.72)) + :good) + +#+(or) +(defmacro flet.73 () :bad) + +#+(or) +(deftest flet.73 + (flet ((flet.73 () :good)) + (flet.73)) + :good) + +#+(or) +(define-compiler-macro flet.74 (&whole form) + :bad) + +#+(or) +(deftest flet.74 + (flet ((flet.74 () :good)) + (flet.74)) + :good) diff --git a/test/ansi/if.lisp b/test/ansi/if.lisp new file mode 100644 index 0000000..c4ead9b --- /dev/null +++ b/test/ansi/if.lisp @@ -0,0 +1,76 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 08:21:29 2002 +;;;; Contains: Tests for IF + +(in-package #:cvm.test) + +(5am:def-suite if :in data-and-control-flow) +(5am:in-suite if) + +(deftest if.1 + (if t 1 2) + 1) + +(deftest if.2 + (if nil 1 2) + 2) + +(deftest if.3 (if t (values) 'a)) + +(deftest if.4 + (if nil 'a) + nil) + +(deftest if.5 + (if t (values 'a 'b 'c) 'd) + a b c) + +(deftest if.6 + (if nil 'a (values 'b 'c 'd)) + b c d) + +(deftest if.7 (if nil 'a (values))) + +;;; Macros are expanded in the appropriate environment + +(deftest if.8 + (macrolet ((%m (z) z)) + (if (expand-in-current-env (%m t)) :good :bad)) + :good) + +(deftest if.9 + (macrolet ((%m (z) z)) + (if (expand-in-current-env (%m nil)) :bad)) + nil) + +(deftest if.10 + (macrolet ((%m (z) z)) + (if (expand-in-current-env (%m t)) :good)) + :good) + +(deftest if.11 + (macrolet ((%m (z) z)) + (if (expand-in-current-env (%m nil)) :bad :good)) + :good) + +(deftest if.12 + (macrolet + ((%m (z) z)) + (flet ((%f (x y) (if x (expand-in-current-env (%m y))))) + (declare (notinline %f)) + (values (%f t :good) (%f nil :bad)))) + :good nil) + +(deftest if.13 + (macrolet + ((%m (z) z)) + (flet ((%f (x y z) (if x y (expand-in-current-env (%m z))))) + (declare (notinline %f)) + (values (%f t :good :bad) (%f nil :bad :good)))) + :good :good) + +(deftest if.order.1 + (let ((i 0)) + (values (if (= (incf i) 1) 't nil) i)) + t 1) diff --git a/test/ansi/ignorable.lisp b/test/ansi/ignorable.lisp new file mode 100644 index 0000000..fa587eb --- /dev/null +++ b/test/ansi/ignorable.lisp @@ -0,0 +1,56 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 21 08:16:27 2005 +;;;; Contains: Tests of the IGNORABLE declaration + +(in-package #:cvm.test) + +(5am:def-suite ignorable :in eval-and-compile) +(5am:in-suite ignorable) + +(deftest ignorable.1 + (let ((x 'foo)) (declare (ignorable x))) + nil) + +(deftest ignorable.2 + (let ((x 'foo)) (declare (ignorable x)) x) + foo) + +(deftest ignorable.3 + (flet ((%f () 'foo)) + (declare (ignorable (function %f)))) + nil) + +(deftest ignorable.4 + (flet ((%f () 'foo)) + (declare (ignorable (function %f))) + (%f)) + foo) + +;;; TODO: add a test for (function (setf foo)) + +(deftest ignorable.5 + (flet (((setf %f) (x y) nil)) + (declare (ignorable (function (setf %f)))) + :good) + :good) + +(deftest ignorable.6 + (flet (((setf %f) (x y) (setf (car y) x))) + (declare (ignorable (function (setf %f)))) + (let ((z (cons 'a 'b))) + (values (setf (%f z) 'c) z))) + c (c . b)) + +(deftest ignorable.7 + (labels (((setf %f) (x y) nil)) + (declare (ignorable (function (setf %f)))) + :good) + :good) + +(deftest ignorable.8 + (labels (((setf %f) (x y) (setf (car y) x))) + (declare (ignorable (function (setf %f)))) + (let ((z (cons 'a 'b))) + (values (setf (%f z) 'c) z))) + c (c . b)) diff --git a/test/ansi/ignore.lisp b/test/ansi/ignore.lisp new file mode 100644 index 0000000..bd86dce --- /dev/null +++ b/test/ansi/ignore.lisp @@ -0,0 +1,40 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 21 07:59:24 2005 +;;;; Contains: Tests of the IGNORE declarations + +(in-package #:cvm.test) + +(5am:def-suite ignore :in eval-and-compile) +(5am:in-suite ignore) + +(deftest ignore.1 + (let ((x 'foo)) (declare (ignore x))) + nil) + +(deftest ignore.2 + (let ((x 'foo)) (declare (ignore x)) x) + foo) + +(deftest ignore.3 + (flet ((%f () 'foo)) + (declare (ignore (function %f)))) + nil) + +(deftest ignore.4 + (flet ((%f () 'foo)) + (declare (ignore (function %f))) + (%f)) + foo) + +(deftest ignore.5 + (flet (((setf %f) (x y) (setf (car y) x))) + (declare (ignore (function (setf %f)))) + :good) + :good) + +(deftest ignore.6 + (labels (((setf %f) (x y) (setf (car y) x))) + (declare (ignore (function (setf %f)))) + :good) + :good) diff --git a/test/ansi/labels.lisp b/test/ansi/labels.lisp new file mode 100644 index 0000000..e3a9488 --- /dev/null +++ b/test/ansi/labels.lisp @@ -0,0 +1,440 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Oct 9 19:06:33 2002 +;;;; Contains: Tests of LABELS + +(in-package #:cvm.test) + +(5am:def-suite labels :in data-and-control-flow) +(5am:in-suite labels) + +(deftest labels.1 + (labels ((%f () 1)) + (%f)) + 1) + +(deftest labels.2 + (labels ((%f (x) x)) + (%f 2)) + 2) + +(deftest labels.3 + (labels ((%f (&rest args) args)) + (%f 'a 'b 'c)) + (a b c)) + +;;; The optional arguments are not in the block defined by +;;; the local function declaration +(deftest labels.4 + (block %f + (labels ((%f (&optional (x (return-from %f :good))) + nil)) + (%f) + :bad)) + :good) + +;;; Keyword parameter initializers are not in the blocked defined +;;; by the local function declaration + +(deftest labels.4a + (block %f + (labels ((%f (&key (x (return-from %f :good))) + nil)) + (%f) + :bad)) + :good) + +(deftest labels.5 + (labels ((%f () (return-from %f 15) 35)) + (%f)) + 15) + +;;; The aux parameters are not in the block defined by +;;; the local function declaration +(deftest labels.6 + (block %f + (labels ((%f (&aux (x (return-from %f 10))) + 20)) + (%f) + :bad)) + 10) + +;;; The function is visible inside itself +(deftest labels.7 + (labels ((%f (x n) (cond ((eql n 0) x) + (t (%f (+ x n) (1- n)))))) + (%f 0 10)) + 55) + +;;; Scope of defined function names includes &AUX parameters + +(deftest labels.7b + (labels ((%f (x &aux (b (%g x))) b) + (%g (y) (+ y y))) + (%f 10)) + 20) + +;;; Scope of defined function names includes &OPTIONAL parameters + +(deftest labels.7c + (labels ((%f (x &optional (b (%g x))) b) + (%g (y) (+ y y))) + (%f 10)) + 20) + +;;; Scope of defined function names includes &KEY parameters + +(deftest labels.7d + (labels ((%f (x &key (b (%g x))) b) + (%g (y) (+ y y))) + (%f 10)) + 20) + +;;; Keyword arguments +(deftest labels.8 + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f)) + nil 0 nil) + +(deftest labels.9 + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :a 1)) + 1 0 nil) + +(deftest labels.10 + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :b 2)) + nil 2 t) + +(deftest labels.11 + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :b 2 :a 3)) + 3 2 t) + +;;; Unknown keyword parameter should throw a program-error in safe code +;;; (section 3.5.1.4) +(5am:test labels.12 + (signals-eval + program-error + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)))) + +;;; Odd # of keyword args should throw a program-error in safe code +;;; (section 3.5.1.6) +(5am:test labels.13 + (signals-eval + program-error + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)))) + +;;; Too few arguments (section 3.5.1.2) +(5am:test labels.14 + (signals-eval program-error + (labels ((%f (a) a)) (%f)))) + +;;; Too many arguments (section 3.5.1.3) +(5am:test labels.15 + (signals-eval program-error + (labels ((%f (a) a)) (%f 1 2)))) + +;;; Invalid keyword argument (section 3.5.1.5) +(5am:test labels.16 + (signals-eval program-error + (labels ((%f (&key a) a)) (%f '(foo))))) + +;;; Definition of a (setf ...) function + +(deftest labels.17 + (labels (((setf %f) (x y) (setf (car y) x))) + (let ((z (list 1 2))) + (setf (%f z) 'a) + z)) + (a 2)) + +;;; Body is an implicit progn +(deftest labels.18 + (labels ((%f (x) (incf x) (+ x x))) + (%f 10)) + 22) + +;;; Can handle at least 50 lambda parameters +(deftest labels.19 + (labels ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) + (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) + (%f 1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 + 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50)) + 1275) + +;;; labels works with the maximum number of arguments (if +;;; not too many.) +#+(or) +(deftest labels.20 + (let* ((n (min (1- lambda-parameters-limit) 1024)) + (vars (loop repeat n collect (gensym)))) + (eval + `(eqlt ,n + (labels ((%f ,vars (+ ,@ vars))) + (%f ,@(loop for e in vars collect 1)))))) + t) + +;;; Declarations and documentation strings are ok +(deftest labels.21 + (labels ((%f (x) + (declare (type fixnum x)) + "Add one to the fixnum x." + (1+ x))) + (declare (ftype (function (fixnum) integer) %f)) + (%f 10)) + 11) + +;;; Keywords can be function names +(deftest labels.22 + (labels ((:foo () 10) + (:bar () (1+ (:foo)))) + (:bar)) + 11) + +(deftest labels.23 + (labels ((:foo () 10) + (:bar () (1+ (funcall #':foo)))) + (funcall #':bar)) + 11) + +#+(or) +(deftest labels.24 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(ignore-errors (labels ((,s (x) (foo (1- x))) + (foo (y) + (if (<= y 0) 'a + (,s (1- y))))) + (,s 10))) + unless (eq (eval form) 'a) + collect s) + nil) + +#+(or) +(deftest labels.25 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(ignore-errors + (labels ((,s (x) (foo (1- x))) + (foo (y) + (if (<= y 0) 'a + (,s (1- y))))) + (declare (ftype (function (integer) symbol) + foo ,s)) + (,s 10))) + unless (eq (eval form) 'a) + collect s) + nil) + +#+(or) +(deftest labels.26 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(ignore-errors + (labels (((setf ,s) (&rest args) + (declare (ignore args)) + 'a)) + (setf (,s) 10))) + unless (eq (eval form) 'a) + collect s) + nil) + +;;; Check that LABELS does not have a tagbody +(deftest labels.27 + (block done + (tagbody + (labels ((%f () (go 10) 10 (return-from done 'bad))) + (%f)) + 10 + (return-from done 'good))) + good) + +;;; Check that nil keyword arguments do not enable the default values + +(deftest labels.28 + (labels ((%f (&key (a 'wrong)) a)) (%f :a nil)) + nil) + +(deftest labels.29 + (labels ((%f (&key (a 'wrong a-p)) (list a (not a-p)))) (%f :a nil)) + (nil nil)) + +(deftest labels.30 + (labels ((%f (&key ((:a b) 'wrong)) b)) (%f :a nil)) + nil) + +(deftest labels.31 + (labels ((%f (&key ((:a b) 'wrong present?)) (list b (not present?)))) + (%f :a nil)) + (nil nil)) + +(deftest labels.32 + (labels ((%f (&key) 'good)) + (%f :allow-other-keys nil)) + good) + +(deftest labels.33 + (labels ((%f (&key) 'good)) + (%f :allow-other-keys t)) + good) + +(deftest labels.34 + (labels ((%f (&key) 'good)) + (%f :allow-other-keys t :a 1 :b 2)) + good) + +(deftest labels.35 + (labels ((%f (&key &allow-other-keys) 'good)) + (%f :a 1 :b 2)) + good) + +;;; NIL as a disallowed keyword argument +(5am:test labels.36 + (signals-eval + program-error + (labels ((%f (&key) :bad)) (%f nil nil)))) + +;;; Identity of function objects +;;; Since (FUNCTION ) returns *the* functional value, it +;;; should be the case that different invocations of this form +;;; in the same lexical environment return the same value. + +(5am:test labels.37 + (is-true-eval (labels ((f () 'foo)) + (eq #'f #'f)))) + +#+(or) +(deftest labels.38 + (labels ((f () 'foo)) + (destructuring-bind (x y) (loop repeat 2 collect #'f) (eqlt x y))) + t) + +(5am:test labels.39 + (is-true-eval (labels ((f () #'f)) + (eql (f) #'f)))) + +(5am:test labels.40 + (is-true-eval (let ((x (labels ((f () #'f)) #'f))) + (eql x (funcall x))))) + +;;; Test that free declarations do not affect argument forms + +(deftest labels.41 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (labels ((%f (&optional (y x)) + (declare (special x)) + y)) + (%f)))) + :good) + +(deftest labels.42 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (labels ((%f (&key (y x)) + (declare (special x)) + y)) + (%f)))) + :good) + +(deftest labels.43 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (labels () (declare (special x))) + x)) + :good) + +(deftest labels.44 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (labels ((%f () (declare (special x))))) + x)) + :good) + +(deftest labels.45 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (labels ((%f () (declare (special x)))) + x))) + :good) + +(deftest labels.46 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (labels ((%f (&aux (y x)) + (declare (special x)) + y)) + (%f)))) + :good) + +(deftest labels.47 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + (labels ((%f () x)) + (declare (special x)) + (%f)))) + :good) + +;;; Macros are expanded in the appropriate environment + +(deftest labels.48 + (macrolet ((%m (z) z)) + (labels () (expand-in-current-env (%m :good)))) + :good) + +(deftest labels.49 + (macrolet ((%m (z) z)) + (labels ((%f () (expand-in-current-env (%m :good)))) + (%f))) + :good) + + +;;; local function bindings shadow global functions, macros +;;; and compiler-macros + + +#+(or) +(defun labels.50 () :bad) + +#+(or) +(deftest labels.50 + (labels ((labels.50 () :good)) + (labels.50)) + :good) + +#+(or) +(defmacro labels.51 () :bad) + +#+(or) +(deftest labels.51 + (labels ((labels.51 () :good)) + (labels.51)) + :good) + +#+(or) +(define-compiler-macro labels.52 (&whole form) + :bad) + +#+(or) +(deftest labels.52 + (labels ((labels.52 () :good)) + (labels.52)) + :good) + + diff --git a/test/ansi/lambda.lisp b/test/ansi/lambda.lisp new file mode 100644 index 0000000..c285a0d --- /dev/null +++ b/test/ansi/lambda.lisp @@ -0,0 +1,382 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Nov 27 06:43:21 2002 +;;;; Contains: Tests of LAMBDA forms + +(in-package #:cvm.test) + +(5am:def-suite lambda :in eval-and-compile) +(5am:in-suite lambda) + +(deftest lambda.1 + ((lambda (x) x) 'a) + a) + +(deftest lambda.2 + ((lambda () 'a)) + a) + +(deftest lambda.3 + ((lambda () "documentation" 'a)) + a) + +(deftest lambda.4 + ((lambda (x) (declare (type symbol x)) x) 'z) + z) + +(deftest lambda.5 + ((lambda (&aux (x 'a)) x)) + a) + +(deftest lambda.6 + ((lambda (&aux (x 'a)) (declare (type symbol x)) x)) + a) + +(deftest lambda.7 + ((lambda () "foo")) + "foo") + +(deftest lambda.8 + ((lambda () "foo" "bar")) + "bar") + +(deftest lambda.9 + ((lambda (x y) (declare (ignore x)) "foo" (declare (ignore y)) "bar") 1 2) + "bar") + +(deftest lambda.10 + ((lambda (x) (declare (type symbol x) (ignorable x))) 'z) + nil) + +(deftest lambda.11 + ((lambda (x &optional y z) (list x y z)) 1 2) + (1 2 nil)) + +(deftest lambda.12 + ((lambda (&optional (x 'a) (y 'b) (z 'c)) (list x y z)) 1 nil) + (1 nil c)) + +(deftest lambda.13 + ((lambda (&optional (x 'a x-p) (y 'b y-p) (z 'c z-p)) + (list* x y z (mapcar #'notnot (list x-p y-p z-p)))) 1 nil) + (1 nil c t t nil)) + +(deftest lambda.14 + (let ((x 1)) + ((lambda (&optional (x (1+ x))) x))) + 2) + +(deftest lambda.15 + ((lambda (y &optional (x (1+ y))) (list y x)) 10) + (10 11)) + +(deftest lambda.16 + ((lambda (y &optional (x (1+ y))) (list y x)) 10 14) + (10 14)) + +(deftest lambda.17 + ((lambda (&rest x) x) 1 2 3) + (1 2 3)) + +(deftest lambda.18 + (let ((b 10)) + ((lambda (&optional (a b) (b (1+ a))) (list a b)) 3 7)) + (3 7)) + +(deftest lambda.19 + (let ((b 10)) + ((lambda (&optional (a b) (b (1+ a))) (list a b)) 3)) + (3 4)) + +(deftest lambda.20 + (let ((b 10)) + ((lambda (&optional (a b) (b (1+ a))) (list a b)))) + (10 11)) + +(deftest lambda.21 + (flet ((%f () (locally (declare (special *x*)) (incf *x*)))) + ((lambda (*x*) + (declare (special *x*)) + (%f) + *x*) + 10)) + 11) + +(deftest lambda.22 + (flet ((%f () (locally (declare (special *x*)) (1+ *x*)))) + ((lambda (*x*) + (declare (special *x*)) + (%f)) + 15)) + 16) + +(deftest lambda.23 + ((lambda (&key a) a)) + nil) + +(deftest lambda.24 + ((lambda (&key a b c) (list a b c))) + (nil nil nil)) + +(deftest lambda.25 + ((lambda (&key (a 1) (b 2) (c 3)) (list a b c))) + (1 2 3)) + +(deftest lambda.26 + ((lambda (&key))) + nil) + +(deftest lambda.27 + ((lambda (&key) 'good) :allow-other-keys nil) + good) + +(deftest lambda.28 + ((lambda (&key) 'good) :allow-other-keys t :foo t) + good) + +(deftest lambda.29 + ((lambda (&key) 'good) :allow-other-keys t :allow-other-keys nil :foo t) + good) + +(deftest lambda.30 + ((lambda (&key x) x) :allow-other-keys t :x 10 + :allow-other-keys nil :foo t) + 10) + +(deftest lambda.31 + ((lambda (&rest x &key) x)) + nil) + +(deftest lambda.32 + ((lambda (&rest x &key) x) :allow-other-keys nil) + (:allow-other-keys nil)) + +(deftest lambda.33 + ((lambda (&rest x &key) x) :w 5 :allow-other-keys t :x 10) + (:w 5 :allow-other-keys t :x 10)) + +(deftest lambda.34 + ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) + b (notnot b-p) + c (notnot c-p))) + :c 5 :a 0) + (0 t 2 nil 5 t)) + +(deftest lambda.35 + ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) + b (notnot b-p) + c (notnot c-p))) + :c 5 :a nil :a 17 :c 100) + (nil t 2 nil 5 t)) + +(deftest lambda.36 + ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) + b (notnot b-p) + c (notnot c-p))) + :c 5 :a 0 :allow-other-keys t 'b 100) + (0 t 2 nil 5 t)) + +(deftest lambda.37 + (let ((b 1)) + ((lambda (&key (a b) b) (list a b)) :b 'x)) + (1 x)) + +(deftest lambda.38 + (let ((b 1)) + ((lambda (&key (a b) b) (list a b)) :b 'x :a nil)) + (nil x)) + +(deftest lambda.39 + (let ((a-p :bad)) + (declare (ignorable a-p)) + ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))))) + (nil nil nil)) + +(deftest lambda.40 + (let ((a-p :bad)) + (declare (ignorable a-p)) + ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) + :a 1)) + (1 t t)) + +(deftest lambda.41 + (let ((a-p :bad)) + (declare (ignorable a-p)) + ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) + :a nil)) + (nil t t)) + +(deftest lambda.42 + ((lambda (&key a b &allow-other-keys) (list a b)) :a 1 :b 2) + (1 2)) + +(deftest lambda.43 + ((lambda (&key a b &allow-other-keys) (list a b)) :b 2 :a 1) + (1 2)) + +(deftest lambda.44 + ((lambda (&key a b &allow-other-keys) (list a b)) :z 10 :b 2 :b nil :a 1 + :a 2 'x 100) + (1 2)) + +(deftest lambda.45 + ((lambda (&key a b &allow-other-keys) (list a b)) :allow-other-keys nil + :z 10 :b 2 :b nil :a 1 :a 2 'x 100) + (1 2)) + +(deftest lambda.46 + ((lambda (&key a b allow-other-keys) (list allow-other-keys a b)) + :allow-other-keys nil :a 1 :b 2) + (nil 1 2)) + +(deftest lambda.47 + ((lambda (&key a b allow-other-keys) (list allow-other-keys a b)) + :c 10 :allow-other-keys t :a 1 :b 2 :d 20) + (t 1 2)) + +(deftest lambda.48 + ((lambda (&key a b allow-other-keys &allow-other-keys) + (list allow-other-keys a b)) + :d 40 :allow-other-keys nil :a 1 :b 2 :c 20) + (nil 1 2)) + +(deftest lambda.49 + ((lambda (&key a b allow-other-keys &allow-other-keys) + (list allow-other-keys a b)) + :d 40 :a 1 :b 2 :c 20) + (nil 1 2)) + +(deftest lambda.50 + ((lambda (&key a b ((:allow-other-keys aok))) + (list aok a b)) + :d 40 :a 1 :allow-other-keys t :b 2 :c 20) + (t 1 2)) + +(deftest lambda.51 + ((lambda (&key &allow-other-keys)) :a 1 :b 2 :c 3) + nil) + +;;; Free declaration scope + +(deftest lambda.52 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + ((lambda (&optional (y x)) (declare (special x)) y)))) + :good) + +(deftest lambda.53 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + ((lambda (&key (y x)) (declare (special x)) y)))) + :good) + +(deftest lambda.54 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + ((lambda (&aux (y x)) (declare (special x)) y)))) + :good) + +(deftest lambda.55 + (let* ((doc "LMB55") + (fn (eval `#'(lambda () ,doc nil))) + (cfn (compile nil fn))) + (values + (or (documentation fn t) doc) + (or (documentation cfn t) doc))) + "LMB55" + "LMB55") + +(deftest lambda.56 + (let* ((doc "LMB56") + (fn (eval `#'(lambda () ,doc nil))) + (cfn (compile nil fn))) + (values + (or (documentation fn 'function) doc) + (or (documentation cfn 'function) doc))) + "LMB56" + "LMB56") + +;;; Uninterned symbols as lambda variables + +(deftest lambda.57 + ((lambda (#1=#:foo) #1#) 17) + 17) + +(deftest lambda.58 + ((lambda (&rest #1=#:foo) #1#) 'a 'b 'c) + (a b c)) + +(deftest lambda.59 + ((lambda (&optional #1=#:foo) #1#)) + nil) + +(deftest lambda.60 + ((lambda (&optional (#1=#:foo t)) #1#)) + t) + +(deftest lambda.61 + ((lambda (&optional (#1=#:foo t)) #1#) 'bar) + bar) + +(deftest lambda.62 + ((lambda (&key #1=#:foo) #1#) :foo 12) + 12) + +;;; Test that declarations for aux variables are handled properly + +(deftest lambda.63 + (let ((y :bad1)) + (declare (ignore y)) + (let ((y :bad2)) + (declare (special y)) + (flet ((%f () y)) + ((lambda (x &aux (y :good)) + (declare (special y) (ignore x)) + (%f)) + nil)))) + :good) + +(deftest lambda.64 + (let ((x :bad)) + (declare (special x)) + (flet ((%f () x)) + ((lambda (x &aux (y (%f))) + (declare (type t y) (special x)) + y) + :good))) + :good) + +;;; Tests of lambda as a macro + +#+(or) +(deftest lambda.macro.1 + (notnot (macro-function 'lambda)) + t) + +#+(or) +(deftest lambda.macro.2 + (funcall (eval (macroexpand '(lambda () 10)))) + 10) + +;;; Error tests + +#+(or) +(deftest lambda.error.1 + (signals-error (funcall (macro-function 'lambda)) + program-error) + t) + +#+(or) +(deftest lambda.error.2 + (signals-error (funcall (macro-function 'lambda) '(lambda ())) + program-error) + t) + +#+(or) +(deftest lambda.error.3 + (signals-error (funcall (macro-function 'lambda) '(lambda ()) nil nil) + program-error) + t) diff --git a/test/ansi/let.lisp b/test/ansi/let.lisp new file mode 100644 index 0000000..587a78c --- /dev/null +++ b/test/ansi/let.lisp @@ -0,0 +1,173 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 09:24:36 2002 +;;;; Contains: Tests for LET, LET* + +(in-package #:cvm.test) + +(5am:def-suite let :in data-and-control-flow) +(5am:in-suite let) + +;;; LET and LET* are also heavily exercised in the many other tests. + +;;; NOTE! Some of these tests bind a variable with the same name +;;; more than once. This apparently has underdetermined semantics that +;;; varies in different Lisps. + +(deftest let.1 + (let ((x 0)) x) + 0) + +(deftest let.2 + (let ((x 0) (y 1)) (values x y)) + 0 1) + +(deftest let.3 + (let ((x 0) (y 1)) (declare (special x y)) (values x y)) + 0 1) + +(deftest let.4 + (let ((x 0)) + (let ((x 1)) + x)) + 1) + +(deftest let.5 + (let ((x 0)) + (let ((#:x 1)) + x)) + 0) + +(deftest let.6 + (let ((x 0)) + (declare (special x)) + (let ((x 1)) + (values x (locally (declare (special x)) x)))) + 1 0) + +(deftest let.7 + (let ((x '(a b c))) + (declare (dynamic-extent x)) + x) + (a b c)) + +;;;(deftest let.8 +;;; (let ((x 0) (x 1)) x) +;;; 1) + +(deftest let.9 + (let (x y z) (values x y z)) + nil nil nil) + +;;; (deftest let.10 +;;; (let ((x 1) x) x) +;;; nil) + +(deftest let.11 + (let ((x 1)) + (list x + (let (x) + (declare (special x)) + x) + x)) + (1 nil 1)) + +;;; (deftest let.12 +;;; (let ((x 0)) +;;; (values +;;; (let ((x 20) +;;; (x (1+ x))) +;;; x) +;;; x)) +;;; 1 0) + +;;; (deftest let.13 +;;; (flet ((%f () (declare (special x)) +;;; (if (boundp 'x) x 10))) +;;; (let ((x 1) +;;; (x (1+ (%f)))) +;;; (declare (special x)) +;;; x)) +;;; 11) + +;;; Tests of large number of LET variables +(5am:test let.14 + (let* ((n 100) + (vars (mapcar #'gensym (make-list n :initial-element "G"))) + (expr `(let ,(let ((i 0)) + (mapcar #'(lambda (v) (list v (incf i))) vars)) + ,(let ((sumexpr 0)) + (dolist (v vars) + (setq sumexpr `(+ ,v ,sumexpr))) + sumexpr))) + (val (eval expr))) + (5am:is (eql (/ (* n (1+ n)) 2) val)))) + +;;; Test that all non-variables exported from COMMON-LISP can be bound +;;; in LET forms. +#+(or) +(deftest let.15 + (loop for s in *cl-non-variable-constant-symbols* + for form = `(ignore-errors (let ((,s 17)) ,s)) + unless (eql (eval form) 17) + collect s) + nil) + +;;; Check that LET does not have a tagbody +(deftest let.16 + (block done + (tagbody + (let () (go 10) 10 (return-from done 'bad)) + 10 + (return-from done 'good))) + good) + +;;; Check that free declarations do not apply to the init forms + +(deftest let.17 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) ;; lexical binding + (let ((y x)) + (declare (special x)) ;; free declaration + y))) + :good) + +(5am:test let.17a + (5am:is (eql :good (funcall + (compile + nil + '(lambda () + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) ;; lexical binding + (let ((y x)) + (declare (special x)) ;; free declaration + y))))))))) + +(deftest let.18 + (let ((foo 'special)) + (declare (special foo)) + (let ((foo 'lexical)) + (locally (declare (special foo))) + foo)) + lexical) + +#+(or) +(deftest let.19 + (loop for k in lambda-list-keywords + unless (eql (eval `(let ((,k :foo)) ,k)) :foo) + collect k) + nil) + +;;; Macros are expanded in the appropriate environment + +(deftest let.20 + (macrolet ((%m (z) z)) + (let () (expand-in-current-env (%m :good)))) + :good) + +(deftest let.21 + (macrolet ((%m (z) z)) + (let ((x (expand-in-current-env (%m 1)))) (+ x x x))) + 3) diff --git a/test/ansi/letstar.lisp b/test/ansi/letstar.lisp new file mode 100644 index 0000000..71f0fef --- /dev/null +++ b/test/ansi/letstar.lisp @@ -0,0 +1,185 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Jun 24 20:53:36 2005 +;;;; Contains: Tests for LET* + +(in-package #:cvm.test) + +(5am:def-suite let* :in data-and-control-flow) +(5am:in-suite let*) + +(deftest let*.1 + (let* ((x 0)) x) + 0) + +(deftest let*.2 + (let* ((x 0) (y 1)) (values x y)) + 0 1) + +(deftest let*.3 + (let* ((x 0) (y 1)) (declare (special x y)) (values x y)) + 0 1) + +(deftest let*.4 + (let* ((x 0)) + (let* ((x 1)) + x)) + 1) + +(deftest let*.5 + (let* ((x 0)) + (let* ((#:x 1)) + x)) + 0) + +(deftest let*.6 + (let* ((x 0)) + (declare (special x)) + (let* ((x 1)) + (values x (locally (declare (special x)) x)))) + 1 0) + +(deftest let*.7 + (let* ((x '(a b c))) + (declare (dynamic-extent x)) + x) + (a b c)) + +(deftest let*.8 + (let* ((x 0) (x 1)) x) + 1) + +(deftest let*.9 + (let* (x y z) (values x y z)) + nil nil nil) + +(deftest let*.10 + (let* ((x 1) x) x) + nil) + +(deftest let*.11 + (let* ((x 1)) + (list x + (let* (x x x) + (declare (special x)) + x) + x)) + (1 nil 1)) + +(deftest let*.12 + (let* ((x 1) + (y (1+ x)) + (x (1+ y)) + (z (+ x y))) + (values x y z)) + 3 2 5) + +;;; (deftest let*.13 +;;; (flet ((%f () (declare (special x)) x)) +;;; (let* ((x 1) +;;; (x (1+ (%f)))) +;;; (declare (special x)) +;;; x)) +;;; 2) + +;;; Tests of large number of LET* variables +(5am:test let*.14 + (let* ((n 100) + (vars (mapcar #'gensym (make-list n :initial-element "G"))) + (expr `(let* ,(let ((i 0)) + (mapcar #'(lambda (v) (list v (incf i))) vars)) + ,(let ((sumexpr 0)) + (dolist (v vars) + (setq sumexpr `(+ ,v ,sumexpr))) + sumexpr))) + (val (eval expr))) + (5am:is (eql (/ (* n (1+ n)) 2) val)))) + +;;; Test that all non-variables exported from COMMON-LISP can be bound +;;; in LET* forms. +#+(or) +(deftest let*.15 + (loop for s in *cl-non-variable-constant-symbols* + for form = `(ignore-errors (let* ((,s 17)) ,s)) + unless (eql (eval form) 17) + collect s) + nil) + +;;; Check that LET* does not have a tagbody +(deftest let*.16 + (block done + (tagbody + (let () (go 10) 10 (return-from done 'bad)) + 10 + (return-from done 'good))) + good) + +;;; Check that free declarations do not apply to the init forms + +(deftest let*.17 + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) ;; lexical binding + (let* ((y x)) + (declare (special x)) ;; free declaration + y))) + :good) + +(5am:test let*.17a + (5am:is (eql :good (funcall + (compile + nil + '(lambda () + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) ;; lexical binding + (let* ((y x)) + (declare (special x)) ;; free declaration + y))))))))) + +(deftest let*.18 + (let ((x :bad1) + (z :bad2)) + (declare (special x z)) + (let ((x :good) + (z :good)) ;; lexical bindings + (let* ((y x) + (w z)) + (declare (special x)) ;; free declaration + (values y w)))) + :good + :good) + +(deftest let*.19 + (let ((foo 'special)) + (declare (special foo)) + (let* ((foo 'lexical)) + (locally (declare (special foo))) + foo)) + lexical) + +#+(or) +(deftest let*.20 + (loop for k in lambda-list-keywords + unless (eql (eval `(let* ((,k :foo)) ,k)) :foo) + collect k) + nil) + +;;; Macros are expanded in the appropriate environment + +(deftest let*.21 + (macrolet ((%m (z) z)) + (let* () (expand-in-current-env (%m :good)))) + :good) + +(deftest let*.22 + (macrolet ((%m (z) z)) + (let* ((x (expand-in-current-env (%m 1)))) (+ x x x))) + 3) + +(deftest let*.23 + (macrolet ((%m (z) z)) + (let* ((x (expand-in-current-env (%m 1))) + (y (expand-in-current-env (%m 2)))) + (+ x y))) + 3) diff --git a/test/ansi/locally.lisp b/test/ansi/locally.lisp new file mode 100644 index 0000000..7dd80c5 --- /dev/null +++ b/test/ansi/locally.lisp @@ -0,0 +1,49 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Jan 8 06:02:47 2005 +;;;; Contains: Tests of LOCALLY + +(in-package #:cvm.test) + +(5am:def-suite locally :in eval-and-compile) +(5am:in-suite locally) + +(deftest locally.1 + (locally) + nil) + +(deftest locally.2 + (locally (values))) + +(deftest locally.3 + (locally (values 1 2 3 4)) + 1 2 3 4) + +(deftest locally.4 + (locally (declare) t) + t) + +(deftest locally.5 + (locally (declare) (declare) (declare) t) + t) + +(deftest locally.6 + (let ((x 'a)) + (declare (special x)) + (let ((x 'b)) + (values + x + (locally (declare (special x)) x) + x))) + b a b) + +(deftest locally.7 + (locally (declare)) + nil) + +;;; Macros are expanded in the appropriate environment + +(deftest locally.8 + (macrolet ((%m (z) z)) + (locally (expand-in-current-env (%m :good)))) + :good) diff --git a/test/ansi/macrolet.lisp b/test/ansi/macrolet.lisp new file mode 100644 index 0000000..ef53ced --- /dev/null +++ b/test/ansi/macrolet.lisp @@ -0,0 +1,486 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Oct 9 19:41:24 2002 +;;;; Contains: Tests of MACROLET + +(in-package #:cvm.test) + +(5am:def-suite macrolet :in data-and-control-flow) +(5am:in-suite macrolet) + +(deftest macrolet.1 + (let ((z (list 3 4))) + (macrolet ((%m (x) `(car ,x))) + (let ((y (list 1 2))) + (values (%m y) (%m z))))) + 1 3) + +(deftest macrolet.2 + (let ((z (list 3 4))) + (macrolet ((%m (x) `(car ,x))) + (let ((y (list 1 2))) + (values + (setf (%m y) 6) + (setf (%m z) 'a) + y z)))) + 6 a (6 2) (a 4)) + +;;; Inner definitions shadow outer ones +(deftest macrolet.3 + (macrolet ((%m (w) `(cadr ,w))) + (let ((z (list 3 4))) + (macrolet ((%m (x) `(car ,x))) + (let ((y (list 1 2))) + (values + (%m y) (%m z) + (setf (%m y) 6) + (setf (%m z) 'a) + y z))))) + 1 3 6 a (6 2) (a 4)) + +;;; &whole parameter +(deftest macrolet.4 + (let ((x nil)) + (macrolet ((%m (&whole w arg) + `(progn (setq x (quote ,w)) + ,arg))) + (values (%m 1) x))) + 1 (%m 1)) + +;;; &whole parameter (nested, destructuring; see section 3.4.4) +(deftest macrolet.5 + (let ((x nil)) + (macrolet ((%m ((&whole w arg)) + `(progn (setq x (quote ,w)) + ,arg))) + (values (%m (1)) x))) + 1 (1)) + +;;; key parameter +#+(or) +(deftest macrolet.6 + (let ((x nil)) + (macrolet ((%m (&key (a 'xxx) b) + `(setq x (quote ,a)))) + (values (%m :a foo) x + (%m :b bar) x))) + foo foo xxx xxx) + +;;; nested key parameters +(deftest macrolet.7 + (let ((x nil)) + (macrolet ((%m ((&key a b)) + `(setq x (quote ,a)))) + (values (%m (:a foo)) x + (%m (:b bar)) x))) + foo foo nil nil) + +;;; nested key parameters +(deftest macrolet.8 + (let ((x nil)) + (macrolet ((%m ((&key (a 10) b)) + `(setq x (quote ,a)))) + (values (%m (:a foo)) x + (%m (:b bar)) x))) + foo foo 10 10) + +;;; keyword parameter with supplied-p parameter +#+(or) +(deftest macrolet.9 + (let ((x nil)) + (macrolet ((%m (&key (a 'xxx a-p) b) + `(setq x (quote ,(list a (not (not a-p))))))) + (values (%m :a foo) x + (%m :b bar) x))) + (foo t) (foo t) (xxx nil) (xxx nil)) + + +;;; rest parameter +(deftest macrolet.10 + (let ((x nil)) + (macrolet ((%m (b &rest a) + `(setq x (quote ,a)))) + (values (%m a1 a2) x))) + (a2) (a2)) + +;;; rest parameter w. destructuring +(deftest macrolet.11 + (let ((x nil)) + (macrolet ((%m ((b &rest a)) + `(setq x (quote ,a)))) + (values (%m (a1 a2)) x))) + (a2) (a2)) + +;;; rest parameter w. whole +(deftest macrolet.12 + (let ((x nil)) + (macrolet ((%m (&whole w b &rest a) + `(setq x (quote ,(list a w))))) + (values (%m a1 a2) x))) + ((a2) (%m a1 a2)) + ((a2) (%m a1 a2))) + +;;; Interaction with symbol-macrolet + +(deftest macrolet.13 + (symbol-macrolet ((a b)) + (macrolet ((foo (x &environment env) + (let ((y (macroexpand x env))) + (if (eq y 'a) 1 2)))) + (foo a))) + 2) + +(deftest macrolet.14 + (symbol-macrolet ((a b)) + (macrolet ((foo (x &environment env) + (let ((y (macroexpand-1 x env))) + (if (eq y 'a) 1 2)))) + (foo a))) + 2) + +(deftest macrolet.15 + (macrolet ((nil () ''a)) + (nil)) + a) + +#+(or) +(deftest macrolet.16 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(ignore-errors (macrolet ((,s () ''a)) (,s))) + unless (eq (eval form) 'a) + collect s) + nil) + +#+(or) +(deftest macrolet.17 + (macrolet ((%m (&key (a t)) `(quote ,a))) + (%m :a nil)) + nil) + +#+(or) +(deftest macrolet.18 + (macrolet ((%m (&key (a t a-p)) `(quote (,a ,(notnot a-p))))) + (%m :a nil)) + (nil t)) + +(deftest macrolet.19 + (macrolet ((%m (x &optional y) `(quote (,x ,y)))) + (values (%m 1) (%m 2 3))) + (1 nil) + (2 3)) + +(deftest macrolet.20 + (macrolet ((%m (x &optional (y 'a)) `(quote (,x ,y)))) + (values (%m 1) (%m 2 3))) + (1 a) + (2 3)) + +;;; Note -- the supplied-p parameter in a macrolet &optional +;;; is required to be T (not just true) if the parameter is present. +;;; See section 3.4.4.1.2 +(deftest macrolet.21 + (macrolet ((%m (x &optional (y 'a y-p)) `(quote (,x ,y ,y-p)))) + (values (%m 1) (%m 2 3))) + (1 a nil) + (2 3 t)) + +(deftest macrolet.22 + (macrolet ((%m (x &optional ((y z) '(2 3))) `(quote (,x ,y ,z)))) + (values + (%m a) + (%m a (b c)))) + (a 2 3) + (a b c)) + +(deftest macrolet.22a + (macrolet ((%m (x &optional ((y z) '(2 3) y-z-p)) + `(quote (,x ,y ,z ,y-z-p)))) + (values + (%m a) + (%m a (b c)))) + (a 2 3 nil) + (a b c t)) + +(deftest macrolet.23 + (macrolet ((%m (&rest y) `(quote ,y))) + (%m 1 2 3)) + (1 2 3)) + +;;; According to 3.4.4.1.2, the entity following &rest is +;;; 'a destructuring pattern that matches the rest of the list.' + +(deftest macrolet.24 + (macrolet ((%m (&rest (x y z)) `(quote (,x ,y ,z)))) + (%m 1 2 3)) + (1 2 3)) + +(deftest macrolet.25 + (macrolet ((%m (&body (x y z)) `(quote (,x ,y ,z)))) + (%m 1 2 3)) + (1 2 3)) + +;;; More key parameters + +#+(or) +(deftest macrolet.26 + (macrolet ((%m (&key ((:a b))) `(quote ,b))) + (values (%m) + (%m :a x))) + nil + x) + +#+(or) +(deftest macrolet.27 + (macrolet ((%m (&key ((:a (b c)))) `(quote (,c ,b)))) + (%m :a (1 2))) + (2 1)) + +#+(or) +(deftest macrolet.28 + (macrolet ((%m (&key ((:a (b c)) '(3 4))) `(quote (,c ,b)))) + (values (%m :a (1 2)) + (%m :a (1 2) :a (10 11)) + (%m))) + (2 1) + (2 1) + (4 3)) + +#+(or) +(deftest macrolet.29 + (macrolet ((%m (&key a (b a)) `(quote (,a ,b)))) + (values (%m) + (%m :a 1) + (%m :b 2) + (%m :a 3 :b 4) + (%m :b 5 :a 6) + (%m :a 7 :a 8) + (%m :a 9 :b nil) + (%m :a 10 :b nil :b 11))) + (nil nil) + (1 1) + (nil 2) + (3 4) + (6 5) + (7 7) + (9 nil) + (10 nil)) + +(deftest macrolet.30 + (macrolet ((%m ((&key a) &key (b a)) `(quote (,a ,b)))) + (values (%m ()) + (%m (:a 1)) + (%m () :b 2) + (%m (:a 3) :b 4) + (%m (:a 7 :a 8)) + (%m (:a 9) :b nil) + (%m (:a 10) :b nil :b 11))) + (nil nil) + (1 1) + (nil 2) + (3 4) + (7 7) + (9 nil) + (10 nil)) + +(deftest macrolet.31 + (macrolet ((%m (&key ((:a (b c)) '(3 4) a-p)) + `(quote (,(notnot a-p) ,c ,b)))) + (values (%m :a (1 2)) + (%m :a (1 2) :a (10 11)) + (%m))) + (t 2 1) + (t 2 1) + (nil 4 3)) + +;;; Allow-other-keys tests + +#+(or) +(deftest macrolet.32 + (macrolet ((%m (&key a b c) `(quote (,a ,b ,c)))) + (values + (%m :allow-other-keys nil) + (%m :a 1 :allow-other-keys nil) + (%m :allow-other-keys t) + (%m :allow-other-keys t :allow-other-keys nil :foo t) + (%m :allow-other-keys t :c 1 :b 2 :a 3) + (%m :allow-other-keys nil :c 1 :b 2 :a 3))) + (nil nil nil) + (1 nil nil) + (nil nil nil) + (nil nil nil) + (3 2 1) + (3 2 1)) + +#+(or) +(deftest macrolet.33 + (macrolet ((%m (&key allow-other-keys) `(quote ,allow-other-keys))) + (values + (%m) + (%m :allow-other-keys nil) + (%m :allow-other-keys t :foo t))) + nil + nil + t) + +(deftest macrolet.34 + (macrolet ((%m (&key &allow-other-keys) :good)) + (values + (%m) + (%m :foo t) + (%m :allow-other-keys nil :foo t))) + :good + :good + :good) + +#+(or) +(deftest macrolet.35 + (macrolet ((%m (&key a b &allow-other-keys) `(quote (,a ,b)))) + (values + (%m :a 1) + (%m :foo t :b 2) + (%m :allow-other-keys nil :a 1 :foo t :b 2))) + (1 nil) + (nil 2) + (1 2)) + +;;; &whole is followed by a destructuring pattern (see 3.4.4.1.2) +(deftest macrolet.36 + (macrolet ((%m (&whole (m a b) c d) `(quote (,m ,a ,b ,c ,d)))) + (%m 1 2)) + (%m 1 2 1 2)) + +;;; Macro names are shadowed by local functions + +(deftest macrolet.37 + (macrolet ((%f () :bad)) + (flet ((%f () :good)) + (%f))) + :good) + + +;;; The &environment parameter is bound first + +(deftest macrolet.38 + (macrolet ((foo () 1)) + (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env) + x)) + (%f))) + 1) + +;;; Test for bug that showed up in sbcl + +(deftest macrolet.39 + (macrolet ((%m (()) :good)) (%m ())) + :good) + +;;; Test that macrolets accept declarations + +(deftest macrolet.40 + (macrolet ((%x () t)) + (declare (optimize))) + nil) + +(deftest macrolet.41 + (macrolet ((%x () t)) + (declare (optimize)) + (declare (notinline identity))) + nil) + +(deftest macrolet.42 + (macrolet ((%x () t)) + (declare (optimize)) + (%x)) + t) + +(5am:test macrolet.43 + (let ((*x-in-macrolet.43* nil)) + (declare (special *x-in-macrolet.43*)) + (let ((*f* #'(lambda () *x-in-macrolet.43*))) + (declare (special *f*)) + (5am:is-false (eval `(macrolet ((%m (*x-in-macrolet.43*) + (declare (special *f*)) + (funcall *f*))) + (%m t))))))) + +(5am:test macrolet.44 + (let ((*x-in-macrolet.44* nil)) + (declare (special *x-in-macrolet.44*)) + (let ((*f* #'(lambda () *x-in-macrolet.44*))) + (declare (special *f*)) + (5am:is (eql t (eval `(macrolet ((%m (*x-in-macrolet.44*) + (declare (special *f* *x-in-macrolet.44*)) + (funcall *f*))) + (%m t)))))))) + +(5am:test macrolet.45 + (let ((*x-in-macrolet.45* nil)) + (declare (special *x-in-macrolet.45*)) + (let ((*f* #'(lambda () *x-in-macrolet.45*))) + (declare (special *f*)) + (5am:is (eql t (eval `(macrolet ((%m ((*x-in-macrolet.45*)) + (declare (special *f* *x-in-macrolet.45*)) + (funcall *f*))) + (%m (t))))))))) + +;;; Macros are expanded in the appropriate environment + +(deftest macrolet.46 + (macrolet ((%m (z) z)) + (macrolet () (expand-in-current-env (%m :good)))) + :good) + +;;; Free declarations in macrolet + +(deftest macrolet.47 + (let ((x :good)) + (declare (special x)) + (let ((x :bad)) + (macrolet () (declare (special x)) x))) + :good) + +(deftest macrolet.48 + (let ((x :good)) + (let ((y :bad)) + (macrolet () (declare (ignore y)) x))) + :good) + +(deftest macrolet.49 + (let ((x :good)) + (let ((y :bad)) + (macrolet () (declare (ignorable y)) x))) + :good) + + +;;; TODO: more special declarations for other macrolet arguments + + +;;; macrolet shadows global macro, function and compiler-macro +;;; definitions + +#+(or) +(defmacro macrolet.50 () :bad) + +#+(or) +(deftest macrolet.50 + (macrolet ((macrolet.50 () :good)) + (macrolet.50)) + :good) + +#+(or) +(defun macrolet.51 () :bad) + +#+(or) +(deftest macrolet.51 + (macrolet ((macrolet.51 () :good)) + (macrolet.51)) + :good) + +#+(or) +(define-compiler-macro macrolet.52 (&whole form) + :bad) + +#+(or) +(deftest macrolet.52 + (macrolet ((macrolet.52 () :good)) + (macrolet.52)) + :good) diff --git a/test/ansi/multiple-value-call.lisp b/test/ansi/multiple-value-call.lisp new file mode 100644 index 0000000..b37d85c --- /dev/null +++ b/test/ansi/multiple-value-call.lisp @@ -0,0 +1,35 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 23:35:07 2002 +;;;; Contains: Tests of MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-LIST + +(in-package #:cvm.test) + +(5am:def-suite multiple-value-call :in data-and-control-flow) +(5am:in-suite multiple-value-call) + +(deftest multiple-value-call.1 + (multiple-value-call #'+ (values 1 2) (values) 3 (values 4 5 6)) + 21) + +(deftest multiple-value-call.2 + (multiple-value-call 'list) + nil) + +(deftest multiple-value-call.3 + (multiple-value-call 'list (floor 13 4)) + (3 1)) + +;;; Macros are expanded in the appropriate environment + +(deftest multiple-value-call.4 + (macrolet + ((%m (z) z)) + (multiple-value-call (expand-in-current-env (%m #'list)) (values 1 2))) + (1 2)) + +(deftest multiple-value-call.5 + (macrolet + ((%m (z) z)) + (multiple-value-call 'list (expand-in-current-env (%m (values 1 2))))) + (1 2)) diff --git a/test/ansi/multiple-value-prog1.lisp b/test/ansi/multiple-value-prog1.lisp new file mode 100644 index 0000000..8306760 --- /dev/null +++ b/test/ansi/multiple-value-prog1.lisp @@ -0,0 +1,101 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 06:48:02 2002 +;;;; Contains: Tests for MULTIPLE-VALUE-PROG1 + +(in-package #:cvm.test) + +(5am:def-suite multiple-value-prog1 :in data-and-control-flow) +(5am:in-suite multiple-value-prog1) + +(deftest multiple-value-prog1.1 + (multiple-value-prog1 nil) + nil) + +(deftest multiple-value-prog1.2 + (multiple-value-prog1 '(a b c)) + (a b c)) + +(deftest multiple-value-prog1.3 + (multiple-value-prog1 (values-list '(a b c))) + a b c) + +(deftest multiple-value-prog1.4 + (multiple-value-prog1 (values))) + +(deftest multiple-value-prog1.5 + (let ((x 0) (y 0)) + (multiple-value-prog1 (values x y) + (incf x) (incf y 2))) + 0 0) + +(deftest multiple-value-prog1.6 + (let ((x 0) (y 0)) + (multiple-value-call + #'list + (multiple-value-prog1 (values x y) + (incf x) (incf y 2)) + x y)) + (0 0 1 2)) + +(deftest multiple-value-prog1.7 + (let ((x 0) (y 0)) + (multiple-value-call + #'list + (multiple-value-prog1 (values (incf x) y) + (incf x x) + (incf y 10)) + x y)) + (1 0 2 10)) + +#+(or) +(deftest multiple-value-prog1.8 + (let* ((n (min 100 multiple-values-limit))) + (not-mv + (loop for i from 0 below n + for x = (make-int-list i) + always + (equalt + (multiple-value-list + (eval `(multiple-value-prog1 (values-list (quote ,(copy-seq x))) + nil))) + x)))) + nil) + + +(deftest multiple-value-prog1.9 + (let ((x 0) (y 0)) + (values + (block foo + (multiple-value-prog1 + (values (incf x) (incf y 2)) + (return-from foo 'a))) + x y)) + a 1 2) + +;;; No implicit tagbody +(deftest multiple-value-prog1.10 + (block nil + (tagbody + (multiple-value-prog1 + (values) + (go 10) + 10 + (return 'bad)) + 10 + (return 'good))) + good) + +;;; Macros are expanded in the appropriate environment + +(deftest multiple-value-prog1.11 + (macrolet + ((%m (z) z)) + (multiple-value-prog1 (expand-in-current-env (%m :good)))) + :good) + +(deftest multiple-value-prog1.12 + (macrolet + ((%m (z) z)) + (multiple-value-prog1 :good (expand-in-current-env (%m :foo)))) + :good) diff --git a/test/ansi/optimize.lisp b/test/ansi/optimize.lisp new file mode 100644 index 0000000..c8dfdb6 --- /dev/null +++ b/test/ansi/optimize.lisp @@ -0,0 +1,57 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 21 09:31:34 2005 +;;;; Contains: Tests of the OPTIMIZE declaration + +(in-package #:cvm.test) + +(5am:def-suite optimize :in eval-and-compile) +(5am:in-suite optimize) + +(deftest optimize.1 + (locally (declare (optimize)) nil) + nil) + +(deftest optimize.2 + (locally (declare (optimize speed)) nil) + nil) + +(deftest optimize.3 + (locally (declare (optimize space)) nil) + nil) + +(deftest optimize.4 + (locally (declare (optimize safety)) nil) + nil) + +(deftest optimize.5 + (locally (declare (optimize debug)) nil) + nil) + +(deftest optimize.6 + (locally (declare (optimize compilation-speed)) nil) + nil) + +(5am:test optimize.7 + (5am:is-false + (loop for d in '(speed space safety debug compilation-speed) + nconc (loop for n from 0 to 3 + for form = `(locally (declare (optimize (,d ,n))) t) + for val = (eval form) + unless (eql val t) + collect (list d n val))))) + +(5am:test optimize.8 + (5am:is-false + (loop for d in '(speed space safety debug compilation-speed) + nconc (loop for n from 0 to 3 + for form = `(lambda () + (declare (optimize (,d ,n))) + t) + for val = (funcall (compile nil form)) + unless (eql val t) + collect (list d n val))))) + + + + diff --git a/test/ansi/progn.lisp b/test/ansi/progn.lisp new file mode 100644 index 0000000..3cba850 --- /dev/null +++ b/test/ansi/progn.lisp @@ -0,0 +1,70 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 09:33:51 2002 +;;;; Contains: Tests of PROGN + +(in-package #:cvm.test) + +(5am:def-suite progn :in data-and-control-flow) +(5am:in-suite progn) + +(deftest progn.1 + (progn) + nil) + +(deftest progn.2 + (progn 'a) + a) + +(deftest progn.3 + (progn 'b 'a) + a) + +(deftest progn.4 + (let ((x 0)) + (values (progn (incf x) x) x)) + 1 1) + +(deftest progn.5 (progn (values))) + +(deftest progn.6 + (progn (values 1 2) (values 'a 'b 'c 'd 'e)) + a b c d e) + +(deftest progn.7 + (let ((x 0)) + (prog () + (progn (go x) x 'a) + (return 'bad) + x + (return 'good))) + good) + +;;; No implicit tagbody +(deftest progn.8 + (block nil + (tagbody + (progn + (go 10) + 10 + (return 'bad)) + 10 + (return 'good))) + good) + +;;; Macros are expanded in the appropriate environment + +(deftest progn.9 + (macrolet + ((%m (z) z)) + (progn (expand-in-current-env (%m :good)))) + :good) + +(deftest progn.10 + (macrolet + ((%m (z) z)) + (progn (expand-in-current-env (%m :bad)) + (expand-in-current-env (%m :good)))) + :good) + + diff --git a/test/ansi/return-from.lisp b/test/ansi/return-from.lisp new file mode 100644 index 0000000..cf325d0 --- /dev/null +++ b/test/ansi/return-from.lisp @@ -0,0 +1,27 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Feb 24 20:22:23 2004 +;;;; Contains: Tests of RETURN-FROM + +(in-package #:cvm.test) + +(5am:def-suite return-from :in data-and-control-flow) +(5am:in-suite return-from) + +;;; RETURN-FROM is tested extensively in other files + +(deftest return-from.1 + (block xyz (return-from xyz) :bad) + nil) + +(deftest return-from.2 + (block nil (return-from nil :good) :bad) + :good) + +;;; Macros are expanded in the appropriate environment + +(deftest return-from.3 + (macrolet + ((%m (z) z)) + (block foo (return-from foo (expand-in-current-env (%m :good))))) + :good) diff --git a/test/ansi/special.lisp b/test/ansi/special.lisp new file mode 100644 index 0000000..df12a51 --- /dev/null +++ b/test/ansi/special.lisp @@ -0,0 +1,36 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 21 12:51:59 2005 +;;;; Contains: Tests of the declaration SPECIAL + +(in-package #:cvm.test) + +(5am:def-suite special :in eval-and-compile) +(5am:in-suite special) + +;;; Many tests for this declaration are in the tests +;;; for specific binding forms. + +(deftest special.1 + (let ((f 1)) + (declare (special f)) + (flet ((f () :good)) + (flet ((g () (f))) + (flet ((f () :bad)) + (g))))) + :good) + +(deftest special.2 + (let ((x 'a)) + (declare (special x)) + (let ((x 'b)) + (values x (locally (declare (special x)) x) x))) + b a b) + +(deftest special.3 + (flet ((%f () (declare (special x10)) x10)) + (let ((x10 'a)) + (declare (special x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) + (%f))) + a) + diff --git a/test/ansi/symbol-macrolet.lisp b/test/ansi/symbol-macrolet.lisp new file mode 100644 index 0000000..92b51f0 --- /dev/null +++ b/test/ansi/symbol-macrolet.lisp @@ -0,0 +1,89 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Jan 8 05:58:53 2005 +;;;; Contains: Tests of SYMBOL-MACROLET + +(in-package #:cvm.test) + +(5am:def-suite symbol-macrolet :in eval-and-compile) + +#+(or) +(deftest symbol-macrolet.1 + (loop for s in *cl-non-variable-constant-symbols* + for form = `(ignore-errors (symbol-macrolet ((,s 17)) ,s)) + unless (eql (eval form) 17) + collect s) + nil) + +(deftest symbol-macrolet.2 + (symbol-macrolet ()) + nil) + +(deftest symbol-macrolet.3 + (symbol-macrolet () (declare (optimize))) + nil) + +(deftest symbol-macrolet.4 + (symbol-macrolet ((x 1)) + (symbol-macrolet ((x 2)) + x)) + 2) + +(deftest symbol-macrolet.5 + (let ((x 10)) + (symbol-macrolet ((y x)) + (list x + y + (let ((x 20)) x) + (let ((y 30)) x) + (let ((y 50)) y) + x + y))) + (10 10 20 10 50 10 10)) + +(deftest symbol-macrolet.6 + (symbol-macrolet () (values))) + +(deftest symbol-macrolet.7 + (symbol-macrolet () (values 'a 'b 'c 'd 'e)) + a b c d e) + +(deftest symbol-macrolet.8 + (let ((x :good)) + (declare (special x)) + (let ((x :bad)) + (symbol-macrolet () (declare (special x)) x))) + :good) + +;;; Error tests + +(5am:test symbol-macrolet.error.1 + (signals-eval program-error + (symbol-macrolet ((x 10)) + (declare (special x)) + 20))) + +#+(or) +(defconstant constant-for-symbol-macrolet.error.2 nil) + +#+(or) +(deftest symbol-macrolet.error.2 + (signals-error (symbol-macrolet ((constant-for-symbol-macrolet.error.2 'a)) + constant-for-symbol-macrolet.error.2) + program-error) + t) + +#+(or) +(deftest symbol-macrolet.error.3 + (signals-error (symbol-macrolet ((*pathnames* 19)) *pathnames*) + program-error) + t) + +;;; Test that explicit calls to macroexpand in subforms +;;; are done in the correct environment + +(deftest symbol-macrolet.9 + (macrolet + ((%m (z) z)) + (symbol-macrolet () (expand-in-current-env (%m :good)))) + :good) diff --git a/test/ansi/tagbody.lisp b/test/ansi/tagbody.lisp new file mode 100644 index 0000000..17cf002 --- /dev/null +++ b/test/ansi/tagbody.lisp @@ -0,0 +1,187 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 13:27:22 2002 +;;;; Contains: Tests of TAGBODY + +(in-package #:cvm.test) + +(5am:def-suite tagbody :in data-and-control-flow) +(5am:in-suite tagbody) + +(deftest tagbody.1 + (tagbody) + nil) + +(deftest tagbody.2 + (tagbody 'a) + nil) + +(deftest tagbody.3 + (tagbody (values)) + nil) + +(deftest tagbody.4 + (tagbody (values 1 2 3 4 5)) + nil) + +(deftest tagbody.5 + (let ((x 0)) + (values + (tagbody + (setq x 1) + (go a) + (setq x 2) + a) + x)) + nil 1) + +(deftest tagbody.6 + (let ((x 0)) + (tagbody + (setq x 1) + (go a) + b + (setq x 2) + (go c) + a + (setq x 3) + (go b) + c) + x) + 2) + +;;; Macroexpansion occurs after tag determination +(deftest tagbody.7 + (let ((x 0)) + (macrolet ((%m () 'a)) + (tagbody + (tagbody + (go a) + (%m) + (setq x 1)) + a )) + x) + 0) + +(deftest tagbody.8 + (let ((x 0)) + (tagbody + (flet ((%f (y) (setq x y) (go a))) + (%f 10)) + (setq x 1) + a) + x) + 10) + +;;; Tag names are in their own name space +(deftest tagbody.9 + (let (result) + (tagbody + (flet ((a (x) x)) + (setq result (a 10)) + (go a)) + a) + result) + 10) + +(deftest tagbody.10 + (let (result) + (tagbody + (block a + (setq result 10) + (go a)) + (setq result 20) + a) + result) + 10) + +(deftest tagbody.11 + (let (result) + (tagbody + (catch 'a + (setq result 10) + (go a)) + (setq result 20) + a) + result) + 10) + +(deftest tagbody.12 + (let (result) + (tagbody + (block a + (setq result 10) + (return-from a nil)) + (setq result 20) + a) + result) + 20) + +;;; Test that integers are accepted as go tags + +(deftest tagbody.13 + (block done + (tagbody + (go around) + 10 + (return-from done 'good) + around + (go 10))) + good) + +(deftest tagbody.14 + (block done + (tagbody + (go around) + -10 + (return-from done 'good) + around + (go -10))) + good) + +(deftest tagbody.15 + (block done + (tagbody + (go around) + #.(1+ most-positive-fixnum) + (return-from done 'good) + around + (go #.(1+ most-positive-fixnum)))) + good) + +(5am:test tagbody.16 + (let* ((t1 (1+ most-positive-fixnum)) + (t2 (1+ most-positive-fixnum)) + (form `(block done + (tagbody + (go around) + ,t1 + (return-from done 'good) + around + (go ,t2))))) + (5am:is (eql 'good (eval form))))) + +;;; Check that macros are not expanded before finding tags +;;; Test for issue TAGBODY-TAG-EXPANSION + +(deftest tagbody.17 + (block done + (tagbody + (macrolet ((foo () 'tag)) + (let (tag) + (tagbody + (go tag) + (foo) + (return-from done :bad)))) + tag + (return-from done :good))) + :good) + +;;; Test that explicit calls to macroexpand in subforms +;;; are done in the correct environment + +(deftest tagbody.18 + (macrolet ((%m (z) z)) + (tagbody + (expand-in-current-env (%m :foo)))) + nil) diff --git a/test/ansi/the.lisp b/test/ansi/the.lisp new file mode 100644 index 0000000..d2b84e4 --- /dev/null +++ b/test/ansi/the.lisp @@ -0,0 +1,159 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue May 6 06:48:48 2003 +;;;; Contains: Tests of THE + +(in-package #:cvm.test) + +(5am:def-suite the :in eval-and-compile) +(5am:in-suite the) + +(deftest the.1 + (the (values) (values))) + +(deftest the.2 + (the (values) 'a) + a) + +#+(or) +(deftest the.3 + (check-predicate #'(lambda (e) + (let ((x (multiple-value-list (eval `(the (values) (quote ,e)))))) + (and x (not (cdr x)) (eql (car x) e))))) + nil) + +#+(or) +(deftest the.4 + (check-predicate #'(lambda (e) + (let ((x (multiple-value-list (eval `(the ,(type-of e) (quote ,e)))))) + (and x (not (cdr x)) (eql (car x) e))))) + nil) + +#+(or) +(deftest the.5 + (check-predicate #'(lambda (e) + (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (quote ,e)))))) + (and x (not (cdr x)) (eql (car x) e))))) + nil) + +#+(or) +(deftest the.6 + (check-predicate #'(lambda (e) + (let ((x (multiple-value-list (eval `(the (values ,(type-of e) t) (quote ,e)))))) + (and x (not (cdr x)) (eql (car x) e))))) + nil) + +#+(or) +(deftest the.7 + (check-predicate + #'(lambda (e) + (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) + (values (quote ,e) :ignored)))))) + (and (eql (length x) 2) + (eql (car x) e) + (eql (cadr x) :ignored))))) + nil) + +#+(or) +(deftest the.8 + (check-predicate #'(lambda (e) (or (not (constantp e)) + (eql (eval `(the ,(type-of e) ,e)) e)))) + nil) + +#+(or) +(deftest the.9 + (check-predicate #'(lambda (e) (or (not (constantp e)) + (eql (eval `(the ,(class-of e) ,e)) e)))) + nil) + +#+(or) +(deftest the.10 + (check-predicate #'(lambda (e) (eql (eval `(the ,(class-of e) ',e)) e))) + nil) + +#+(or) +(deftest the.11 + (check-predicate + #'(lambda (e) + (let* ((type (type-of e)) + (x (multiple-value-list (eval `(the ,type (the ,type (quote ,e))))))) + (and x (not (cdr x)) (eql (car x) e))))) + nil) + +#+(or) +(deftest the.12 + (let ((lexpr + `(lambda () + (and + ,@(loop for e in *mini-universe* + for type = (type-of e) + collect `(eqlt (quote ,e) (the ,type (quote ,e)))))))) + (funcall (compile nil lexpr))) + t) + +(deftest the.13 + (let ((x 0)) + (values + (the (or symbol integer) (incf x)) + x)) + 1 1) + +(deftest the.14 + (the (values &rest t) (values 'a 'b)) + a b) + +(deftest the.15 + (the (values &rest symbol) (values 'a 'b)) + a b) + +(deftest the.16 + (the (values &rest null) (values))) + +(deftest the.17 + (the (values symbol integer &rest null) (values 'a 1)) + a 1) + +(deftest the.18 + (the (values symbol integer &rest t) (values 'a 1 'foo '(x y))) + a 1 foo (x y)) + +(deftest the.19 + (let () (list (the (values) (eval '(values))))) + (nil)) + +;;; This is from SBCL bug 261 +#+(or) +(deftest the.20 + (let () (list (the (values &optional fixnum) (eval '(values))))) + (nil)) + +#+(or) +(deftest the.21 + (let () (list (the (values &rest t) (eval '(values))))) + (nil)) + +#+(or) +(deftest the.22 + (the (values symbol integer &rest t) (eval '(values 'a 1 'foo '(x y)))) + a 1 foo (x y)) + +#+(or) +(deftest the.23 + (multiple-value-list + (the (values symbol integer &optional fixnum) (eval '(values 'a 1)))) + (a 1)) + +;;; Test that explicit calls to macroexpand in subforms +;;; are done in the correct environment + +(deftest the.24 + (macrolet + ((%m (z) z)) + (the (integer 0 10) (expand-in-current-env (%m 4)))) + 4) + +(deftest the.25 + (macrolet + ((%m (z) z)) + (the (values t t) (expand-in-current-env (%m (values 1 2))))) + 1 2) diff --git a/test/ansi/type.lisp b/test/ansi/type.lisp new file mode 100644 index 0000000..856209a --- /dev/null +++ b/test/ansi/type.lisp @@ -0,0 +1,77 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun May 29 08:25:46 2005 +;;;; Contains: Tests of TYPE declarations + +(in-package #:cvm.test) + +(5am:def-suite type :in eval-and-compile) +(5am:in-suite type) + +;;; Also of implicit type declarations + +(deftest type.1 + (let ((x 1)) + (declare (type (integer 0 1) x)) + (values + x + (setq x 0) + (1+ x))) + 1 0 1) + +(deftest type.2 + (let ((x 1)) + (declare (type (integer -1 1) x)) + (locally (declare (type (integer 0 2) x)) + (values + x + (setq x 0) + (1+ x)))) + 1 0 1) + +#+(or) +(deftest type.3 + (loop for x in *mini-universe* + for tp = (type-of x) + for form = `(let ((y ',x)) + (declare (type ,tp y)) + y) + for val = (eval form) + unless (eql val x) + collect (list x tp form val)) + nil) + +#+(or) +(deftest type.4 + (loop for x in *mini-universe* + for tp = (type-of x) + for form = `(let ((y ',x)) + (declare (,tp y)) + y) + for val = (eval form) + unless (eql val x) + collect (list x tp form val)) + nil) + +#+(or) +(deftest type.5 + (loop for x in *mini-universe* + for class = (class-of x) + for form = `(let ((y ',x)) + (declare (,class y)) + y) + for val = (eval form) + unless (eql val x) + collect (list x class form val)) + nil) + +;;; Free TYPE declaration +;;; It should not apply to the occurence of X in the form +;;; whose value is being bound to Y. + +(deftest type.6 + (let ((x 2)) + (let ((y (+ (decf x) 2))) + (declare (type (integer 0 1) x)) + (values x y))) + 1 3) diff --git a/test/package.lisp b/test/package.lisp new file mode 100644 index 0000000..38319a6 --- /dev/null +++ b/test/package.lisp @@ -0,0 +1,4 @@ +(defpackage #:cvm.test + (:use #:cl) + (:shadow #:eval #:compile) + (:export #:run #:run!)) diff --git a/test/rt.lisp b/test/rt.lisp new file mode 100644 index 0000000..f403e1d --- /dev/null +++ b/test/rt.lisp @@ -0,0 +1,35 @@ +(in-package #:cvm.test) + +;;; Force true values to T. +(defun notnot (v) (not (not v))) + +;;; Macro used in tests of environments in system macros +;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP +;;; was being called in some system macros without the proper +;;; environment argument +(defmacro expand-in-current-env (macro-form &environment env) + (macroexpand macro-form env)) + +(defvar *environment*) +(defvar *client*) + +(defun eval (form) + (cvm.compile:eval form *environment* *client*)) + +(defun compile (name lambda-expression) + (declare (ignore name)) + (cvm.compile:compile lambda-expression *environment* *client*)) + +(defmacro is-true-eval (form) + `(5am:is-true (eval ',form))) + +(defmacro signals-eval (condition-type form) + `(5am:signals ,condition-type (eval ',form))) + +(defmacro deftest (name form &rest expected) + `(5am:test ,name + (5am:is (equal '(,@expected) (multiple-value-list (eval ',form)))))) + +(defun run (*environment* *client*) (5am:run 'cvm)) + +(defun run! (*environment* *client*) (5am:run! 'cvm)) diff --git a/test/suites.lisp b/test/suites.lisp new file mode 100644 index 0000000..562fb83 --- /dev/null +++ b/test/suites.lisp @@ -0,0 +1,6 @@ +(in-package #:cvm.test) + +(5am:def-suite cvm) + +(5am:def-suite eval-and-compile :in cvm) +(5am:def-suite data-and-control-flow :in cvm) From 226651c7b6e97114b294c6bd16d68fb3702cb32e Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 13:12:46 -0400 Subject: [PATCH 02/32] Use Ecclessia instead of trivial-cltl2 for parse-macro trivial-cltl2 will give us the native parse-macro, which could expand into gods know what. In particular on SBCL it uses a lot of POP and some internal SBCL functions, which can cause issues. --- cmpltv.lisp | 2 +- compile.lisp | 2 +- cvm.asd | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/cmpltv.lisp b/cmpltv.lisp index 1d2a2b2..9543060 100644 --- a/cmpltv.lisp +++ b/cmpltv.lisp @@ -1267,7 +1267,7 @@ (dolist (binding bindings) (let* ((name (car binding)) (lambda-list (cadr binding)) (body (cddr binding)) - (eform (trivial-cltl2:parse-macro name lambda-list body env)) + (eform (ecclesia:parse-macro name lambda-list body env)) (aenv (cmp:lexenv-for-macrolet env)) (expander (cmp:compile eform aenv)) (info (cmp:make-local-macro name expander))) diff --git a/compile.lisp b/compile.lisp index 4eb3777..7801c75 100644 --- a/compile.lisp +++ b/compile.lisp @@ -1214,7 +1214,7 @@ (loop with env = (lexenv-for-macrolet env) for (name lambda-list . body) in bindings for macro-lexpr - = (trivial-cltl2:parse-macro name lambda-list body) + = (ecclesia:parse-macro name lambda-list body env) for info = (make-local-macro name (compile macro-lexpr env)) collect (cons name info)))) (compile-locally body (make-lexical-environment diff --git a/cvm.asd b/cvm.asd index 8e5bcff..91400c0 100644 --- a/cvm.asd +++ b/cvm.asd @@ -6,7 +6,7 @@ :maintainer "Bike " :version "0.5.0" :depends-on (:closer-mop ; machine - :alexandria :trucler :trivial-cltl2 ; compiler + :alexandria :trucler :ecclesia ; compiler :ieee-floats) ; compile-file :components ((:file "machine") (:file "structures" :depends-on ("machine")) From cf242b66a26f49fba85442134203e19fb453afe3 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 13:21:26 -0400 Subject: [PATCH 03/32] Define Trucler query methods for our environments Important so that macros can actually use macroexpand. --- compile.lisp | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/compile.lisp b/compile.lisp index 7801c75..9e80fa6 100644 --- a/compile.lisp +++ b/compile.lisp @@ -492,6 +492,30 @@ ;;; environments are necessarily ours (they include bytecode-specific ;;; information, etc.) ;;; But we do fall back to it when we hit the global environment. +;;; And we define the methods, to be nice to macros, so maybe we +;;; should use it internally after all. +;;; TODO: Once trucler actually implements augmentation we should +;;; maybe use that and not have our own environments at all. + +(defmethod trucler:describe-variable + (client (env lexical-environment) name) + (or (cdr (assoc name (vars env))) + (trucler:describe-variable client + (global-environment env) name))) + +(defmethod trucler:describe-function + (client (env lexical-environment) name) + (or (cdr (assoc name (funs env))) + (trucler:describe-variable client + (global-environment env) name))) + +(defmethod trucler:describe-block + (client (env lexical-environment) name) + (cdr (assoc name (blocks env)))) + +(defmethod trucler:describe-tag + (client (env lexical-environment) name) + (cdr (assoc name (tags env)))) (defun var-info (name env) (or (cdr (assoc name (vars env))) From 7127b95d49e63e8301849f74f4fde650b204e369 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 13:35:51 -0400 Subject: [PATCH 04/32] define sham INCF for tests --- test/package.lisp | 2 +- test/rt.lisp | 38 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 37 insertions(+), 3 deletions(-) diff --git a/test/package.lisp b/test/package.lisp index 38319a6..f4b571f 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -1,4 +1,4 @@ (defpackage #:cvm.test (:use #:cl) - (:shadow #:eval #:compile) + (:shadow #:eval #:compile #:macroexpand-1 #:macroexpand #:incf) (:export #:run #:run!)) diff --git a/test/rt.lisp b/test/rt.lisp index f403e1d..9081be3 100644 --- a/test/rt.lisp +++ b/test/rt.lisp @@ -1,8 +1,36 @@ (in-package #:cvm.test) +(defvar *environment*) +(defvar *client*) + ;;; Force true values to T. (defun notnot (v) (not (not v))) +(defun macroexpand-1 (form &optional env) + (typecase form + (symbol + (let ((info (trucler:describe-variable *client* env form))) + (if (typep info 'trucler:symbol-macro-description) + (values (cvm.compile:symbol-macro-expansion info form env) t) + (values form nil)))) + (cons + (let* ((head (car form)) + (info (if (symbolp head) + (trucler:describe-function *client* env head) + nil))) + (if (typep info 'trucler:macro-description) + (values (cvm.compile:expand (trucler:expander info) form env) t) + (values form nil)))) + (t (values form nil)))) + +(defun macroexpand (form &optional env) + (loop with ever-expanded = nil + do (multiple-value-bind (expansion expandedp) + (macroexpand-1 form env) + (if expandedp + (setf ever-expanded t form expansion) + (return (values form ever-expanded)))))) + ;;; Macro used in tests of environments in system macros ;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP ;;; was being called in some system macros without the proper @@ -10,8 +38,14 @@ (defmacro expand-in-current-env (macro-form &environment env) (macroexpand macro-form env)) -(defvar *environment*) -(defvar *client*) +;;; Used extensively by the tests as a side effect, but not in +;;; any very complicated ways. +(defmacro incf (place &optional (delta 1) &environment env) + ;; FIXME: Check for symbol macros. + (if (symbolp place) + ;; (this part will be a problem if place is a symbol macro) + `(setq ,place (+ ,place ,delta)) + (error "Sham INCF not implemented for form: ~s" place))) (defun eval (form) (cvm.compile:eval form *environment* *client*)) From c47d1c747f9398004e6b13aeb5265d3e031bbfdc Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 13:59:28 -0400 Subject: [PATCH 05/32] Signal actual program-errors on lambda list problems --- vm.lisp | 68 +++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 57 insertions(+), 11 deletions(-) diff --git a/vm.lisp b/vm.lisp index 01783f8..1edc4c7 100644 --- a/vm.lisp +++ b/vm.lisp @@ -6,6 +6,48 @@ (in-package #:cvm.vm) +;;; nabbed from clasp +(define-condition wrong-number-of-arguments (program-error) + ((%called-function :initform nil :initarg :called-function + :reader called-function) + (%given-nargs :initarg :given-nargs :reader given-nargs) + (%min-nargs :initarg :min-nargs :reader min-nargs :initform nil) + (%max-nargs :initarg :max-nargs :reader max-nargs :initform nil)) + (:report (lambda (condition stream) + (let* ((min (min-nargs condition)) + (max (max-nargs condition)) + ;; FIXME: get an actual name if possible + (dname nil)) + (format stream "~@[Calling ~a - ~]Got ~d arguments, but expected ~@?" + dname (given-nargs condition) + (cond ((null max) "at least ~d") + ((null min) "at most ~*~d") + ;; I think "exactly 0" is better than "at most 0", thus duplication + ((= min max) "exactly ~d") + ((zerop min) "at most ~*~d") + (t "between ~d and ~d")) + min max))))) + +(define-condition odd-keywords (program-error) + ((%called-function :initarg :called-function :reader called-function + :initform nil)) + (:report (lambda (condition stream) + (format stream "Odd number of keyword arguments~:[~; for ~s~]." + (called-function condition) + ;; FIXME: again, get an actual name somehow. + nil)))) + +(define-condition unrecognized-keyword-argument (program-error) + ((%called-function :initarg :called-function :reader called-function + :initform nil) + (%unrecognized-keywords :initarg :unrecognized-keywords + :reader unrecognized-keywords)) + (:report (lambda (condition stream) + (format stream "Unrecognized keyword arguments ~S~:[~; for ~S~]." + (unrecognized-keywords condition) + (called-function condition) ; FIXME: name + nil)))) + (defstruct vm (values nil :type list) (stack #() :type simple-vector) @@ -221,20 +263,23 @@ ((#.m:check-arg-count-<=) (let ((n (next-code))) (unless (<= (vm-arg-count vm) n) - (error "Invalid number of arguments: Got ~d, need at most ~d." - (vm-arg-count vm) n))) + (error 'wrong-number-of-arguments + :given-nargs (vm-arg-count vm) + :max-nargs n))) (incf ip)) ((#.m:check-arg-count->=) (let ((n (next-code))) (unless (>= (vm-arg-count vm) n) - (error "Invalid number of arguments: Got ~d, need at least ~d." - (vm-arg-count vm) n))) + (error 'wrong-number-of-arguments + :given-nargs (vm-arg-count vm) + :min-nargs n))) (incf ip)) ((#.m:check-arg-count-=) (let ((n (next-code))) (unless (= (vm-arg-count vm) n) - (error "Invalid number of arguments: Got ~d, need exactly ~d." - (vm-arg-count vm) n))) + (error 'wrong-number-of-arguments + :given-nargs (vm-arg-count vm) + :min-nargs n :max-nargs n))) (incf ip)) ((#.m:jump-if-supplied-8) (incf ip (if (typep (stack (+ bp (next-code))) 'unbound-marker) @@ -292,7 +337,7 @@ (key-literal-start (next-code)) (key-literal-end (+ key-literal-start key-count)) (key-frame-start (+ bp (next-code))) - (unknown-key-p nil) + (unknown-keys nil) (allow-other-keys-p nil)) ;; Initialize all key values to # (loop for index from key-frame-start below (+ key-frame-start key-count) @@ -302,7 +347,7 @@ ((< arg-index more-start) (cond ((= arg-index (1- more-start))) ((= arg-index (- more-start 2)) - (error "Passed odd number of &KEY args!")) + (error 'odd-keywords)) (t (error "BUG! This can't happen!")))) (let ((key (stack (1- arg-index)))) @@ -315,11 +360,12 @@ do (when (eq (constant key-index) key) (setf (stack offset) (stack arg-index)) (return)) - finally (setf unknown-key-p key)))))) + finally (push key unknown-keys)))))) (when (and (not (or (logbitp 7 key-count-info) allow-other-keys-p)) - unknown-key-p) - (error "Unknown key arg ~a!" unknown-key-p))) + unknown-keys) + (error 'unrecognized-keyword-argument + :unrecognized-keywords unknown-keys))) (incf ip)) ((#.m:save-sp) (setf (stack (+ bp (next-code))) sp) From fc9f0e25c9f56c23d79d32468db3e5ec3dc1f326 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 14:08:06 -0400 Subject: [PATCH 06/32] Compile m-v-call w/o using etypecase macro --- compile.lisp | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/compile.lisp b/compile.lisp index 9e80fa6..1933803 100644 --- a/compile.lisp +++ b/compile.lisp @@ -1260,9 +1260,17 @@ (compile-form `(fdefinition ,form) env (new-context context :receiving 1))) (t (let* ((fsym (gensym "FUNCTION-DESIGNATOR")) - (form `(etypecase ,fsym - (function ,fsym) - (symbol (fdefinition ,fsym))))) + ;; Try to avoid using macros (etypecase) for the sake of + ;; compatibility with a native client. For example, SBCL's + ;; COND cannot be macroexpanded in our environments. + ;; TODO: Newer VM version makes this a VM operation. + (form `(let ((,fsym ,form)) + (if (functionp ,fsym) + ,fsym + (if (symbolp ,fsym) + (fdefinition ,fsym) + (error 'type-error :datum ,fsym + :expected-type '(or symbol function))))))) (compile-form form env (new-context context :receiving 1)))))) (defmethod compile-special ((op (eql 'multiple-value-call)) form env context) From f9979d900b740844009d81f90bdd841e76e72575 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 14:20:05 -0400 Subject: [PATCH 07/32] Allow docstrings in lambda expressions --- compile.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compile.lisp b/compile.lisp index 1933803..2017b44 100644 --- a/compile.lisp +++ b/compile.lisp @@ -1321,7 +1321,7 @@ ;;; corresponding suppliedp var for each optional/key. (defun compile-with-lambda-list (lambda-list body env context) (multiple-value-bind (body decls) - (alexandria:parse-body body) + (alexandria:parse-body body :documentation t) (multiple-value-bind (required optionals rest keys aok-p aux key-p) (alexandria:parse-ordinary-lambda-list lambda-list) (let* ((function (context-function context)) From e4c7d225be4e41ffe66dd1cd000fe1573dad524d Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 14:35:46 -0400 Subject: [PATCH 08/32] Fix lambda handling of special declarations --- compile.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compile.lisp b/compile.lisp index 2017b44..918f29c 100644 --- a/compile.lisp +++ b/compile.lisp @@ -1469,7 +1469,7 @@ ;; Generate aux and the body as a let*. ;; We repeat the special declarations so that let* will know the auxs ;; are special, and so that any free special declarations are processed. - (compile-let* aux `((special ,@specials)) body new-env context) + (compile-let* aux `((declare (special ,@specials))) body new-env context) (emit-unbind context special-binding-count))))) ;;; Compile an optional/key item and return the resulting environment From 6a1d3382ed1f86eadf5766bfbb92645660f64bad Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 14:43:38 -0400 Subject: [PATCH 09/32] Implicit blocks for LABELS functions --- compile.lisp | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/compile.lisp b/compile.lisp index 918f29c..a9e0262 100644 --- a/compile.lisp +++ b/compile.lisp @@ -921,10 +921,13 @@ (defmethod compile-special ((operator (eql 'flet)) form env context) (destructuring-bind (definitions . body) (rest form) (loop for (name lambda-list . body) in definitions - do (compile-lambda-expression - `(lambda ,lambda-list - (block ,(fun-name-block-name name) (locally ,@body))) - env context)) + do (multiple-value-bind (body decls) + (alexandria:parse-body body :documentation t) + (compile-lambda-expression + `(lambda ,lambda-list + ,@decls + (block ,(fun-name-block-name name) ,@body)) + env context))) (emit-bind context (length definitions) (context-frame-end context)) (multiple-value-call #'compile-locally body (bind-fvars (mapcar #'car definitions) env context)))) @@ -936,7 +939,13 @@ (let* ((module (context-module context)) (closures (loop for (name lambda-list . body) in definitions - for fun = (compile-lambda lambda-list body new-env + for bname = (fun-name-block-name name) + for rbody + = (multiple-value-bind (body decls) + (alexandria:parse-body body + :documentation t) + `(,@decls (block ,bname ,@body))) + for fun = (compile-lambda lambda-list rbody new-env module) for literal-index = (cfunction-literal-index fun context) if (zerop (length (cfunction-closed fun))) From 50ec6cffe1e47bdbafeefada96e402ecc39c2849 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 14:54:55 -0400 Subject: [PATCH 10/32] Correctly treat :allow-other-keys as a normal keyword argument For the truly perverse. --- vm.lisp | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/vm.lisp b/vm.lisp index 1edc4c7..e73c257 100644 --- a/vm.lisp +++ b/vm.lisp @@ -351,16 +351,19 @@ (t (error "BUG! This can't happen!")))) (let ((key (stack (1- arg-index)))) - (if (eq key :allow-other-keys) - (setf allow-other-keys-p (stack arg-index)) - (loop for key-index from key-literal-start - below key-literal-end - for offset of-type (unsigned-byte 16) - from key-frame-start - do (when (eq (constant key-index) key) - (setf (stack offset) (stack arg-index)) - (return)) - finally (push key unknown-keys)))))) + (when (eq key :allow-other-keys) + (setf allow-other-keys-p (stack arg-index))) + (loop for key-index from key-literal-start + below key-literal-end + for offset of-type (unsigned-byte 16) + from key-frame-start + do (when (eq (constant key-index) key) + (setf (stack offset) (stack arg-index)) + (return)) + finally (unless (or allow-other-keys-p + ;; aok is always allowed + (eq key :allow-other-keys)) + (push key unknown-keys)))))) (when (and (not (or (logbitp 7 key-count-info) allow-other-keys-p)) unknown-keys) From e1676786090f6323ad9f2f9f24c9fb58d57f1651 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 15:19:00 -0400 Subject: [PATCH 11/32] Fix add-specials Not sure exactly what was wrong with the DO* loop, but DO* is hard to understand anyway. It was adding special variables called NIL from normal free special declarations somehow, and some of the binding related ANSI tests got really screwy results. --- compile.lisp | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/compile.lisp b/compile.lisp index a9e0262..f94f996 100644 --- a/compile.lisp +++ b/compile.lisp @@ -821,23 +821,20 @@ ;;; Add VARS as specials in ENV. (defun add-specials (vars env) - (do* ((evars (vars env)) - (ivars vars (rest ivars)) - (new-vars - evars - (let* ((var (first ivars)) - (desc (trucler:describe-variable m:*client* env var)) - (specialp (typep desc 'trucler:special-variable-description))) - (if specialp - new-vars ; already present - (acons var (make-instance - 'trucler:local-special-variable-description - :name var) - new-vars))))) - ((endp ivars) - (if (eq new-vars evars) ; nothing added - env - (make-lexical-environment env :vars new-vars))))) + (let* ((existing (vars env)) + (new-vars existing)) + (loop for var in vars + for desc = (trucler:describe-variable m:*client* env var) + for specialp + = (typep desc 'trucler:special-variable-description) + unless specialp ; already covered + do (push (cons var (make-instance + 'trucler:local-special-variable-description + :name var)) + new-vars)) + (if (eq new-vars existing) ; nothing added + env + (make-lexical-environment env :vars new-vars)))) (defun extract-specials (declarations) (let ((specials '())) From e872a95cd6858c9c3504b29d383e7a4b562b1e1e Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 16:58:41 -0400 Subject: [PATCH 12/32] Fix most of the stupid test failures for native See extensive comment in native-sham --- cvm.asd | 9 +- test/ansi/block.lisp | 2 +- test/ansi/compile.lisp | 12 +-- test/ansi/dynamic-extent.lisp | 6 +- test/ansi/eval-when.lisp | 4 +- test/ansi/eval.lisp | 10 +-- test/ansi/flet.lisp | 15 ++-- test/ansi/if.lisp | 14 +-- test/ansi/ignorable.lisp | 12 +-- test/ansi/ignore.lisp | 4 +- test/ansi/labels.lisp | 13 ++- test/ansi/lambda.lisp | 66 +++++++-------- test/ansi/let.lisp | 8 +- test/ansi/letstar.lisp | 12 +-- test/ansi/locally.lisp | 2 +- test/ansi/macrolet.lisp | 40 ++++----- test/ansi/multiple-value-call.lisp | 4 +- test/ansi/multiple-value-prog1.lisp | 16 ++-- test/ansi/optimize.lisp | 4 +- test/ansi/progn.lisp | 8 +- test/ansi/return-from.lisp | 2 +- test/ansi/symbol-macrolet.lisp | 2 +- test/ansi/tagbody.lisp | 4 +- test/ansi/the.lisp | 7 +- test/ansi/type.lisp | 2 +- test/native-sham.lisp | 127 ++++++++++++++++++++++++++++ test/package.lisp | 4 - test/packages.lisp | 14 +++ test/rt.lisp | 64 +++----------- 29 files changed, 293 insertions(+), 194 deletions(-) create mode 100644 test/native-sham.lisp delete mode 100644 test/package.lisp create mode 100644 test/packages.lisp diff --git a/cvm.asd b/cvm.asd index 91400c0..538c114 100644 --- a/cvm.asd +++ b/cvm.asd @@ -21,11 +21,12 @@ :depends-on (:cvm :fiveam) :components ((:module "test" - :components ((:file "package") - (:file "suites" :depends-on ("package")) - (:file "rt" :depends-on ("package")) + :components ((:file "packages") + (:file "suites" :depends-on ("packages")) + (:file "rt" :depends-on ("packages")) + (:file "native-sham" :depends-on ("packages")) (:module "ansi" - :depends-on ("suites" "rt" "package") + :depends-on ("suites" "rt" "packages") ;; These can be loaded in any order. :components (;; eval-and-compile (:file "compile") diff --git a/test/ansi/block.lisp b/test/ansi/block.lisp index c1d63c6..3960f7b 100644 --- a/test/ansi/block.lisp +++ b/test/ansi/block.lisp @@ -83,7 +83,7 @@ (deftest block.12 (macrolet ((%m (z) z)) - (block foo (expand-in-current-env (%m :good)))) + (block foo (s:expand-in-current-env (%m :good)))) :good) #| diff --git a/test/ansi/compile.lisp b/test/ansi/compile.lisp index 1284c90..c437c93 100644 --- a/test/ansi/compile.lisp +++ b/test/ansi/compile.lisp @@ -48,31 +48,31 @@ (5am:is-false (let ((x (list 'a 'b)) (y (list 'a 'b))) - (funcall (compile nil `(lambda () (eq ',x ',y))))))) + (funcall (ccompile nil `(lambda () (eq ',x ',y))))))) (5am:test compile.4 (5am:is-false (let ((x (copy-seq "abc")) (y (copy-seq "abc"))) - (funcall (compile nil `(lambda () (eq ,x ,y))))))) + (funcall (ccompile nil `(lambda () (eq ,x ,y))))))) (5am:test compile.5 (5am:is-true (let ((x (copy-seq "abc"))) - (funcall (compile nil `(lambda () (eq ,x ,x))))))) + (funcall (ccompile nil `(lambda () (eq ,x ,x))))))) (5am:test compile.6 (5am:is-true (let ((x (copy-seq "abc"))) - (funcall (compile nil `(lambda () (eq ',x ',x))))))) + (funcall (ccompile nil `(lambda () (eq ',x ',x))))))) (5am:test compile.7 (let ((x (copy-seq "abc"))) - (5am:is (eq x (funcall (compile nil `(lambda () ,x))))))) + (5am:is (eq x (funcall (ccompile nil `(lambda () ,x))))))) (5am:test compile.8 (let ((x (list 'a 'b))) - (5am:is (eq x (funcall (compile nil `(lambda () ',x))))))) + (5am:is (eq x (funcall (ccompile nil `(lambda () ',x))))))) #+(or) (deftest compile.9 diff --git a/test/ansi/dynamic-extent.lisp b/test/ansi/dynamic-extent.lisp index c67382a..48b2e86 100644 --- a/test/ansi/dynamic-extent.lisp +++ b/test/ansi/dynamic-extent.lisp @@ -101,7 +101,7 @@ (declare (notinline coerce)) (declare (optimize speed (safety 0))) (equal (coerce a 'list) ',contents)) - unless (eval form2) + unless (ceval form2) collect i))) nil) @@ -119,13 +119,13 @@ (every #'(lambda (c) (eql c #\a)) s)))) (deftest dynamic-extent.15 - (flet (((setf %f) (x y) (setf (car y) x))) + (flet (((setf %f) (x y) (s:setf (car y) x))) (declare (dynamic-extent #'(setf %f))) :good) :good) (deftest dynamic-extent.16 - (labels (((setf %f) (x y) (setf (car y) x))) + (labels (((setf %f) (x y) (s:setf (car y) x))) (declare (dynamic-extent #'(setf %f))) :good) :good) diff --git a/test/ansi/eval-when.lisp b/test/ansi/eval-when.lisp index 4a654d1..bc1fd10 100644 --- a/test/ansi/eval-when.lisp +++ b/test/ansi/eval-when.lisp @@ -135,12 +135,12 @@ (deftest eval-when.17 (let ((x :bad)) - (values (eval-when (eval) (setq x :good)) x)) + (values (eval-when (cl:eval) (setq x :good)) x)) :good :good) ;;; Macros are expanded in the appropriate environment (deftest eval-when.18 (macrolet ((%m (z) z)) - (eval-when (:execute) (expand-in-current-env (%m :good)))) + (eval-when (:execute) (s:expand-in-current-env (%m :good)))) :good) diff --git a/test/ansi/eval.lisp b/test/ansi/eval.lisp index c954343..3984a0d 100644 --- a/test/ansi/eval.lisp +++ b/test/ansi/eval.lisp @@ -20,7 +20,7 @@ (5am:test eval.3 (5am:is-true (let ((s "abcd")) - (eql (eval s) s)))) + (eql (ceval s) s)))) #+(or) (deftest eval.4 @@ -32,7 +32,7 @@ 0) (5am:test eval.6 - (5am:is (eql 1 (funcall #'eval 1)))) + (5am:is (eql 1 (funcall #'ceval 1)))) #+(or) (deftest eval.order.1 @@ -43,7 +43,7 @@ ;;; Error cases (5am:test eval.error.1 - (5am:signals program-error (eval))) + (5am:signals program-error (ceval))) #+(or) (deftest eval.error.2 @@ -51,7 +51,7 @@ t) (5am:test eval.error.3 - (5am:signals undefined-function (eval (list (gensym))))) + (5am:signals undefined-function (ceval (list (gensym))))) (5am:test eval.error.4 - (5am:signals unbound-variable (eval (gensym)))) + (5am:signals unbound-variable (ceval (gensym)))) diff --git a/test/ansi/flet.lisp b/test/ansi/flet.lisp index cf4badd..8468096 100644 --- a/test/ansi/flet.lisp +++ b/test/ansi/flet.lisp @@ -60,8 +60,7 @@ ;;; The function is not visible inside itself (deftest flet.7 (flet ((%f (x) (+ x 5))) - (flet ((%f (y) (cond ((eql y 20) 30) - (t (%f 20))))) + (flet ((%f (y) (if (eql y 20) 30 (%f 20)))) (%f 15))) 25) @@ -116,15 +115,15 @@ ;;; Definition of a (setf ...) function (deftest flet.17 - (flet (((setf %f) (x y) (setf (car y) x))) + (flet (((setf %f) (x y) (s:setf (car y) x))) (let ((z (list 1 2))) - (setf (%f z) 'a) + (s:setf (%f z) 'a) z)) (a 2)) ;;; Body is an implicit progn (deftest flet.18 - (flet ((%f (x) (incf x) (+ x x))) + (flet ((%f (x) (s:incf x) (+ x x))) (%f 10)) 22) @@ -540,7 +539,7 @@ (flet ((%f (i) #'(lambda (arg) (declare (ignore arg)) - (incf *x* i)))) + (s:incf *x* i)))) (values (mapcar (%f 1) '(a b c)) (mapcar (%f 2) '(a b c))))) @@ -551,12 +550,12 @@ (deftest flet.70 (macrolet ((%m (z) z)) - (flet () (expand-in-current-env (%m :good)))) + (flet () (s:expand-in-current-env (%m :good)))) :good) (deftest flet.71 (macrolet ((%m (z) z)) - (flet ((%f () (expand-in-current-env (%m :good)))) + (flet ((%f () (s:expand-in-current-env (%m :good)))) (%f))) :good) diff --git a/test/ansi/if.lisp b/test/ansi/if.lisp index c4ead9b..8e51356 100644 --- a/test/ansi/if.lisp +++ b/test/ansi/if.lisp @@ -36,28 +36,28 @@ (deftest if.8 (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m t)) :good :bad)) + (if (s:expand-in-current-env (%m t)) :good :bad)) :good) (deftest if.9 (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m nil)) :bad)) + (if (s:expand-in-current-env (%m nil)) :bad)) nil) (deftest if.10 (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m t)) :good)) + (if (s:expand-in-current-env (%m t)) :good)) :good) (deftest if.11 (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m nil)) :bad :good)) + (if (s:expand-in-current-env (%m nil)) :bad :good)) :good) (deftest if.12 (macrolet ((%m (z) z)) - (flet ((%f (x y) (if x (expand-in-current-env (%m y))))) + (flet ((%f (x y) (if x (s:expand-in-current-env (%m y))))) (declare (notinline %f)) (values (%f t :good) (%f nil :bad)))) :good nil) @@ -65,12 +65,12 @@ (deftest if.13 (macrolet ((%m (z) z)) - (flet ((%f (x y z) (if x y (expand-in-current-env (%m z))))) + (flet ((%f (x y z) (if x y (s:expand-in-current-env (%m z))))) (declare (notinline %f)) (values (%f t :good :bad) (%f nil :bad :good)))) :good :good) (deftest if.order.1 (let ((i 0)) - (values (if (= (incf i) 1) 't nil) i)) + (values (if (= (s:incf i) 1) 't nil) i)) t 1) diff --git a/test/ansi/ignorable.lisp b/test/ansi/ignorable.lisp index fa587eb..a1e29e8 100644 --- a/test/ansi/ignorable.lisp +++ b/test/ansi/ignorable.lisp @@ -36,21 +36,21 @@ :good) (deftest ignorable.6 - (flet (((setf %f) (x y) (setf (car y) x))) + (flet (((setf %f) (x y) (s:setf (car y) x))) (declare (ignorable (function (setf %f)))) (let ((z (cons 'a 'b))) - (values (setf (%f z) 'c) z))) + (values (s:setf (%f z) 'c) z))) c (c . b)) (deftest ignorable.7 (labels (((setf %f) (x y) nil)) - (declare (ignorable (function (setf %f)))) - :good) + (declare (ignorable (function (setf %f)))) + :good) :good) (deftest ignorable.8 - (labels (((setf %f) (x y) (setf (car y) x))) + (labels (((setf %f) (x y) (s:setf (car y) x))) (declare (ignorable (function (setf %f)))) (let ((z (cons 'a 'b))) - (values (setf (%f z) 'c) z))) + (values (s:setf (%f z) 'c) z))) c (c . b)) diff --git a/test/ansi/ignore.lisp b/test/ansi/ignore.lisp index bd86dce..4de2049 100644 --- a/test/ansi/ignore.lisp +++ b/test/ansi/ignore.lisp @@ -28,13 +28,13 @@ foo) (deftest ignore.5 - (flet (((setf %f) (x y) (setf (car y) x))) + (flet (((setf %f) (x y) (s:setf (car y) x))) (declare (ignore (function (setf %f)))) :good) :good) (deftest ignore.6 - (labels (((setf %f) (x y) (setf (car y) x))) + (labels (((setf %f) (x y) (s:setf (car y) x))) (declare (ignore (function (setf %f)))) :good) :good) diff --git a/test/ansi/labels.lisp b/test/ansi/labels.lisp index e3a9488..1b76105 100644 --- a/test/ansi/labels.lisp +++ b/test/ansi/labels.lisp @@ -61,8 +61,7 @@ ;;; The function is visible inside itself (deftest labels.7 - (labels ((%f (x n) (cond ((eql n 0) x) - (t (%f (+ x n) (1- n)))))) + (labels ((%f (x n) (if (eql n 0) x (%f (+ x n) (1- n))))) (%f 0 10)) 55) @@ -143,15 +142,15 @@ ;;; Definition of a (setf ...) function (deftest labels.17 - (labels (((setf %f) (x y) (setf (car y) x))) + (labels (((setf %f) (x y) (s:setf (car y) x))) (let ((z (list 1 2))) - (setf (%f z) 'a) + (s:setf (%f z) 'a) z)) (a 2)) ;;; Body is an implicit progn (deftest labels.18 - (labels ((%f (x) (incf x) (+ x x))) + (labels ((%f (x) (s:incf x) (+ x x))) (%f 10)) 22) @@ -395,12 +394,12 @@ (deftest labels.48 (macrolet ((%m (z) z)) - (labels () (expand-in-current-env (%m :good)))) + (labels () (s:expand-in-current-env (%m :good)))) :good) (deftest labels.49 (macrolet ((%m (z) z)) - (labels ((%f () (expand-in-current-env (%m :good)))) + (labels ((%f () (s:expand-in-current-env (%m :good)))) (%f))) :good) diff --git a/test/ansi/lambda.lisp b/test/ansi/lambda.lisp index c285a0d..74ad817 100644 --- a/test/ansi/lambda.lisp +++ b/test/ansi/lambda.lisp @@ -58,7 +58,7 @@ (deftest lambda.13 ((lambda (&optional (x 'a x-p) (y 'b y-p) (z 'c z-p)) - (list* x y z (mapcar #'notnot (list x-p y-p z-p)))) 1 nil) + (list* x y z (mapcar #'s:notnot (list x-p y-p z-p)))) 1 nil) (1 nil c t t nil)) (deftest lambda.14 @@ -94,7 +94,7 @@ (10 11)) (deftest lambda.21 - (flet ((%f () (locally (declare (special *x*)) (incf *x*)))) + (flet ((%f () (locally (declare (special *x*)) (s:incf *x*)))) ((lambda (*x*) (declare (special *x*)) (%f) @@ -156,23 +156,23 @@ (:w 5 :allow-other-keys t :x 10)) (deftest lambda.34 - ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) + ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (s:notnot a-p) + b (s:notnot b-p) + c (s:notnot c-p))) :c 5 :a 0) (0 t 2 nil 5 t)) (deftest lambda.35 - ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) + ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (s:notnot a-p) + b (s:notnot b-p) + c (s:notnot c-p))) :c 5 :a nil :a 17 :c 100) (nil t 2 nil 5 t)) (deftest lambda.36 - ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) + ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (s:notnot a-p) + b (s:notnot b-p) + c (s:notnot c-p))) :c 5 :a 0 :allow-other-keys t 'b 100) (0 t 2 nil 5 t)) @@ -189,20 +189,20 @@ (deftest lambda.39 (let ((a-p :bad)) (declare (ignorable a-p)) - ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))))) + ((lambda (&key (a nil a-p) (b a-p)) (list a (s:notnot a-p) (s:notnot b))))) (nil nil nil)) (deftest lambda.40 (let ((a-p :bad)) (declare (ignorable a-p)) - ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) + ((lambda (&key (a nil a-p) (b a-p)) (list a (s:notnot a-p) (s:notnot b))) :a 1)) (1 t t)) (deftest lambda.41 (let ((a-p :bad)) (declare (ignorable a-p)) - ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) + ((lambda (&key (a nil a-p) (b a-p)) (list a (s:notnot a-p) (s:notnot b))) :a nil)) (nil t t)) @@ -279,25 +279,23 @@ ((lambda (&aux (y x)) (declare (special x)) y)))) :good) -(deftest lambda.55 - (let* ((doc "LMB55") - (fn (eval `#'(lambda () ,doc nil))) - (cfn (compile nil fn))) - (values - (or (documentation fn t) doc) - (or (documentation cfn t) doc))) - "LMB55" - "LMB55") - -(deftest lambda.56 - (let* ((doc "LMB56") - (fn (eval `#'(lambda () ,doc nil))) - (cfn (compile nil fn))) - (values - (or (documentation fn 'function) doc) - (or (documentation cfn 'function) doc))) - "LMB56" - "LMB56") +(5am:test lambda.55 + (5am:is (equal '("LMB55" "LMB55") + (let* ((doc "LMB55") + (fn (ceval `#'(lambda () ,doc nil))) + (cfn (ccompile nil fn))) + (list + (or (documentation fn t) doc) + (or (documentation cfn t) doc)))))) + +(5am:test lambda.56 + (5am:is (equal '("LMB56" "LMB56") + (let* ((doc "LMB56") + (fn (ceval `#'(lambda () ,doc nil))) + (cfn (ccompile nil fn))) + (list + (or (documentation fn 'function) doc) + (or (documentation cfn 'function) doc)))))) ;;; Uninterned symbols as lambda variables @@ -353,7 +351,7 @@ #+(or) (deftest lambda.macro.1 - (notnot (macro-function 'lambda)) + (s:notnot (macro-function 'lambda)) t) #+(or) diff --git a/test/ansi/let.lisp b/test/ansi/let.lisp index 587a78c..6ce7f57 100644 --- a/test/ansi/let.lisp +++ b/test/ansi/let.lisp @@ -100,7 +100,7 @@ (dolist (v vars) (setq sumexpr `(+ ,v ,sumexpr))) sumexpr))) - (val (eval expr))) + (val (ceval expr))) (5am:is (eql (/ (* n (1+ n)) 2) val)))) ;;; Test that all non-variables exported from COMMON-LISP can be bound @@ -135,7 +135,7 @@ (5am:test let.17a (5am:is (eql :good (funcall - (compile + (ccompile nil '(lambda () (let ((x :bad)) @@ -164,10 +164,10 @@ (deftest let.20 (macrolet ((%m (z) z)) - (let () (expand-in-current-env (%m :good)))) + (let () (s:expand-in-current-env (%m :good)))) :good) (deftest let.21 (macrolet ((%m (z) z)) - (let ((x (expand-in-current-env (%m 1)))) (+ x x x))) + (let ((x (s:expand-in-current-env (%m 1)))) (+ x x x))) 3) diff --git a/test/ansi/letstar.lisp b/test/ansi/letstar.lisp index 71f0fef..6ac5708 100644 --- a/test/ansi/letstar.lisp +++ b/test/ansi/letstar.lisp @@ -92,7 +92,7 @@ (dolist (v vars) (setq sumexpr `(+ ,v ,sumexpr))) sumexpr))) - (val (eval expr))) + (val (ceval expr))) (5am:is (eql (/ (* n (1+ n)) 2) val)))) ;;; Test that all non-variables exported from COMMON-LISP can be bound @@ -127,7 +127,7 @@ (5am:test let*.17a (5am:is (eql :good (funcall - (compile + (ccompile nil '(lambda () (let ((x :bad)) @@ -169,17 +169,17 @@ (deftest let*.21 (macrolet ((%m (z) z)) - (let* () (expand-in-current-env (%m :good)))) + (let* () (s:expand-in-current-env (%m :good)))) :good) (deftest let*.22 (macrolet ((%m (z) z)) - (let* ((x (expand-in-current-env (%m 1)))) (+ x x x))) + (let* ((x (s:expand-in-current-env (%m 1)))) (+ x x x))) 3) (deftest let*.23 (macrolet ((%m (z) z)) - (let* ((x (expand-in-current-env (%m 1))) - (y (expand-in-current-env (%m 2)))) + (let* ((x (s:expand-in-current-env (%m 1))) + (y (s:expand-in-current-env (%m 2)))) (+ x y))) 3) diff --git a/test/ansi/locally.lisp b/test/ansi/locally.lisp index 7dd80c5..b045520 100644 --- a/test/ansi/locally.lisp +++ b/test/ansi/locally.lisp @@ -45,5 +45,5 @@ (deftest locally.8 (macrolet ((%m (z) z)) - (locally (expand-in-current-env (%m :good)))) + (locally (s:expand-in-current-env (%m :good)))) :good) diff --git a/test/ansi/macrolet.lisp b/test/ansi/macrolet.lisp index ef53ced..2b05ae3 100644 --- a/test/ansi/macrolet.lisp +++ b/test/ansi/macrolet.lisp @@ -20,8 +20,8 @@ (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) (values - (setf (%m y) 6) - (setf (%m z) 'a) + (s:setf (%m y) 6) + (s:setf (%m z) 'a) y z)))) 6 a (6 2) (a 4)) @@ -33,8 +33,8 @@ (let ((y (list 1 2))) (values (%m y) (%m z) - (setf (%m y) 6) - (setf (%m z) 'a) + (s:setf (%m y) 6) + (s:setf (%m z) 'a) y z))))) 1 3 6 a (6 2) (a 4)) @@ -125,7 +125,7 @@ (deftest macrolet.13 (symbol-macrolet ((a b)) (macrolet ((foo (x &environment env) - (let ((y (macroexpand x env))) + (let ((y (s:macroexpand x env))) (if (eq y 'a) 1 2)))) (foo a))) 2) @@ -133,7 +133,7 @@ (deftest macrolet.14 (symbol-macrolet ((a b)) (macrolet ((foo (x &environment env) - (let ((y (macroexpand-1 x env))) + (let ((y (s:macroexpand-1 x env))) (if (eq y 'a) 1 2)))) (foo a))) 2) @@ -362,7 +362,7 @@ (deftest macrolet.38 (macrolet ((foo () 1)) - (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env) + (macrolet ((%f (&optional (x (s:macroexpand '(foo) env)) &environment env) x)) (%f))) 1) @@ -397,36 +397,36 @@ (declare (special *x-in-macrolet.43*)) (let ((*f* #'(lambda () *x-in-macrolet.43*))) (declare (special *f*)) - (5am:is-false (eval `(macrolet ((%m (*x-in-macrolet.43*) - (declare (special *f*)) - (funcall *f*))) - (%m t))))))) + (5am:is-false (ceval `(macrolet ((%m (*x-in-macrolet.43*) + (declare (special *f*)) + (funcall *f*))) + (%m t))))))) (5am:test macrolet.44 (let ((*x-in-macrolet.44* nil)) (declare (special *x-in-macrolet.44*)) (let ((*f* #'(lambda () *x-in-macrolet.44*))) (declare (special *f*)) - (5am:is (eql t (eval `(macrolet ((%m (*x-in-macrolet.44*) - (declare (special *f* *x-in-macrolet.44*)) - (funcall *f*))) - (%m t)))))))) + (5am:is (eql t (ceval `(macrolet ((%m (*x-in-macrolet.44*) + (declare (special *f* *x-in-macrolet.44*)) + (funcall *f*))) + (%m t)))))))) (5am:test macrolet.45 (let ((*x-in-macrolet.45* nil)) (declare (special *x-in-macrolet.45*)) (let ((*f* #'(lambda () *x-in-macrolet.45*))) (declare (special *f*)) - (5am:is (eql t (eval `(macrolet ((%m ((*x-in-macrolet.45*)) - (declare (special *f* *x-in-macrolet.45*)) - (funcall *f*))) - (%m (t))))))))) + (5am:is (eql t (ceval `(macrolet ((%m ((*x-in-macrolet.45*)) + (declare (special *f* *x-in-macrolet.45*)) + (funcall *f*))) + (%m (t))))))))) ;;; Macros are expanded in the appropriate environment (deftest macrolet.46 (macrolet ((%m (z) z)) - (macrolet () (expand-in-current-env (%m :good)))) + (macrolet () (s:expand-in-current-env (%m :good)))) :good) ;;; Free declarations in macrolet diff --git a/test/ansi/multiple-value-call.lisp b/test/ansi/multiple-value-call.lisp index b37d85c..ea3606d 100644 --- a/test/ansi/multiple-value-call.lisp +++ b/test/ansi/multiple-value-call.lisp @@ -25,11 +25,11 @@ (deftest multiple-value-call.4 (macrolet ((%m (z) z)) - (multiple-value-call (expand-in-current-env (%m #'list)) (values 1 2))) + (multiple-value-call (s:expand-in-current-env (%m #'list)) (values 1 2))) (1 2)) (deftest multiple-value-call.5 (macrolet ((%m (z) z)) - (multiple-value-call 'list (expand-in-current-env (%m (values 1 2))))) + (multiple-value-call 'list (s:expand-in-current-env (%m (values 1 2))))) (1 2)) diff --git a/test/ansi/multiple-value-prog1.lisp b/test/ansi/multiple-value-prog1.lisp index 8306760..67e1fb0 100644 --- a/test/ansi/multiple-value-prog1.lisp +++ b/test/ansi/multiple-value-prog1.lisp @@ -26,7 +26,7 @@ (deftest multiple-value-prog1.5 (let ((x 0) (y 0)) (multiple-value-prog1 (values x y) - (incf x) (incf y 2))) + (s:incf x) (s:incf y 2))) 0 0) (deftest multiple-value-prog1.6 @@ -34,7 +34,7 @@ (multiple-value-call #'list (multiple-value-prog1 (values x y) - (incf x) (incf y 2)) + (s:incf x) (s:incf y 2)) x y)) (0 0 1 2)) @@ -42,9 +42,9 @@ (let ((x 0) (y 0)) (multiple-value-call #'list - (multiple-value-prog1 (values (incf x) y) - (incf x x) - (incf y 10)) + (multiple-value-prog1 (values (s:incf x) y) + (s:incf x x) + (s:incf y 10)) x y)) (1 0 2 10)) @@ -68,7 +68,7 @@ (values (block foo (multiple-value-prog1 - (values (incf x) (incf y 2)) + (values (s:incf x) (s:incf y 2)) (return-from foo 'a))) x y)) a 1 2) @@ -91,11 +91,11 @@ (deftest multiple-value-prog1.11 (macrolet ((%m (z) z)) - (multiple-value-prog1 (expand-in-current-env (%m :good)))) + (multiple-value-prog1 (s:expand-in-current-env (%m :good)))) :good) (deftest multiple-value-prog1.12 (macrolet ((%m (z) z)) - (multiple-value-prog1 :good (expand-in-current-env (%m :foo)))) + (multiple-value-prog1 :good (s:expand-in-current-env (%m :foo)))) :good) diff --git a/test/ansi/optimize.lisp b/test/ansi/optimize.lisp index c8dfdb6..8660079 100644 --- a/test/ansi/optimize.lisp +++ b/test/ansi/optimize.lisp @@ -37,7 +37,7 @@ (loop for d in '(speed space safety debug compilation-speed) nconc (loop for n from 0 to 3 for form = `(locally (declare (optimize (,d ,n))) t) - for val = (eval form) + for val = (ceval form) unless (eql val t) collect (list d n val))))) @@ -48,7 +48,7 @@ for form = `(lambda () (declare (optimize (,d ,n))) t) - for val = (funcall (compile nil form)) + for val = (funcall (ccompile nil form)) unless (eql val t) collect (list d n val))))) diff --git a/test/ansi/progn.lisp b/test/ansi/progn.lisp index 3cba850..1438e74 100644 --- a/test/ansi/progn.lisp +++ b/test/ansi/progn.lisp @@ -22,7 +22,7 @@ (deftest progn.4 (let ((x 0)) - (values (progn (incf x) x) x)) + (values (progn (s:incf x) x) x)) 1 1) (deftest progn.5 (progn (values))) @@ -57,14 +57,14 @@ (deftest progn.9 (macrolet ((%m (z) z)) - (progn (expand-in-current-env (%m :good)))) + (progn (s:expand-in-current-env (%m :good)))) :good) (deftest progn.10 (macrolet ((%m (z) z)) - (progn (expand-in-current-env (%m :bad)) - (expand-in-current-env (%m :good)))) + (progn (s:expand-in-current-env (%m :bad)) + (s:expand-in-current-env (%m :good)))) :good) diff --git a/test/ansi/return-from.lisp b/test/ansi/return-from.lisp index cf325d0..71ff5ef 100644 --- a/test/ansi/return-from.lisp +++ b/test/ansi/return-from.lisp @@ -23,5 +23,5 @@ (deftest return-from.3 (macrolet ((%m (z) z)) - (block foo (return-from foo (expand-in-current-env (%m :good))))) + (block foo (return-from foo (s:expand-in-current-env (%m :good))))) :good) diff --git a/test/ansi/symbol-macrolet.lisp b/test/ansi/symbol-macrolet.lisp index 92b51f0..126fd35 100644 --- a/test/ansi/symbol-macrolet.lisp +++ b/test/ansi/symbol-macrolet.lisp @@ -85,5 +85,5 @@ (deftest symbol-macrolet.9 (macrolet ((%m (z) z)) - (symbol-macrolet () (expand-in-current-env (%m :good)))) + (symbol-macrolet () (s:expand-in-current-env (%m :good)))) :good) diff --git a/test/ansi/tagbody.lisp b/test/ansi/tagbody.lisp index 17cf002..30db45d 100644 --- a/test/ansi/tagbody.lisp +++ b/test/ansi/tagbody.lisp @@ -159,7 +159,7 @@ (return-from done 'good) around (go ,t2))))) - (5am:is (eql 'good (eval form))))) + (5am:is (eql 'good (ceval form))))) ;;; Check that macros are not expanded before finding tags ;;; Test for issue TAGBODY-TAG-EXPANSION @@ -183,5 +183,5 @@ (deftest tagbody.18 (macrolet ((%m (z) z)) (tagbody - (expand-in-current-env (%m :foo)))) + (s:expand-in-current-env (%m :foo)))) nil) diff --git a/test/ansi/the.lisp b/test/ansi/the.lisp index d2b84e4..beff2b6 100644 --- a/test/ansi/the.lisp +++ b/test/ansi/the.lisp @@ -94,7 +94,7 @@ (deftest the.13 (let ((x 0)) (values - (the (or symbol integer) (incf x)) + (the (or symbol integer) (s:incf x)) x)) 1 1) @@ -117,6 +117,7 @@ (the (values symbol integer &rest t) (values 'a 1 'foo '(x y))) a 1 foo (x y)) +#+(or) (deftest the.19 (let () (list (the (values) (eval '(values))))) (nil)) @@ -149,11 +150,11 @@ (deftest the.24 (macrolet ((%m (z) z)) - (the (integer 0 10) (expand-in-current-env (%m 4)))) + (the (integer 0 10) (s:expand-in-current-env (%m 4)))) 4) (deftest the.25 (macrolet ((%m (z) z)) - (the (values t t) (expand-in-current-env (%m (values 1 2))))) + (the (values t t) (s:expand-in-current-env (%m (values 1 2))))) 1 2) diff --git a/test/ansi/type.lisp b/test/ansi/type.lisp index 856209a..cba79f3 100644 --- a/test/ansi/type.lisp +++ b/test/ansi/type.lisp @@ -71,7 +71,7 @@ (deftest type.6 (let ((x 2)) - (let ((y (+ (decf x) 2))) + (let ((y (+ (s:decf x) 2))) (declare (type (integer 0 1) x)) (values x y))) 1 3) diff --git a/test/native-sham.lisp b/test/native-sham.lisp new file mode 100644 index 0000000..6665b98 --- /dev/null +++ b/test/native-sham.lisp @@ -0,0 +1,127 @@ +(in-package #:cvm.test) + +;;;; KLUDGE TIME +;;;; In an ideal world, all Lisp implementations would support +;;;; first-class environments, and their MACROEXPAND(-1) +;;;; implementations would go through a common interface like Trucler +;;;; so that they could be used with custom environments like ours. +;;;; In our world, none of them do this. This means that any macro +;;;; that calls MACROEXPAND(-1) will very likely throw a fit if +;;;; our compiler expands it. Sometimes it's worse - in SBCL, +;;;; seemingly innocuous macros like COND and UNLESS try to grab an +;;;; internal policy object from their environment, so we can't even +;;;; use those. +;;;; In this file we define some sham operators that work with the +;;;; VM compiler's environments properly. These are used in the tests +;;;; rather than the standard operators. +;;;; VERY IMPORTANTLY, these sham operators must ONLY used in code that +;;;; is fed to the VM compiler - not code for the host. This is in +;;;; preparation for that ideal world, in which the environment +;;;; these tests are run in is minimally defined to include only the +;;;; standard special operators, these few macros, and a short list of +;;;; functions to be catalogued. + +;;; Force true values to T. +(defun s:notnot (v) (not (not v))) + +(defun s:macroexpand-1 (form &optional env) + (typecase form + (symbol + (let ((info (trucler:describe-variable *client* env form))) + (if (typep info 'trucler:symbol-macro-description) + (values (cvm.compile:symbol-macro-expansion info form env) t) + (values form nil)))) + (cons + (let* ((head (car form)) + (info (if (symbolp head) + (trucler:describe-function *client* env head) + nil))) + (if (typep info 'trucler:macro-description) + (values (cvm.compile:expand (trucler:expander info) form env) t) + (values form nil)))) + (t (values form nil)))) + +(defun s:macroexpand (form &optional env) + (loop with ever-expanded = nil + do (multiple-value-bind (expansion expandedp) + (s:macroexpand-1 form env) + (if expandedp + (setq ever-expanded t form expansion) + (return (values form ever-expanded)))))) + +;;; Macro used in tests of environments in system macros +;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP +;;; was being called in some system macros without the proper +;;; environment argument +(defmacro s:expand-in-current-env (macro-form &environment env) + (s:macroexpand macro-form env)) + +;;; SETF is also quite common. +(defun default-symbol-setf-expansion (symbol) + (let ((new (gensym "NEW"))) + (values () () `(,new) `(setq ,symbol ,new) symbol))) + +(defun default-call-setf-expansion (fname arguments) + (let ((new (gensym "NEW")) + (temps (loop repeat (length arguments) collect (gensym)))) + (values temps arguments `(,new) + `(funcall #'(setf ,fname) ,new ,@temps) + `(,fname ,@temps)))) + +(defun %get-setf-expansion (place &optional env) + (etypecase place + (symbol (multiple-value-bind (expansion expandedp) + (s:macroexpand-1 place env) + (if expandedp + (%get-setf-expansion expansion env) + (default-symbol-setf-expansion place)))) + (cons (let* ((head (car place)) + (rest (rest place)) + (info (trucler:describe-function *client* env head))) + (typecase info + (trucler:local-function-description ; shadowed + (default-call-setf-expansion head rest)) + (trucler:local-macro-description + ;; note that we leave global macros to the host, + ;; because there might be a global setf expander + ;; that overrides the macroexpansion. + (%get-setf-expansion (s:macroexpand-1 place env) env)) + (t ;; defer to host + (cl:get-setf-expansion place nil))))))) + +(defmacro s:multiple-value-bind (vars valform &body body) + (if (= (length vars) 1) + `(let ((,(first vars) ,valform)) ,@body) + (let ((r (gensym "REST"))) + `(multiple-value-call (lambda (&optional ,@(mapcar #'list vars) + &rest ,r) + (declare (ignore ,r)) + ,@body) + ,valform)))) + +(defmacro setf-1 (place value &environment env) + (multiple-value-bind (temps forms news write read) + (%get-setf-expansion place env) + (declare (ignore read)) + `(let* (,@(mapcar #'list temps forms)) + (multiple-value-bind (,@news) ,value + ,write)))) + +(defmacro s:setf (&rest pairs) + `(progn + ,@(loop for (place value) on pairs by #'cddr + collect `(setf-1 ,place ,value)))) + +;;; Used extensively in tests as side effects. +(defmacro s:incf (place &optional (delta 1) &environment env) + (multiple-value-bind (temps forms news write read) + (%get-setf-expansion place env) + `(let* (,@(mapcar #'list temps forms)) + (multiple-value-bind (,@news) (+ ,read ,delta) + ,write)))) +(defmacro s:decf (place &optional (delta 1) &environment env) + (multiple-value-bind (temps forms news write read) + (%get-setf-expansion place env) + `(let* (,@(mapcar #'list temps forms)) + (multiple-value-bind (,@news) (- ,read ,delta) + ,write)))) diff --git a/test/package.lisp b/test/package.lisp deleted file mode 100644 index f4b571f..0000000 --- a/test/package.lisp +++ /dev/null @@ -1,4 +0,0 @@ -(defpackage #:cvm.test - (:use #:cl) - (:shadow #:eval #:compile #:macroexpand-1 #:macroexpand #:incf) - (:export #:run #:run!)) diff --git a/test/packages.lisp b/test/packages.lisp new file mode 100644 index 0000000..6f451ec --- /dev/null +++ b/test/packages.lisp @@ -0,0 +1,14 @@ +(defpackage #:cvm.test.sham + (:use) + (:export #:expand-in-current-env #:notnot) + (:export #:macroexpand-1 #:macroexpand) + (:export #:multiple-value-bind #:setf #:incf #:decf)) + +(defpackage #:cvm.test + (:use #:cl) + (:local-nicknames (#:s #:cvm.test.sham)) + (:export #:run #:run!) + ;; We don't define these. They're shadowed so that if you + ;; use one accidentally in a test, you get an obvious error. + ;; We could shadow eval but that messes with e.g. eval-when. + (:shadow #:eval #:compile)) diff --git a/test/rt.lisp b/test/rt.lisp index 9081be3..d3c3a3f 100644 --- a/test/rt.lisp +++ b/test/rt.lisp @@ -3,66 +3,30 @@ (defvar *environment*) (defvar *client*) -;;; Force true values to T. -(defun notnot (v) (not (not v))) - -(defun macroexpand-1 (form &optional env) - (typecase form - (symbol - (let ((info (trucler:describe-variable *client* env form))) - (if (typep info 'trucler:symbol-macro-description) - (values (cvm.compile:symbol-macro-expansion info form env) t) - (values form nil)))) - (cons - (let* ((head (car form)) - (info (if (symbolp head) - (trucler:describe-function *client* env head) - nil))) - (if (typep info 'trucler:macro-description) - (values (cvm.compile:expand (trucler:expander info) form env) t) - (values form nil)))) - (t (values form nil)))) - -(defun macroexpand (form &optional env) - (loop with ever-expanded = nil - do (multiple-value-bind (expansion expandedp) - (macroexpand-1 form env) - (if expandedp - (setf ever-expanded t form expansion) - (return (values form ever-expanded)))))) - -;;; Macro used in tests of environments in system macros -;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP -;;; was being called in some system macros without the proper -;;; environment argument -(defmacro expand-in-current-env (macro-form &environment env) - (macroexpand macro-form env)) - -;;; Used extensively by the tests as a side effect, but not in -;;; any very complicated ways. -(defmacro incf (place &optional (delta 1) &environment env) - ;; FIXME: Check for symbol macros. - (if (symbolp place) - ;; (this part will be a problem if place is a symbol macro) - `(setq ,place (+ ,place ,delta)) - (error "Sham INCF not implemented for form: ~s" place))) - -(defun eval (form) +(defun ceval (form) (cvm.compile:eval form *environment* *client*)) -(defun compile (name lambda-expression) +(defun ccompile (name definition) (declare (ignore name)) - (cvm.compile:compile lambda-expression *environment* *client*)) + (etypecase definition + ((cons (eql lambda)) + (cvm.compile:compile definition *environment* *client*)) + ;; this happens in lambda.55,56 + (function definition))) (defmacro is-true-eval (form) - `(5am:is-true (eval ',form))) + `(5am:is-true (ceval ',form))) (defmacro signals-eval (condition-type form) - `(5am:signals ,condition-type (eval ',form))) + `(5am:signals ,condition-type (ceval ',form))) + +(defmacro is-values-eval (form &rest expected) + `(5am:is (equal '(,@expected) + (multiple-value-list (ceval ',form))))) (defmacro deftest (name form &rest expected) `(5am:test ,name - (5am:is (equal '(,@expected) (multiple-value-list (eval ',form)))))) + (is-values-eval ,form ,@expected))) (defun run (*environment* *client*) (5am:run 'cvm)) From 3221ecedade87b90810bd1c67a314ff824a039df Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 16:59:19 -0400 Subject: [PATCH 13/32] Fix setf function name lookup in compiler --- compile.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compile.lisp b/compile.lisp index f94f996..2648733 100644 --- a/compile.lisp +++ b/compile.lisp @@ -505,7 +505,7 @@ (defmethod trucler:describe-function (client (env lexical-environment) name) - (or (cdr (assoc name (funs env))) + (or (cdr (assoc name (funs env) :test #'equal)) (trucler:describe-variable client (global-environment env) name))) @@ -521,7 +521,7 @@ (or (cdr (assoc name (vars env))) (trucler:describe-variable m:*client* (global-environment env) name))) (defun fun-info (name env) - (or (cdr (assoc name (funs env))) + (or (cdr (assoc name (funs env) :test #'equal)) (trucler:describe-function m:*client* (global-environment env) name))) ;; never actually called From 5f28580c2d6a293059214f17f00003566587a8fd Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 22:51:30 -0400 Subject: [PATCH 14/32] Start on cross tester --- compile.lisp | 10 +++- cvm.asd | 12 ++++ test/cross-sham.lisp | 117 +++++++++++++++++++++++++++++++++++++++ test/cross/packages.lisp | 4 ++ test/cross/rt.lisp | 9 +++ test/cross/sham.lisp | 117 +++++++++++++++++++++++++++++++++++++++ test/native-sham.lisp | 11 ++++ test/packages.lisp | 3 +- 8 files changed, 280 insertions(+), 3 deletions(-) create mode 100644 test/cross-sham.lisp create mode 100644 test/cross/packages.lisp create mode 100644 test/cross/rt.lisp create mode 100644 test/cross/sham.lisp diff --git a/compile.lisp b/compile.lisp index 2648733..60c170c 100644 --- a/compile.lisp +++ b/compile.lisp @@ -1689,8 +1689,14 @@ ;; Now replace the cfunctions in the cmodule literal vector with ;; real bytecode functions. ;; Also replace the load-time-value infos with the evaluated forms. - (map-into literals (lambda (info) (load-literal-info client info env)) - cmodule-literals)) + (let ((genv + ;; Obviously anything we're linking is global. + (if (lexical-environment-p env) + (global-environment env) + env))) + (map-into literals + (lambda (info) (load-literal-info client info genv)) + cmodule-literals))) (values)) (defun link-function (cfunction env) diff --git a/cvm.asd b/cvm.asd index 538c114..a2082e8 100644 --- a/cvm.asd +++ b/cvm.asd @@ -55,3 +55,15 @@ (:file "progn") (:file "return-from") (:file "tagbody"))))))) + +(asdf:defsystem #:cvm/test/cross + :author ("Bike ") + :maintainer "Bike " + :depends-on (:cvm/test :cvm-cross :clostrum) + :components + ((:module "test" + :components ((:module "cross" + :components ((:file "packages") + (:file "sham" :depends-on ("packages")) + (:file "rt" :depends-on ("sham" + "packages")))))))) diff --git a/test/cross-sham.lisp b/test/cross-sham.lisp new file mode 100644 index 0000000..f9db23a --- /dev/null +++ b/test/cross-sham.lisp @@ -0,0 +1,117 @@ +(in-package #:cvm.test) + +#| ; accounting for what's actually used +compile: (eq let quote) +dynamic-extent: (let quote list length vector flet mapcar labels consp cons car cdr most-positive-fixnum 1- values setq prog1 make-array coerce equal make-string every eql s:setf function) +eval: (let) +eval-when: (eval-when values setq let s:expand-in-current-env) +ignorable: () +ignore: () +lambda: (s:notnot 1+ s:incf) ; not the lambda macro, funnily enough +locally: (locally t nil macrolet) ; nil's probably in an earlier file, w/e +optimize: () +special: () +symbol-macrolet: (symbol-macrolet) +the: (the) +type: (s:decf) +block: (block return-from return tagbody) +flet: (:x) ; bla bla keywords will need a clostrum intercept +if: (if =) +labels: +let: (+) +multiple-value-call: (multiple-value-call floor) +multiple-value-prog1: (values-list) +progn: (progn go) +return-from: () +tagbody: () +|# + +(defun define-specials (client environment) + ;; from figure 3-2 + (loop for op in '(block let* return-from + catch load-time-value setq + eval-when locally symbol-macrolet + flet macrolet tagbody + function multiple-value-call the + go multiple-value-prog1 throw + if progn unwind-protect + labels progv + let quote) + do (clostrum:make-special-operator client environment op t))) + +;;; define functions that can be just copied from the host +(defun define-aliases (client environment) + (loop for op in '(list length vector consp cons car cdr null not + ;; coerce only ok because no test does + ;; (coerce foo 'function) + 1+ 1- + = - values make-array coerce make-string + values-list eq eql equal equalp + error) + for f = (fdefinition op) + do (setf (clostrum:fdefinition client environment op) f))) + +(defun define-sham-aliases (client environment) + (loop for op in '(s:notnot) + for f = (fdefinition op) + do (setf (clostrum:fdefinition client environment op) f)) + (loop for op in '(s:macroexpand-1 s:macroexpand) + for cl in '( macroexpand-1 macroexpand) + for f = (fdefinition op) + do (setf (clostrum:fdefinition client environment op) f + (clostrum:fdefinition client environment cl) f))) + +;;; functions that can be copied except we ban the env-specific parts +(defun define-stricter-aliases (client environment) + (loop for op in '(mapc mapcar mapcan mapl maplist mapcon + every some notany notevery funcall apply) + for f = (fdefinition op) + for g = (let ((f f)) + (lambda (fun &rest args) + (check-type fun function) + (apply f fun args))) + do (setf (clostrum:fdefinition client environment op) g))) + +;;; constants copied from the host +(defun define-constants (client environment) + (loop for c in '(t nil most-positive-fixnum most-negative-fixnum) + for v = (symbol-value c) + do (clostrum:make-constant client environment c v))) + +(defun define-macros (client environment) + (loop for mac in '(s:expand-in-current-env setf-1) + for f = (macro-function mac) + do (setf (clostrum:macro-function client environment mac) f)) + (loop for mac in '(s:multiple-value-bind + s:setf s:incf s:decf + s:when s:unless s:prog1) + for cl in '(multiple-value-bind + setf incf decf + when unless prog1) + for f = (macro-function mac) + do (setf (clostrum:macro-function client environment mac) f + (clostrum:macro-function client environment cl) f))) + +(defun fill-environment (client environment) + (define-specials client environment) + (define-aliases client environment) + (define-sham-aliases client environment) + (define-stricter-aliases client environment) + (define-constants client environment) + (define-macros client environment)) + +;;; On top of all that, we need to define a client so that we +;;; can define some methods to automatically bind keywords. +(defclass cross-client (cvm.cross:client) ()) + +(defmethod clostrum-sys:variable-cell :around ((client cross-client) + environment symbol) + (let ((cell (call-next-method))) + (when (keywordp symbol) + (setf (clostrum-sys:variable-cell-value client cell) symbol)) + cell)) + +(defmethod clostrum-sys:variable-status :around ((client cross-client) + environment symbol) + (if (keywordp symbol) + :constant + (call-next-method))) diff --git a/test/cross/packages.lisp b/test/cross/packages.lisp new file mode 100644 index 0000000..1f8b29d --- /dev/null +++ b/test/cross/packages.lisp @@ -0,0 +1,4 @@ +(defpackage #:cvm.test.cross + (:use #:cl) + (:local-nicknames (#:s #:cvm.test.sham)) + (:export #:fill-environment #:run #:run!)) diff --git a/test/cross/rt.lisp b/test/cross/rt.lisp new file mode 100644 index 0000000..b63eb6a --- /dev/null +++ b/test/cross/rt.lisp @@ -0,0 +1,9 @@ +(in-package #:cvm.test.cross) + +(defvar *client* (make-instance 'client)) + +(defun fill-environment (environment) + (%fill-environment *client* environment)) + +(defun run (environment) (cvm.test:run environment *client*)) +(defun run! (environment) (cvm.test:run! environment *client*)) diff --git a/test/cross/sham.lisp b/test/cross/sham.lisp new file mode 100644 index 0000000..9c952b7 --- /dev/null +++ b/test/cross/sham.lisp @@ -0,0 +1,117 @@ +(in-package #:cvm.test.cross) + +#| ; accounting for what's actually used +compile: (eq let quote) +dynamic-extent: (let quote list length vector flet mapcar labels consp cons car cdr most-positive-fixnum 1- values setq prog1 make-array coerce equal make-string every eql s:setf function) +eval: (let) +eval-when: (eval-when values setq let s:expand-in-current-env) +ignorable: () +ignore: () +lambda: (s:notnot 1+ s:incf) ; not the lambda macro, funnily enough +locally: (locally t nil macrolet) ; nil's probably in an earlier file, w/e +optimize: () +special: () +symbol-macrolet: (symbol-macrolet) +the: (the) +type: (s:decf) +block: (block return-from return tagbody) +flet: (:x) ; bla bla keywords will need a clostrum intercept +if: (if =) +labels: +let: (+) +multiple-value-call: (multiple-value-call floor) +multiple-value-prog1: (values-list) +progn: (progn go) +return-from: () +tagbody: () +|# + +(defun define-specials (client environment) + ;; from figure 3-2 + (loop for op in '(block let* return-from + catch load-time-value setq + eval-when locally symbol-macrolet + flet macrolet tagbody + function multiple-value-call the + go multiple-value-prog1 throw + if progn unwind-protect + labels progv + let quote) + do (clostrum:make-special-operator client environment op t))) + +;;; define functions that can be just copied from the host +(defun define-aliases (client environment) + (loop for op in '(list length vector consp cons car cdr null not + ;; coerce only ok because no test does + ;; (coerce foo 'function) + 1+ 1- + = - values make-array coerce make-string + values-list eq eql equal equalp + error) + for f = (fdefinition op) + do (setf (clostrum:fdefinition client environment op) f))) + +(defun define-sham-aliases (client environment) + (loop for op in '(s:notnot) + for f = (fdefinition op) + do (setf (clostrum:fdefinition client environment op) f)) + (loop for op in '(s:macroexpand-1 s:macroexpand) + for cl in '( macroexpand-1 macroexpand) + for f = (fdefinition op) + do (setf (clostrum:fdefinition client environment op) f + (clostrum:fdefinition client environment cl) f))) + +;;; functions that can be copied except we ban the env-specific parts +(defun define-stricter-aliases (client environment) + (loop for op in '(mapc mapcar mapcan mapl maplist mapcon + every some notany notevery funcall apply) + for f = (fdefinition op) + for g = (let ((f f)) + (lambda (fun &rest args) + (check-type fun function) + (apply f fun args))) + do (setf (clostrum:fdefinition client environment op) g))) + +;;; constants copied from the host +(defun define-constants (client environment) + (loop for c in '(t nil most-positive-fixnum most-negative-fixnum) + for v = (symbol-value c) + do (clostrum:make-constant client environment c v))) + +(defun define-macros (client environment) + (loop for mac in '(s:expand-in-current-env setf-1) + for f = (macro-function mac) + do (setf (clostrum:macro-function client environment mac) f)) + (loop for mac in '(s:multiple-value-bind + s:setf s:incf s:decf + s:when s:unless s:prog1) + for cl in '(multiple-value-bind + setf incf decf + when unless prog1) + for f = (macro-function mac) + do (setf (clostrum:macro-function client environment mac) f + (clostrum:macro-function client environment cl) f))) + +(defun %fill-environment (client environment) + (define-specials client environment) + (define-aliases client environment) + (define-sham-aliases client environment) + (define-stricter-aliases client environment) + (define-constants client environment) + (define-macros client environment)) + +;;; On top of all that, we need to define a client so that we +;;; can define some methods to automatically bind keywords. +(defclass client (cvm.cross:client) ()) + +(defmethod clostrum-sys:variable-cell :around ((client client) + environment symbol) + (let ((cell (call-next-method))) + (when (keywordp symbol) + (setf (clostrum-sys:variable-cell-value client cell) symbol)) + cell)) + +(defmethod clostrum-sys:variable-status :around ((client client) + environment symbol) + (if (keywordp symbol) + :constant + (call-next-method))) diff --git a/test/native-sham.lisp b/test/native-sham.lisp index 6665b98..13d9816 100644 --- a/test/native-sham.lisp +++ b/test/native-sham.lisp @@ -56,6 +56,17 @@ (defmacro s:expand-in-current-env (macro-form &environment env) (s:macroexpand macro-form env)) +;;; used indirectly in ecclesia:parse-macro results +(defmacro s:when (test &body forms) + `(if ,test (progn ,@forms) nil)) +(defmacro s:unless (test &body forms) + `(if ,test nil (progn ,@forms))) + +(defmacro s:prog1 (result &body body) + (let ((temp (gensym))) + ;; progn to invalidate declarations + `(let ((,temp ,result)) (progn ,@body) ,temp))) + ;;; SETF is also quite common. (defun default-symbol-setf-expansion (symbol) (let ((new (gensym "NEW"))) diff --git a/test/packages.lisp b/test/packages.lisp index 6f451ec..5c00de6 100644 --- a/test/packages.lisp +++ b/test/packages.lisp @@ -2,7 +2,8 @@ (:use) (:export #:expand-in-current-env #:notnot) (:export #:macroexpand-1 #:macroexpand) - (:export #:multiple-value-bind #:setf #:incf #:decf)) + (:export #:multiple-value-bind #:setf #:incf #:decf + #:prog1 #:when #:unless)) (defpackage #:cvm.test (:use #:cl) From ed47da24942314915e91a933da730a5d65c13b3c Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 23:07:29 -0400 Subject: [PATCH 15/32] Define more stuff for cross tests sham --- test/cross/sham.lisp | 22 ++++++++++++++++++---- test/native-sham.lisp | 9 +++++++++ test/packages.lisp | 2 +- 3 files changed, 28 insertions(+), 5 deletions(-) diff --git a/test/cross/sham.lisp b/test/cross/sham.lisp index 9c952b7..aa91788 100644 --- a/test/cross/sham.lisp +++ b/test/cross/sham.lisp @@ -41,10 +41,11 @@ tagbody: () ;;; define functions that can be just copied from the host (defun define-aliases (client environment) - (loop for op in '(list length vector consp cons car cdr null not + (loop for op in '(list list* length vector make-array make-string + consp cons car cdr null not ;; coerce only ok because no test does ;; (coerce foo 'function) - 1+ 1- + = - values make-array coerce make-string + 1+ 1- + = - floor values functionp coerce values-list eq eql equal equalp error) for f = (fdefinition op) @@ -60,6 +61,18 @@ tagbody: () do (setf (clostrum:fdefinition client environment op) f (clostrum:fdefinition client environment cl) f))) +(defun define-env-access (client environment) + ;; fdefinition is used implicitly by multiple-value-call. + (flet ((%fdefinition (name) + (clostrum:fdefinition client environment name)) + (%symbol-function (name) + (check-type name symbol) + (clostrum:fdefinition client environment name))) + (setf (clostrum:fdefinition client environment 'fdefinition) + #'%fdefinition + (clostrum:fdefinition client environment 'symbol-function) + #'%symbol-function))) + ;;; functions that can be copied except we ban the env-specific parts (defun define-stricter-aliases (client environment) (loop for op in '(mapc mapcar mapcan mapl maplist mapcon @@ -83,10 +96,10 @@ tagbody: () do (setf (clostrum:macro-function client environment mac) f)) (loop for mac in '(s:multiple-value-bind s:setf s:incf s:decf - s:when s:unless s:prog1) + s:when s:unless s:prog1 s:prog s:return) for cl in '(multiple-value-bind setf incf decf - when unless prog1) + when unless prog1 prog return) for f = (macro-function mac) do (setf (clostrum:macro-function client environment mac) f (clostrum:macro-function client environment cl) f))) @@ -95,6 +108,7 @@ tagbody: () (define-specials client environment) (define-aliases client environment) (define-sham-aliases client environment) + (define-env-access client environment) (define-stricter-aliases client environment) (define-constants client environment) (define-macros client environment)) diff --git a/test/native-sham.lisp b/test/native-sham.lisp index 13d9816..09235ed 100644 --- a/test/native-sham.lisp +++ b/test/native-sham.lisp @@ -67,6 +67,15 @@ ;; progn to invalidate declarations `(let ((,temp ,result)) (progn ,@body) ,temp))) +(defmacro s:return (&optional value) `(return-from nil ,value)) + +(defmacro s:prog ((&rest bindings) &body body) + (multiple-value-bind (body decls) (alexandria:parse-body body) + `(block nil + (let (,@bindings) + ,@decls + (tagbody ,@body))))) + ;;; SETF is also quite common. (defun default-symbol-setf-expansion (symbol) (let ((new (gensym "NEW"))) diff --git a/test/packages.lisp b/test/packages.lisp index 5c00de6..5e51413 100644 --- a/test/packages.lisp +++ b/test/packages.lisp @@ -3,7 +3,7 @@ (:export #:expand-in-current-env #:notnot) (:export #:macroexpand-1 #:macroexpand) (:export #:multiple-value-bind #:setf #:incf #:decf - #:prog1 #:when #:unless)) + #:prog1 #:when #:unless #:return #:prog)) (defpackage #:cvm.test (:use #:cl) From a9e9cc9d1e3486958ca02e13f57826f72307fb31 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 23:11:49 -0400 Subject: [PATCH 16/32] port program error stuff to cross vm --- Cross/vm.lisp | 87 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 67 insertions(+), 20 deletions(-) diff --git a/Cross/vm.lisp b/Cross/vm.lisp index b704597..586cc31 100644 --- a/Cross/vm.lisp +++ b/Cross/vm.lisp @@ -7,6 +7,47 @@ (in-package #:cvm.cross.vm) +(define-condition wrong-number-of-arguments (program-error) + ((%called-function :initform nil :initarg :called-function + :reader called-function) + (%given-nargs :initarg :given-nargs :reader given-nargs) + (%min-nargs :initarg :min-nargs :reader min-nargs :initform nil) + (%max-nargs :initarg :max-nargs :reader max-nargs :initform nil)) + (:report (lambda (condition stream) + (let* ((min (min-nargs condition)) + (max (max-nargs condition)) + ;; FIXME: get an actual name if possible + (dname nil)) + (format stream "~@[Calling ~a - ~]Got ~d arguments, but expected ~@?" + dname (given-nargs condition) + (cond ((null max) "at least ~d") + ((null min) "at most ~*~d") + ;; I think "exactly 0" is better than "at most 0", thus duplication + ((= min max) "exactly ~d") + ((zerop min) "at most ~*~d") + (t "between ~d and ~d")) + min max))))) + +(define-condition odd-keywords (program-error) + ((%called-function :initarg :called-function :reader called-function + :initform nil)) + (:report (lambda (condition stream) + (format stream "Odd number of keyword arguments~:[~; for ~s~]." + (called-function condition) + ;; FIXME: again, get an actual name somehow. + nil)))) + +(define-condition unrecognized-keyword-argument (program-error) + ((%called-function :initarg :called-function :reader called-function + :initform nil) + (%unrecognized-keywords :initarg :unrecognized-keywords + :reader unrecognized-keywords)) + (:report (lambda (condition stream) + (format stream "Unrecognized keyword arguments ~S~:[~; for ~S~]." + (unrecognized-keywords condition) + (called-function condition) ; FIXME: name + nil)))) + (defstruct vm (values nil :type list) (stack #() :type simple-vector) @@ -272,20 +313,23 @@ ((#.m:check-arg-count-<=) (let ((n (next-code))) (unless (<= (vm-arg-count vm) n) - (error "Invalid number of arguments: Got ~d, need at most ~d." - (vm-arg-count vm) n))) + (error 'wrong-number-of-arguments + :given-nargs (vm-arg-count vm) + :max-nargs n))) (incf ip)) ((#.m:check-arg-count->=) (let ((n (next-code))) (unless (>= (vm-arg-count vm) n) - (error "Invalid number of arguments: Got ~d, need at least ~d." - (vm-arg-count vm) n))) + (error 'wrong-number-of-arguments + :given-nargs (vm-arg-count vm) + :min-nargs n))) (incf ip)) ((#.m:check-arg-count-=) (let ((n (next-code))) (unless (= (vm-arg-count vm) n) - (error "Invalid number of arguments: Got ~d, need exactly ~d." - (vm-arg-count vm) n))) + (error 'wrong-number-of-arguments + :given-nargs (vm-arg-count vm) + :min-nargs n :max-nargs n))) (incf ip)) ((#.m:jump-if-supplied-8) (incf ip (if (typep (stack (+ bp (next-code))) 'unbound-marker) @@ -343,7 +387,7 @@ (key-literal-start (next-code)) (key-literal-end (+ key-literal-start key-count)) (key-frame-start (+ bp (next-code))) - (unknown-key-p nil) + (unknown-keys nil) (allow-other-keys-p nil)) ;; Initialize all key values to # (loop for index from key-frame-start below (+ key-frame-start key-count) @@ -353,24 +397,27 @@ ((< arg-index more-start) (cond ((= arg-index (1- more-start))) ((= arg-index (- more-start 2)) - (error "Passed odd number of &KEY args!")) + (error 'odd-keywords)) (t (error "BUG! This can't happen!")))) (let ((key (stack (1- arg-index)))) - (if (eq key :allow-other-keys) - (setf allow-other-keys-p (stack arg-index)) - (loop for key-index from key-literal-start - below key-literal-end - for offset of-type (unsigned-byte 16) - from key-frame-start - do (when (eq (constant key-index) key) - (setf (stack offset) (stack arg-index)) - (return)) - finally (setf unknown-key-p key)))))) + (when (eq key :allow-other-keys) + (setf allow-other-keys-p (stack arg-index))) + (loop for key-index from key-literal-start + below key-literal-end + for offset of-type (unsigned-byte 16) + from key-frame-start + do (when (eq (constant key-index) key) + (setf (stack offset) (stack arg-index)) + (return)) + finally (unless (or allow-other-keys-p + (eq key :allow-other-keys)) + (push key unknown-keys)))))) (when (and (not (or (logbitp 7 key-count-info) allow-other-keys-p)) - unknown-key-p) - (error "Unknown key arg ~a!" unknown-key-p))) + unknown-keys) + (error 'unrecognized-keyword-argument + :unrecognized-keywords unknown-keys))) (incf ip)) ((#.m:save-sp) (setf (stack (+ bp (next-code))) sp) From 0a88749a10234ab4b894d68b9e8e8f3ee6238f5b Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 23:20:27 -0400 Subject: [PATCH 17/32] fix setf sham for cross tester --- test/cross/sham.lisp | 10 +++++++++- test/native-sham.lisp | 27 +++++++++++++-------------- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/test/cross/sham.lisp b/test/cross/sham.lisp index aa91788..21423f8 100644 --- a/test/cross/sham.lisp +++ b/test/cross/sham.lisp @@ -51,6 +51,13 @@ tagbody: () for f = (fdefinition op) do (setf (clostrum:fdefinition client environment op) f))) +;;; may or may not exist in the lisp, so +(defun define-setters (client environment) + (flet (((setf %car) (new cons) (setf (car cons) new)) + ((setf %cdr) (new cons) (setf (cdr cons) new))) + (setf (clostrum:fdefinition client environment '(setf car)) #'(setf %car) + (clostrum:fdefinition client environment '(setf cdr)) #'(setf %cdr)))) + (defun define-sham-aliases (client environment) (loop for op in '(s:notnot) for f = (fdefinition op) @@ -91,7 +98,7 @@ tagbody: () do (clostrum:make-constant client environment c v))) (defun define-macros (client environment) - (loop for mac in '(s:expand-in-current-env setf-1) + (loop for mac in '(s:expand-in-current-env) for f = (macro-function mac) do (setf (clostrum:macro-function client environment mac) f)) (loop for mac in '(s:multiple-value-bind @@ -107,6 +114,7 @@ tagbody: () (defun %fill-environment (client environment) (define-specials client environment) (define-aliases client environment) + (define-setters client environment) (define-sham-aliases client environment) (define-env-access client environment) (define-stricter-aliases client environment) diff --git a/test/native-sham.lisp b/test/native-sham.lisp index 09235ed..267785b 100644 --- a/test/native-sham.lisp +++ b/test/native-sham.lisp @@ -106,8 +106,8 @@ ;; because there might be a global setf expander ;; that overrides the macroexpansion. (%get-setf-expansion (s:macroexpand-1 place env) env)) - (t ;; defer to host - (cl:get-setf-expansion place nil))))))) + (t ; (for now) we have no setf expanders, so + (default-call-setf-expansion head rest))))))) (defmacro s:multiple-value-bind (vars valform &body body) (if (= (length vars) 1) @@ -119,18 +119,17 @@ ,@body) ,valform)))) -(defmacro setf-1 (place value &environment env) - (multiple-value-bind (temps forms news write read) - (%get-setf-expansion place env) - (declare (ignore read)) - `(let* (,@(mapcar #'list temps forms)) - (multiple-value-bind (,@news) ,value - ,write)))) - -(defmacro s:setf (&rest pairs) - `(progn - ,@(loop for (place value) on pairs by #'cddr - collect `(setf-1 ,place ,value)))) +(defmacro s:setf (&rest pairs &environment env) + (flet ((expand-setf-1 (place value) + (multiple-value-bind (temps forms news write read) + (%get-setf-expansion place env) + (declare (ignore read)) + `(let* (,@(mapcar #'list temps forms)) + (multiple-value-bind (,@news) ,value + ,write))))) + `(progn + ,@(loop for (place value) on pairs by #'cddr + collect (expand-setf-1 place value))))) ;;; Used extensively in tests as side effects. (defmacro s:incf (place &optional (delta 1) &environment env) From 8358a7e4de842a7d8c1a9e4357409160608f1400 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 29 Sep 2023 23:25:11 -0400 Subject: [PATCH 18/32] add test READMEs before I forget everything --- test/README | 7 +++++++ test/cross/README | 3 +++ 2 files changed, 10 insertions(+) create mode 100644 test/README create mode 100644 test/cross/README diff --git a/test/README b/test/README new file mode 100644 index 0000000..2531301 --- /dev/null +++ b/test/README @@ -0,0 +1,7 @@ +This system runs a small subset of the ANSI tests directly related to evaluation semantics on the VM with a client and environment of your choice. This client and environment are passed through to cvm.compile functions and otherwise arbitrary. + +For example, to use the basic native client on SBCL, you could do: + +(run! nil (make-instance 'trucler-native-sbcl:client)) + +Eventually there will be more tests, hopefully. diff --git a/test/cross/README b/test/cross/README new file mode 100644 index 0000000..27bf9a4 --- /dev/null +++ b/test/cross/README @@ -0,0 +1,3 @@ +This system runs the cvm/test tests with the cross VM. It has its own client, mostly to handle keywords, but you can use any environment as long as it works with Clostrum. + +The environment must have a certain small subset of the CL symbols bound appropriately, along with a few extras. FILL-ENVIRONMENT will define these for you, given an environment. From e87b34bc29f5d16450243c29180183897ec76773 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 08:59:55 -0400 Subject: [PATCH 19/32] Move argument parsing errors to shared file --- Cross/vm.lisp | 54 ++++++-------------------------------------- arg-conditions.lisp | 49 ++++++++++++++++++++++++++++++++++++++++ cvm.asd | 4 +++- vm.lisp | 55 ++++++--------------------------------------- 4 files changed, 66 insertions(+), 96 deletions(-) create mode 100644 arg-conditions.lisp diff --git a/Cross/vm.lisp b/Cross/vm.lisp index 586cc31..7555632 100644 --- a/Cross/vm.lisp +++ b/Cross/vm.lisp @@ -1,53 +1,13 @@ (defpackage #:cvm.cross.vm (:use #:cl) - (:local-nicknames (#:m #:cvm.machine)) + (:local-nicknames (#:m #:cvm.machine) + (#:arg #:cvm.argparse)) (:export #:initialize-vm) (:export #:*trace*) (:export #:symbol-cell)) (in-package #:cvm.cross.vm) -(define-condition wrong-number-of-arguments (program-error) - ((%called-function :initform nil :initarg :called-function - :reader called-function) - (%given-nargs :initarg :given-nargs :reader given-nargs) - (%min-nargs :initarg :min-nargs :reader min-nargs :initform nil) - (%max-nargs :initarg :max-nargs :reader max-nargs :initform nil)) - (:report (lambda (condition stream) - (let* ((min (min-nargs condition)) - (max (max-nargs condition)) - ;; FIXME: get an actual name if possible - (dname nil)) - (format stream "~@[Calling ~a - ~]Got ~d arguments, but expected ~@?" - dname (given-nargs condition) - (cond ((null max) "at least ~d") - ((null min) "at most ~*~d") - ;; I think "exactly 0" is better than "at most 0", thus duplication - ((= min max) "exactly ~d") - ((zerop min) "at most ~*~d") - (t "between ~d and ~d")) - min max))))) - -(define-condition odd-keywords (program-error) - ((%called-function :initarg :called-function :reader called-function - :initform nil)) - (:report (lambda (condition stream) - (format stream "Odd number of keyword arguments~:[~; for ~s~]." - (called-function condition) - ;; FIXME: again, get an actual name somehow. - nil)))) - -(define-condition unrecognized-keyword-argument (program-error) - ((%called-function :initarg :called-function :reader called-function - :initform nil) - (%unrecognized-keywords :initarg :unrecognized-keywords - :reader unrecognized-keywords)) - (:report (lambda (condition stream) - (format stream "Unrecognized keyword arguments ~S~:[~; for ~S~]." - (unrecognized-keywords condition) - (called-function condition) ; FIXME: name - nil)))) - (defstruct vm (values nil :type list) (stack #() :type simple-vector) @@ -313,21 +273,21 @@ ((#.m:check-arg-count-<=) (let ((n (next-code))) (unless (<= (vm-arg-count vm) n) - (error 'wrong-number-of-arguments + (error 'arg:wrong-number-of-arguments :given-nargs (vm-arg-count vm) :max-nargs n))) (incf ip)) ((#.m:check-arg-count->=) (let ((n (next-code))) (unless (>= (vm-arg-count vm) n) - (error 'wrong-number-of-arguments + (error 'arg:wrong-number-of-arguments :given-nargs (vm-arg-count vm) :min-nargs n))) (incf ip)) ((#.m:check-arg-count-=) (let ((n (next-code))) (unless (= (vm-arg-count vm) n) - (error 'wrong-number-of-arguments + (error 'arg:wrong-number-of-arguments :given-nargs (vm-arg-count vm) :min-nargs n :max-nargs n))) (incf ip)) @@ -397,7 +357,7 @@ ((< arg-index more-start) (cond ((= arg-index (1- more-start))) ((= arg-index (- more-start 2)) - (error 'odd-keywords)) + (error 'arg:odd-keywords)) (t (error "BUG! This can't happen!")))) (let ((key (stack (1- arg-index)))) @@ -416,7 +376,7 @@ (when (and (not (or (logbitp 7 key-count-info) allow-other-keys-p)) unknown-keys) - (error 'unrecognized-keyword-argument + (error 'arg:unrecognized-keyword-argument :unrecognized-keywords unknown-keys))) (incf ip)) ((#.m:save-sp) diff --git a/arg-conditions.lisp b/arg-conditions.lisp new file mode 100644 index 0000000..23752b6 --- /dev/null +++ b/arg-conditions.lisp @@ -0,0 +1,49 @@ +(defpackage #:cvm.argparse + (:use #:cl) + (:export #:argument-error + #:wrong-number-of-arguments #:odd-keywords + #:unrecognized-keyword-argument)) + +(in-package #:cvm.argparse) + +;;; abstract parent type for errors signaled by lambda list processing +(define-condition argument-error (program-error) + ((%called-function :initform nil :initarg :called-function + :reader called-function))) + +;;; nabbed from clasp +(define-condition wrong-number-of-arguments (argument-error) + ((%given-nargs :initarg :given-nargs :reader given-nargs) + (%min-nargs :initarg :min-nargs :reader min-nargs :initform nil) + (%max-nargs :initarg :max-nargs :reader max-nargs :initform nil)) + (:report (lambda (condition stream) + (let* ((min (min-nargs condition)) + (max (max-nargs condition)) + ;; FIXME: get an actual name if possible + (dname nil)) + (format stream "~@[Calling ~a - ~]Got ~d arguments, but expected ~@?" + dname (given-nargs condition) + (cond ((null max) "at least ~d") + ((null min) "at most ~*~d") + ;; I think "exactly 0" is better than "at most 0", thus duplication + ((= min max) "exactly ~d") + ((zerop min) "at most ~*~d") + (t "between ~d and ~d")) + min max))))) + +(define-condition odd-keywords (argument-error) + () + (:report (lambda (condition stream) + (format stream "Odd number of keyword arguments~:[~; for ~s~]." + (called-function condition) + ;; FIXME: again, get an actual name somehow. + nil)))) + +(define-condition unrecognized-keyword-argument (argument-error) + ((%unrecognized-keywords :initarg :unrecognized-keywords + :reader unrecognized-keywords)) + (:report (lambda (condition stream) + (format stream "Unrecognized keyword arguments ~S~:[~; for ~S~]." + (unrecognized-keywords condition) + (called-function condition) ; FIXME: name + nil)))) diff --git a/cvm.asd b/cvm.asd index a2082e8..d573820 100644 --- a/cvm.asd +++ b/cvm.asd @@ -9,11 +9,13 @@ :alexandria :trucler :ecclesia ; compiler :ieee-floats) ; compile-file :components ((:file "machine") + (:file "arg-conditions") (:file "structures" :depends-on ("machine")) (:file "disassemble" :depends-on ("structures" "machine")) (:file "compile" :depends-on ("structures" "machine")) (:file "cmpltv" :depends-on ("compile")) - (:file "vm" :depends-on ("disassemble" "structures" "machine")))) + (:file "vm" :depends-on ("arg-conditions" "disassemble" + "structures" "machine")))) (asdf:defsystem #:cvm/test :author ("Bike ") diff --git a/vm.lisp b/vm.lisp index e73c257..c537571 100644 --- a/vm.lisp +++ b/vm.lisp @@ -1,53 +1,12 @@ (defpackage #:cvm.vm (:use #:cl) - (:local-nicknames (#:m #:cvm.machine)) + (:local-nicknames (#:m #:cvm.machine) + (#:arg #:cvm.argparse)) (:export #:initialize-vm) (:export #:*trace*)) (in-package #:cvm.vm) -;;; nabbed from clasp -(define-condition wrong-number-of-arguments (program-error) - ((%called-function :initform nil :initarg :called-function - :reader called-function) - (%given-nargs :initarg :given-nargs :reader given-nargs) - (%min-nargs :initarg :min-nargs :reader min-nargs :initform nil) - (%max-nargs :initarg :max-nargs :reader max-nargs :initform nil)) - (:report (lambda (condition stream) - (let* ((min (min-nargs condition)) - (max (max-nargs condition)) - ;; FIXME: get an actual name if possible - (dname nil)) - (format stream "~@[Calling ~a - ~]Got ~d arguments, but expected ~@?" - dname (given-nargs condition) - (cond ((null max) "at least ~d") - ((null min) "at most ~*~d") - ;; I think "exactly 0" is better than "at most 0", thus duplication - ((= min max) "exactly ~d") - ((zerop min) "at most ~*~d") - (t "between ~d and ~d")) - min max))))) - -(define-condition odd-keywords (program-error) - ((%called-function :initarg :called-function :reader called-function - :initform nil)) - (:report (lambda (condition stream) - (format stream "Odd number of keyword arguments~:[~; for ~s~]." - (called-function condition) - ;; FIXME: again, get an actual name somehow. - nil)))) - -(define-condition unrecognized-keyword-argument (program-error) - ((%called-function :initarg :called-function :reader called-function - :initform nil) - (%unrecognized-keywords :initarg :unrecognized-keywords - :reader unrecognized-keywords)) - (:report (lambda (condition stream) - (format stream "Unrecognized keyword arguments ~S~:[~; for ~S~]." - (unrecognized-keywords condition) - (called-function condition) ; FIXME: name - nil)))) - (defstruct vm (values nil :type list) (stack #() :type simple-vector) @@ -263,21 +222,21 @@ ((#.m:check-arg-count-<=) (let ((n (next-code))) (unless (<= (vm-arg-count vm) n) - (error 'wrong-number-of-arguments + (error 'arg:wrong-number-of-arguments :given-nargs (vm-arg-count vm) :max-nargs n))) (incf ip)) ((#.m:check-arg-count->=) (let ((n (next-code))) (unless (>= (vm-arg-count vm) n) - (error 'wrong-number-of-arguments + (error 'arg:wrong-number-of-arguments :given-nargs (vm-arg-count vm) :min-nargs n))) (incf ip)) ((#.m:check-arg-count-=) (let ((n (next-code))) (unless (= (vm-arg-count vm) n) - (error 'wrong-number-of-arguments + (error 'arg:wrong-number-of-arguments :given-nargs (vm-arg-count vm) :min-nargs n :max-nargs n))) (incf ip)) @@ -347,7 +306,7 @@ ((< arg-index more-start) (cond ((= arg-index (1- more-start))) ((= arg-index (- more-start 2)) - (error 'odd-keywords)) + (error 'arg:odd-keywords)) (t (error "BUG! This can't happen!")))) (let ((key (stack (1- arg-index)))) @@ -367,7 +326,7 @@ (when (and (not (or (logbitp 7 key-count-info) allow-other-keys-p)) unknown-keys) - (error 'unrecognized-keyword-argument + (error 'arg:unrecognized-keyword-argument :unrecognized-keywords unknown-keys))) (incf ip)) ((#.m:save-sp) From 08b4938f08d6be6026e6980e7084402ba79448bf Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 09:29:30 -0400 Subject: [PATCH 20/32] Link only in global environments --- compile.lisp | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/compile.lisp b/compile.lisp index 60c170c..1a3c359 100644 --- a/compile.lisp +++ b/compile.lisp @@ -665,7 +665,10 @@ ;;; As CL:COMPILE, but doesn't mess with function bindings. (defun compile (lambda-expression &optional env (m:*client* m:*client*)) - (link-function (compile-into (make-cmodule) lambda-expression env) env)) + (link-function (compile-into (make-cmodule) lambda-expression env) + (if (lexical-environment-p env) + (global-environment env) + env))) ;;; As CL:EVAL. (defun eval (form &optional env (m:*client* m:*client*)) @@ -1689,16 +1692,13 @@ ;; Now replace the cfunctions in the cmodule literal vector with ;; real bytecode functions. ;; Also replace the load-time-value infos with the evaluated forms. - (let ((genv - ;; Obviously anything we're linking is global. - (if (lexical-environment-p env) - (global-environment env) - env))) - (map-into literals - (lambda (info) (load-literal-info client info genv)) - cmodule-literals))) + (map-into literals + (lambda (info) (load-literal-info client info env)) + cmodule-literals)) (values)) +;;; Given a cfunction, link constants and return an actual function. +;;; ENV must be a global environment. (defun link-function (cfunction env) (link-load (cfunction-cmodule cfunction) env) (cfunction-info cfunction)) From f1247bbfa8a5f11aeecc974ee2144cafa049f246 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 13:59:39 -0400 Subject: [PATCH 21/32] Make MACROLET work regardless of environment See long comment/apologia in parse-macro.lisp. --- arg-conditions.lisp | 3 +- cmpltv.lisp | 8 +- compile.lisp | 11 ++- cvm.asd | 4 +- parse-macro.lisp | 216 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 234 insertions(+), 8 deletions(-) create mode 100644 parse-macro.lisp diff --git a/arg-conditions.lisp b/arg-conditions.lisp index 23752b6..4d2cffe 100644 --- a/arg-conditions.lisp +++ b/arg-conditions.lisp @@ -2,7 +2,8 @@ (:use #:cl) (:export #:argument-error #:wrong-number-of-arguments #:odd-keywords - #:unrecognized-keyword-argument)) + #:unrecognized-keyword-argument) + (:export #:parse-macro)) (in-package #:cvm.argparse) diff --git a/cmpltv.lisp b/cmpltv.lisp index 9543060..ba8f887 100644 --- a/cmpltv.lisp +++ b/cmpltv.lisp @@ -1,6 +1,7 @@ (defpackage #:cvm.compile-file (:use #:cl) - (:local-nicknames (#:cmp #:cvm.compile)) + (:local-nicknames (#:cmp #:cvm.compile) + (#:arg #:cvm.argparse)) (:shadow #:compile-file #:macroexpand-1 #:macroexpand) (:export #:with-constants #:ensure-constant #:add-constant #:find-constant-index) @@ -1267,9 +1268,10 @@ (dolist (binding bindings) (let* ((name (car binding)) (lambda-list (cadr binding)) (body (cddr binding)) - (eform (ecclesia:parse-macro name lambda-list body env)) (aenv (cmp:lexenv-for-macrolet env)) - (expander (cmp:compile eform aenv)) + (eform (arg:parse-macro name lambda-list body aenv + #'cmp:compile)) + (expander (cl:compile nil eform)) (info (cmp:make-local-macro name expander))) (push (cons name info) macros))) (bytecode-compile-toplevel-locally diff --git a/compile.lisp b/compile.lisp index 1a3c359..3506c78 100644 --- a/compile.lisp +++ b/compile.lisp @@ -1,6 +1,7 @@ (defpackage #:cvm.compile (:use #:cl) - (:local-nicknames (#:m #:cvm.machine)) + (:local-nicknames (#:m #:cvm.machine) + (#:arg #:cvm.argparse)) (:shadow #:compile #:eval #:constantp) (:export #:compile-into #:compile #:eval) ;; Compiler guts - used in cmpltv @@ -1247,8 +1248,12 @@ (loop with env = (lexenv-for-macrolet env) for (name lambda-list . body) in bindings for macro-lexpr - = (ecclesia:parse-macro name lambda-list body env) - for info = (make-local-macro name (compile macro-lexpr env)) + = (arg:parse-macro name lambda-list body env + #'compile) + ;; see comment in parse-macro for explanation + ;; as to how we're using the host here + for macrof = (cl:compile nil macro-lexpr) + for info = (make-local-macro name macrof) collect (cons name info)))) (compile-locally body (make-lexical-environment env :funs (append macros (funs env))) diff --git a/cvm.asd b/cvm.asd index d573820..4706654 100644 --- a/cvm.asd +++ b/cvm.asd @@ -10,9 +10,11 @@ :ieee-floats) ; compile-file :components ((:file "machine") (:file "arg-conditions") + (:file "parse-macro" :depends-on ("arg-conditions")) (:file "structures" :depends-on ("machine")) (:file "disassemble" :depends-on ("structures" "machine")) - (:file "compile" :depends-on ("structures" "machine")) + (:file "compile" :depends-on ("parse-macro" + "structures" "machine")) (:file "cmpltv" :depends-on ("compile")) (:file "vm" :depends-on ("arg-conditions" "disassemble" "structures" "machine")))) diff --git a/parse-macro.lisp b/parse-macro.lisp new file mode 100644 index 0000000..98a8b6b --- /dev/null +++ b/parse-macro.lisp @@ -0,0 +1,216 @@ +(in-package #:cvm.argparse) + +#| +Here's the skinny. +Any lisp compiler needs to handle MACROLET. To handle macrolet, a compiler needs to be able to take the code for the local macro definitions, evaluate them _at compile time_, and get an _actual function it can call_ for macroexpansion. Furthermore the local macro definitions must be evaluated in the environment a compiler is working with - because for example macrolet definitions can refer to macros defined in outer macrolets. +Plus, the local macro definitions have macro lambda lists, which can be quite complicated. When the macro runs it performs a complex destructuring operation that will in general involve complex loops and many function calls. +Traditionally, this all is accomplished with a function called PARSE-MACRO. PARSE-MACRO takes as input the macro definition (lambda-list, body, etc.). It returns a lambda expression. The compiler then evaluates this lambda expression in its environment to get the function. +This does not work for us. The reason lies in first class global environments. We want to support compilation in _any_ environment. If the environment contains MACROLET, compilation in it should work even if standard functions, macros, or even special operators are not available in that environment, or have different names, etc. Therefore, with the usual PARSE-MACRO approach, the form returned by PARSE-MACRO cannot contain any operators not intrinsic to evaluation, which means all you get is lambda forms - obviously not enough. +Instead, what we do is use a _host_ function as our macroexpander. The compiler calls PARSE-MACRO and gets back a lambda expression. This lambda expression is then evaluated in a null lexical environment _in the host_ (e.g., by CL:COMPILE or CL:EVAL, rather than anything necessarily CVM related). The resulting function parses the macro arguments _with host code_, and therefore it doesn't matter what environment the compiler is working with. +Of course, the actual macro body, as well as any default forms in the lambda list, must still be compiled by our compiler in the appropriate environment, rather than by the host. To accomplish this, PARSE-MACRO receives a callback, called COMPILER below. This is a function of two arguments, a lambda expression and a compiler environment. The function must compile the lambda in the environment and return a callable function. +And here's the really funky part: PARSE-MACRO then includes this function as a literal object in the expression it returns. So the expression will have code looking something like `(funcall # a b c)`. This lets the host function call our bytecode-compiled function even though they were compiled by completely different means in completely different kinds of environments. Literal functions are quite unusual in code, but since the macroexpander only needs to go through CL:COMPILE or CL:EVAL, and not CL:COMPILE-FILE (as macroexpanders are not dumped), this works out. +End result: a callable host function that does lambda list processing independently of bytecode anything, but still calls into the bytecode when semantics demand it. + +FIXME: Currently PARSE-MACRO still expects CL:BLOCK to be defined standardly. +|# + +;;; returns four values: +;;; 1) a list of bindings in the host +;;; 2) a list of variables to declare ignorable after those bindings +;;; 3) a list of arguments in the host to the cross function +;;; 4) a list of parameters for the cross function +(defun process-lambda-list (lambda-list compiler environment + target etarget toplevelp + &optional arguments parameters) + (let* ((bindings nil) (ignorables nil) + (arguments arguments) (parameters parameters) + (whole (ecclesia:whole lambda-list)) + (required (ecclesia:required lambda-list)) + (nreq (length required)) + (%optionals (ecclesia:optionals lambda-list)) + ;; we treat () and (&optional) the same. + (optionals (if (eq %optionals :none) nil %optionals)) + (nopt (length optionals)) + (rest (ecclesia:rest-body lambda-list)) + (restp (not (eq rest :none))) + (%keys (ecclesia:keys lambda-list)) + (keysp (not (eq %keys :none))) + (keys (if keysp %keys nil)) + (aokp (ecclesia:allow-other-keys lambda-list)) + (nmax (if (or keysp restp) nil (+ nreq nopt))) + (nargs (gensym "NARGS")) + (%aux (ecclesia:aux lambda-list)) + ;; and () and (&aux) the same + (aux (if (eq %aux :none) () %aux)) + (eparam (ecclesia:environment lambda-list))) + (labels + ((destructure (sub-lambda-list new-target-form) + (let ((targ (gensym "SUBARGS")) + ;; ecclesia sometimes returns lists + ;; and other times returns a LAMBDA-LIST object. + (sub-lambda-list + (etypecase sub-lambda-list + (list (ecclesia:parse-macro-lambda-list + sub-lambda-list)) + (ecclesia:lambda-list sub-lambda-list)))) + (push `(,targ ,new-target-form) bindings) + (push targ ignorables) + (multiple-value-bind (%binds %ign %args %params) + (process-lambda-list sub-lambda-list + compiler environment + targ etarget nil + arguments parameters) + (setf bindings (append (reverse %binds) bindings) + ignorables (append %ign ignorables) + arguments (reverse %args) + parameters (reverse %params))))) + (bind-presentp (listparam testf) + (if (null listparam) + ;; no -p provided: make one + (let ((-p (gensym "PRESENTP"))) + (push `(,-p ,testf) bindings) + -p) + ;; provided: use it and add to args etc + (let* ((-p (first listparam)) + (s-p (gensym (symbol-name -p)))) + (push `(,s-p ,testf) bindings) + (push s-p arguments) + (push -p parameters) + s-p))) + (bind (thing valuef) + (etypecase thing + ((or list ecclesia:lambda-list) + (destructure thing valuef)) + (symbol (let ((arg (gensym (symbol-name thing)))) + (push `(,arg ,valuef) bindings) + (push arg arguments) + (push thing parameters))))) + (default (form) + (let* ((rparams (reverse parameters)) + (rargs (reverse arguments)) + (lexpr `(lambda (,@rparams) + (declare (ignorable ,@rparams)) + ,form)) + (thunk (funcall compiler lexpr environment))) + `(funcall ,thunk ,@rargs)))) + ;; Environment parameter + (unless (eq eparam :none) (bind eparam etarget)) + ;; Whole parameter + (unless (eq whole :none) (bind whole target)) + ;; If we're at toplevel, take the rest + (when toplevelp + (let ((new-target (gensym "ARGS"))) + (push `(,new-target (rest ,target)) bindings) + (push new-target ignorables) + (setf target new-target))) + ;; Argument count + (push `(,nargs (length ,target)) bindings) + (push nargs ignorables) + ;; Push arg count checks if needed + ;; do this before evaluating any default forms, to be nice + (when (or (> nreq 0) nmax) + (let ((s (gensym "ARGCOUNT-CHECK"))) + (push `(,s + (unless (<= ,nreq ,nargs ,@(when nmax `(,nmax))) + (error 'wrong-number-of-arguments + :given-nargs ,nargs + :min-nargs ,nreq + ,@(when nmax `(:max-nargs ,nmax))))) + bindings) + (push s ignorables))) + (when keysp + (let ((s (gensym "EVEN-KEYS-CHECK"))) + (push `(,s (unless (evenp (- ,nargs ,(+ nreq nopt))) + (error 'odd-keywords))) + bindings) + (push s ignorables))) + ;; Required parameters + (loop for r in required + for i from 0 + do (bind r `(nth ,i ,target))) + ;; Optional parameters + (loop for (o dform . -p) in optionals + for i from nreq + for def = (default dform) + for s-p = (bind-presentp -p `(> ,nargs ,i)) + do (bind o `(if ,s-p (nth ,i ,target) ,def))) + ;; Rest parameter + (when restp (bind rest `(nthcdr ,(+ nreq nopt) ,target))) + ;; Key parameters + (when keysp + (let ((keytarg (gensym "KEYS"))) + (push `(,keytarg (nthcdr ,(+ nreq nopt) ,target)) bindings) + (push keytarg ignorables) + ;; check for unknown keys + (unless aokp + (let ((key-check (gensym "UNKNOWN-KEYS-CHECK")) + (valid-keys (mapcar #'caar keys))) + (push `(,key-check + (check-keywords ',valid-keys ,keytarg)) + bindings) + (push key-check ignorables))) + ;; Bind keys + (loop for ((kw var) dform . -p) in keys + for def = (default dform) + for s-p = (bind-presentp -p `(keyword-presentp ',kw ,keytarg)) + do (bind var `(if ,s-p (keyword-find ',kw ,keytarg) ,def))))) + ;; Aux parameters + (loop for (a dform) in aux + do (bind a (default dform)))) + (values (reverse bindings) ignorables + (reverse arguments) (reverse parameters)))) + +;;; Given the list of valid keys and a plist, signal an error if the +;;; plist contains an invalid keyword, while respecting +;;; that most fun of party tricks, :allow-other-keys. +;;; It is guaranteed that plist is a list with an even length. +;;; This function is only called when &allow-other-keys is +;;; not present. +;;; Return value undefined. +(defun check-keywords (valid-keys plist) + (loop with seen-aok = nil ; see 3.4.1.4.1.1 + for (key val) on plist by #'cddr + when (and (not seen-aok) (eq key :allow-other-keys)) + do (when val + ;; we're not doing anything else with the keywords, + ;; so just leave + (return-from check-keywords)) + (setf seen-aok t) + unless (or (member key valid-keys) + (eq key :allow-other-keys)) ; always valid + collect key into unknown-keys + finally (when unknown-keys + (error 'unrecognized-keyword-argument + :unrecognized-keywords unknown-keys)))) + +;;; Check if a keyword is in the plist. The plist is valid and has +;;; even length. +;;; Obviously it would be more efficient to check for presence and +;;; get the value in one go, but this file is messy enough as-is. +(defun keyword-presentp (key plist) + (loop for (pkey) on plist by #'cddr + when (eq key pkey) + return t + finally (return nil))) + +;;; Get the value associated with a keyword in the plist. +;;; The plist is valid and has even length. +(defun keyword-find (key plist) (getf plist key)) + +(defun parse-macro (name lambda-list body environment compiler) + (multiple-value-bind (bindings ignorables arguments parameters) + (process-lambda-list + (ecclesia:parse-macro-lambda-list lambda-list) + compiler environment 'form 'environment t) + (multiple-value-bind (body decls) + (alexandria:parse-body body :documentation t) + (let ((bodyf (funcall compiler + `(lambda (,@parameters) + ,@decls + (block ,name ,@body)) + environment))) + `(lambda (form environment) + (declare (ignorable environment)) + (let* (,@bindings) + (declare (ignorable ,@ignorables)) + (funcall ,bodyf ,@arguments))))))) From 5fae57ecd9254fa83697c2b502a0677c6d5e76fe Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 14:16:44 -0400 Subject: [PATCH 22/32] Rewrite MACROLET tests to not use ` It's this or hack the reader, and I don't want to hack the reader. It's nicer if the test files can just be loaded normally without whatever ASDF nonsense is required to use Eclector or something. Majority of macrolet tests now pass. Amazing. --- test/ansi/macrolet.lisp | 68 +++++++++++++++++++++++++++++++---------- 1 file changed, 52 insertions(+), 16 deletions(-) diff --git a/test/ansi/macrolet.lisp b/test/ansi/macrolet.lisp index 2b05ae3..b569b19 100644 --- a/test/ansi/macrolet.lisp +++ b/test/ansi/macrolet.lisp @@ -8,16 +8,20 @@ (5am:def-suite macrolet :in data-and-control-flow) (5am:in-suite macrolet) +;;;; WARNING: Do not use backquote in any code that will be passed +;;;; to CVM. It is read implementation-specifically, and these tests +;;;; are designed to run in limited first-class environments. + (deftest macrolet.1 (let ((z (list 3 4))) - (macrolet ((%m (x) `(car ,x))) + (macrolet ((%m (x) (list 'car x))) (let ((y (list 1 2))) (values (%m y) (%m z))))) 1 3) (deftest macrolet.2 (let ((z (list 3 4))) - (macrolet ((%m (x) `(car ,x))) + (macrolet ((%m (x) (list 'car x))) (let ((y (list 1 2))) (values (s:setf (%m y) 6) @@ -27,9 +31,9 @@ ;;; Inner definitions shadow outer ones (deftest macrolet.3 - (macrolet ((%m (w) `(cadr ,w))) + (macrolet ((%m (w) (list 'cadr w))) (let ((z (list 3 4))) - (macrolet ((%m (x) `(car ,x))) + (macrolet ((%m (x) (list 'car x))) (let ((y (list 1 2))) (values (%m y) (%m z) @@ -42,6 +46,8 @@ (deftest macrolet.4 (let ((x nil)) (macrolet ((%m (&whole w arg) + (list 'progn (list 'setq 'x (list 'quote w)) arg) + #+(or) `(progn (setq x (quote ,w)) ,arg))) (values (%m 1) x))) @@ -51,6 +57,8 @@ (deftest macrolet.5 (let ((x nil)) (macrolet ((%m ((&whole w arg)) + (list 'progn (list 'setq (list 'quote w)) arg) + #+(or) `(progn (setq x (quote ,w)) ,arg))) (values (%m (1)) x))) @@ -70,7 +78,9 @@ (deftest macrolet.7 (let ((x nil)) (macrolet ((%m ((&key a b)) - `(setq x (quote ,a)))) + (list 'setq 'x (list 'quote a)) + #+(or) + `(setq x (quote ,a)))) (values (%m (:a foo)) x (%m (:b bar)) x))) foo foo nil nil) @@ -79,6 +89,8 @@ (deftest macrolet.8 (let ((x nil)) (macrolet ((%m ((&key (a 10) b)) + (list 'setq 'x (list 'quote a)) + #+(or) `(setq x (quote ,a)))) (values (%m (:a foo)) x (%m (:b bar)) x))) @@ -99,6 +111,8 @@ (deftest macrolet.10 (let ((x nil)) (macrolet ((%m (b &rest a) + (list 'setq x (list 'quote a)) + #+(or) `(setq x (quote ,a)))) (values (%m a1 a2) x))) (a2) (a2)) @@ -107,6 +121,8 @@ (deftest macrolet.11 (let ((x nil)) (macrolet ((%m ((b &rest a)) + (list 'setq 'x (list 'quote a)) + #+(or) `(setq x (quote ,a)))) (values (%m (a1 a2)) x))) (a2) (a2)) @@ -115,6 +131,8 @@ (deftest macrolet.12 (let ((x nil)) (macrolet ((%m (&whole w b &rest a) + (list 'setq 'x (list 'quote (list a w))) + #+(or) `(setq x (quote ,(list a w))))) (values (%m a1 a2) x))) ((a2) (%m a1 a2)) @@ -164,13 +182,17 @@ (nil t)) (deftest macrolet.19 - (macrolet ((%m (x &optional y) `(quote (,x ,y)))) + (macrolet ((%m (x &optional y) + (list 'quote (list x y)) + #+(or) `(quote (,x ,y)))) (values (%m 1) (%m 2 3))) (1 nil) (2 3)) (deftest macrolet.20 - (macrolet ((%m (x &optional (y 'a)) `(quote (,x ,y)))) + (macrolet ((%m (x &optional (y 'a)) + (list 'quote (list x y)) + #+(or) `(quote (,x ,y)))) (values (%m 1) (%m 2 3))) (1 a) (2 3)) @@ -179,13 +201,17 @@ ;;; is required to be T (not just true) if the parameter is present. ;;; See section 3.4.4.1.2 (deftest macrolet.21 - (macrolet ((%m (x &optional (y 'a y-p)) `(quote (,x ,y ,y-p)))) + (macrolet ((%m (x &optional (y 'a y-p)) + (list 'quote (list x y y-p)) + #+(or) `(quote (,x ,y ,y-p)))) (values (%m 1) (%m 2 3))) (1 a nil) (2 3 t)) (deftest macrolet.22 - (macrolet ((%m (x &optional ((y z) '(2 3))) `(quote (,x ,y ,z)))) + (macrolet ((%m (x &optional ((y z) '(2 3))) + (list 'quote (list x y z)) + #+(or) `(quote (,x ,y ,z)))) (values (%m a) (%m a (b c)))) @@ -194,7 +220,8 @@ (deftest macrolet.22a (macrolet ((%m (x &optional ((y z) '(2 3) y-z-p)) - `(quote (,x ,y ,z ,y-z-p)))) + (list 'quote (list x y z y-z-p)) + #+(or)`(quote (,x ,y ,z ,y-z-p)))) (values (%m a) (%m a (b c)))) @@ -202,7 +229,7 @@ (a b c t)) (deftest macrolet.23 - (macrolet ((%m (&rest y) `(quote ,y))) + (macrolet ((%m (&rest y) (list 'quote y) #+(or) `(quote ,y))) (%m 1 2 3)) (1 2 3)) @@ -210,12 +237,16 @@ ;;; 'a destructuring pattern that matches the rest of the list.' (deftest macrolet.24 - (macrolet ((%m (&rest (x y z)) `(quote (,x ,y ,z)))) + (macrolet ((%m (&rest (x y z)) + (list 'quote (list x y z)) + #+(or) `(quote (,x ,y ,z)))) (%m 1 2 3)) (1 2 3)) (deftest macrolet.25 - (macrolet ((%m (&body (x y z)) `(quote (,x ,y ,z)))) + (macrolet ((%m (&body (x y z)) + (list 'quote (list x y z)) + #+(or) `(quote (,x ,y ,z)))) (%m 1 2 3)) (1 2 3)) @@ -266,7 +297,9 @@ (10 nil)) (deftest macrolet.30 - (macrolet ((%m ((&key a) &key (b a)) `(quote (,a ,b)))) + (macrolet ((%m ((&key a) &key (b a)) + (list 'quote (list a b)) + #+(or) `(quote (,a ,b)))) (values (%m ()) (%m (:a 1)) (%m () :b 2) @@ -284,7 +317,8 @@ (deftest macrolet.31 (macrolet ((%m (&key ((:a (b c)) '(3 4) a-p)) - `(quote (,(notnot a-p) ,c ,b)))) + (list 'quote (list (s:notnot a-p) c b)) + #+(or) `(quote (,(s:notnot a-p) ,c ,b)))) (values (%m :a (1 2)) (%m :a (1 2) :a (10 11)) (%m))) @@ -345,7 +379,9 @@ ;;; &whole is followed by a destructuring pattern (see 3.4.4.1.2) (deftest macrolet.36 - (macrolet ((%m (&whole (m a b) c d) `(quote (,m ,a ,b ,c ,d)))) + (macrolet ((%m (&whole (m a b) c d) + (list 'quote (list m a b c d)) + #+(or) `(quote (,m ,a ,b ,c ,d)))) (%m 1 2)) (%m 1 2 1 2)) From dba861dc7203a0aae9fa716a09b9aa00b412f618 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 14:37:08 -0400 Subject: [PATCH 23/32] Fix special binding MACROLET tests For these tests the same variable needs to be bound inside and outside the macrolet, so the whole thing has to go through the test evaluator, not just the outer part. --- cvm.asd | 2 +- test/ansi/macrolet.lisp | 33 ++++++++++++++++++--------------- test/cross/sham.lisp | 4 ++-- test/native-sham.lisp | 3 +++ test/packages.lisp | 2 +- 5 files changed, 25 insertions(+), 19 deletions(-) diff --git a/cvm.asd b/cvm.asd index 4706654..437a140 100644 --- a/cvm.asd +++ b/cvm.asd @@ -28,7 +28,7 @@ :components ((:file "packages") (:file "suites" :depends-on ("packages")) (:file "rt" :depends-on ("packages")) - (:file "native-sham" :depends-on ("packages")) + (:file "native-sham" :depends-on ("rt" "packages")) (:module "ansi" :depends-on ("suites" "rt" "packages") ;; These can be loaded in any order. diff --git a/test/ansi/macrolet.lisp b/test/ansi/macrolet.lisp index b569b19..aa23818 100644 --- a/test/ansi/macrolet.lisp +++ b/test/ansi/macrolet.lisp @@ -428,35 +428,38 @@ (%x)) t) -(5am:test macrolet.43 +(deftest macrolet.43 (let ((*x-in-macrolet.43* nil)) (declare (special *x-in-macrolet.43*)) (let ((*f* #'(lambda () *x-in-macrolet.43*))) (declare (special *f*)) - (5am:is-false (ceval `(macrolet ((%m (*x-in-macrolet.43*) - (declare (special *f*)) - (funcall *f*))) - (%m t))))))) + (s:eval '(macrolet ((%m (*x-in-macrolet.43*) + (declare (special *f*)) + (funcall *f*))) + (%m t))))) + nil) -(5am:test macrolet.44 +(deftest macrolet.44 (let ((*x-in-macrolet.44* nil)) (declare (special *x-in-macrolet.44*)) (let ((*f* #'(lambda () *x-in-macrolet.44*))) (declare (special *f*)) - (5am:is (eql t (ceval `(macrolet ((%m (*x-in-macrolet.44*) - (declare (special *f* *x-in-macrolet.44*)) - (funcall *f*))) - (%m t)))))))) + (s:eval '(macrolet ((%m (*x-in-macrolet.44*) + (declare (special *f* *x-in-macrolet.44*)) + (funcall *f*))) + (%m t))))) + t) -(5am:test macrolet.45 +(deftest macrolet.45 (let ((*x-in-macrolet.45* nil)) (declare (special *x-in-macrolet.45*)) (let ((*f* #'(lambda () *x-in-macrolet.45*))) (declare (special *f*)) - (5am:is (eql t (ceval `(macrolet ((%m ((*x-in-macrolet.45*)) - (declare (special *f* *x-in-macrolet.45*)) - (funcall *f*))) - (%m (t))))))))) + (s:eval '(macrolet ((%m ((*x-in-macrolet.45*)) + (declare (special *f* *x-in-macrolet.45*)) + (funcall *f*))) + (%m (t)))))) + t) ;;; Macros are expanded in the appropriate environment diff --git a/test/cross/sham.lisp b/test/cross/sham.lisp index 21423f8..cf694e8 100644 --- a/test/cross/sham.lisp +++ b/test/cross/sham.lisp @@ -62,8 +62,8 @@ tagbody: () (loop for op in '(s:notnot) for f = (fdefinition op) do (setf (clostrum:fdefinition client environment op) f)) - (loop for op in '(s:macroexpand-1 s:macroexpand) - for cl in '( macroexpand-1 macroexpand) + (loop for op in '(s:macroexpand-1 s:macroexpand s:eval) + for cl in '( macroexpand-1 macroexpand eval) for f = (fdefinition op) do (setf (clostrum:fdefinition client environment op) f (clostrum:fdefinition client environment cl) f))) diff --git a/test/native-sham.lisp b/test/native-sham.lisp index 267785b..da1065b 100644 --- a/test/native-sham.lisp +++ b/test/native-sham.lisp @@ -49,6 +49,9 @@ (setq ever-expanded t form expansion) (return (values form ever-expanded)))))) +;;; used in e.g. MACROLET.43 +(setf (fdefinition 's:eval) #'ceval) + ;;; Macro used in tests of environments in system macros ;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP ;;; was being called in some system macros without the proper diff --git a/test/packages.lisp b/test/packages.lisp index 5e51413..71d97e4 100644 --- a/test/packages.lisp +++ b/test/packages.lisp @@ -1,7 +1,7 @@ (defpackage #:cvm.test.sham (:use) (:export #:expand-in-current-env #:notnot) - (:export #:macroexpand-1 #:macroexpand) + (:export #:macroexpand-1 #:macroexpand #:eval) (:export #:multiple-value-bind #:setf #:incf #:decf #:prog1 #:when #:unless #:return #:prog)) From 62a7b5962064ddcfd2b248b4ce614240317b554c Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 14:59:51 -0400 Subject: [PATCH 24/32] Localize weird cl:compile usage --- cmpltv.lisp | 9 ++++----- compile.lisp | 22 +++++++++++++++------- 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/cmpltv.lisp b/cmpltv.lisp index ba8f887..ff40670 100644 --- a/cmpltv.lisp +++ b/cmpltv.lisp @@ -1264,14 +1264,13 @@ (bytecode-compile-toplevel-progn body new-env)))) (defun bytecode-compile-toplevel-macrolet (bindings body env) - (let ((macros nil)) + (let ((macros nil) + (aenv (cmp:lexenv-for-macrolet env))) (dolist (binding bindings) (let* ((name (car binding)) (lambda-list (cadr binding)) (body (cddr binding)) - (aenv (cmp:lexenv-for-macrolet env)) - (eform (arg:parse-macro name lambda-list body aenv - #'cmp:compile)) - (expander (cl:compile nil eform)) + (expander (cmp:compute-macroexpander + name lambda-list body aenv)) (info (cmp:make-local-macro name expander))) (push (cons name info) macros))) (bytecode-compile-toplevel-locally diff --git a/compile.lisp b/compile.lisp index 3506c78..bdb7f71 100644 --- a/compile.lisp +++ b/compile.lisp @@ -7,7 +7,8 @@ ;; Compiler guts - used in cmpltv (:export #:add-specials #:extract-specials #:lexenv-for-macrolet #:make-lexical-environment #:make-local-macro #:make-symbol-macro - #:coerce-to-lexenv #:funs #:vars) + #:coerce-to-lexenv #:funs #:vars + #:compute-macroexpander) (:export #:var-info #:fun-info #:expand #:symbol-macro-expansion) (:export #:load-literal-info) (:export #:ltv-info #:ltv-info-form #:ltv-info-read-only-p) @@ -1242,17 +1243,24 @@ collect pair) :tags nil :blocks nil)) +;;; Given the arguments to parse-macro, return a macroexpander, +;;; i.e. an actual function. The environment must already be +;;; stripped by lexenv-for-macrolet (so that this can be done once +;;; for multiple definitions). +;;; Also used in cmpltv. +(defun compute-macroexpander (name lambda-list body env) + ;; see comment in parse-macro for explanation + ;; as to how we're using the host here + (cl:compile nil (arg:parse-macro name lambda-list body env + #'compile))) + (defmethod compile-special ((op (eql 'macrolet)) form env context) (let* ((bindings (second form)) (body (cddr form)) (macros (loop with env = (lexenv-for-macrolet env) for (name lambda-list . body) in bindings - for macro-lexpr - = (arg:parse-macro name lambda-list body env - #'compile) - ;; see comment in parse-macro for explanation - ;; as to how we're using the host here - for macrof = (cl:compile nil macro-lexpr) + for macrof = (compute-macroexpander + name lambda-list body env) for info = (make-local-macro name macrof) collect (cons name info)))) (compile-locally body (make-lexical-environment From dd8ab7aea86825e67417d27a3940178929d287b7 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 15:38:32 -0400 Subject: [PATCH 25/32] Fix lambda list default form environments Example previous breakage: (funcall (let ((x 0)) (lambda (&optional (x x)) x))) would return an internal unboundedness marker. This is because the default form, X, was compiled in an environment in which all the parameters were already bound. compile-with-lambda-list is getting really unwieldly. --- compile.lisp | 53 +++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 48 insertions(+), 5 deletions(-) diff --git a/compile.lisp b/compile.lisp index bdb7f71..840e579 100644 --- a/compile.lisp +++ b/compile.lisp @@ -1353,7 +1353,9 @@ (max-count (+ min-count optional-count)) (key-count (length keys)) (more-p (or rest key-p)) - new-env (context context) + new-env ; will be the body environment + default-env ; environment for compiling default forms + (context context) (specials (extract-specials decls)) (special-binding-count 0) ;; An alist from optional and key variables to their local indices. @@ -1384,6 +1386,9 @@ (t (maybe-emit-encage (var-info var new-env) context)))) (setq new-env (add-specials (intersection specials required) new-env))) + ;; set the default env to have all the requireds bound, + ;; but don't put in the optionals (yet). + (setq default-env new-env) (unless (zerop optional-count) ;; Generate code to bind the provided optional args; unprovided args will ;; be initialized with the unbound marker. @@ -1461,11 +1466,31 @@ index supplied-var next-optional-label optional-special-p supplied-special-p - context new-env)) + context new-env + default-env)) + ;; set the default env for later bindings. + (let* ((ovar (cons optional-var + (var-info optional-var new-env))) + (svar (when supplied-var + (cons supplied-var + (var-info supplied-var new-env)))) + (newvars + (if svar (list svar ovar) (list ovar)))) + (setf default-env + (make-lexical-environment + default-env + :vars (append newvars (vars default-env))))) (when optional-special-p (incf special-binding-count)) (when supplied-special-p (incf special-binding-count)))))) ;; Generate defaulting code for key args, and special-bind them if necessary. (when key-p + ;; Bind the rest parameter in the default env, if existent. + (when rest + (let ((rvar (cons rest (var-info rest new-env))) + (old (vars default-env))) + (setf default-env + (make-lexical-environment + default-env :vars (cons rvar old))))) (do ((keys keys (rest keys)) (key-label (make-label) next-key-label) (next-key-label (make-label) (make-label))) @@ -1485,7 +1510,20 @@ (compile-optional/key-item key-var defaulting-form index supplied-var next-key-label key-special-p supplied-special-p - context new-env)) + context new-env + default-env)) + ;; set the default env for later bindings. + (let* ((ovar (cons key-var + (var-info key-var new-env))) + (svar (when supplied-var + (cons supplied-var + (var-info supplied-var new-env)))) + (newvars + (if svar (list svar ovar) (list ovar)))) + (setf default-env + (make-lexical-environment + default-env + :vars (append newvars (vars default-env))))) (when key-special-p (incf special-binding-count)) (when supplied-special-p (incf special-binding-count)))))) ;; Generate aux and the body as a let*. @@ -1497,7 +1535,7 @@ ;;; Compile an optional/key item and return the resulting environment ;;; and context. (defun compile-optional/key-item (var defaulting-form var-index supplied-var next-label - var-specialp supplied-specialp context env) + var-specialp supplied-specialp context env default-env) (flet ((default (suppliedp specialp var info) (cond (suppliedp (cond (specialp @@ -1506,7 +1544,12 @@ (t (maybe-emit-encage info context)))) (t - (compile-form defaulting-form env + ;; We compile in default-env but also context. + ;; The context already has space allocated for all + ;; the later lexical parameters, which have already + ;; been bound. Thus, we ensure that no bindings + ;; in the default form clobber later parameters. + (compile-form defaulting-form default-env (new-context context :receiving 1)) (cond (specialp (emit-special-bind context var)) From 8c45d6daea35f86d6a339a767ccb670279b709dc Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 15:44:11 -0400 Subject: [PATCH 26/32] Fix macrolet tests I made some mistakes whiles removing the backquotes. --- test/ansi/macrolet.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/ansi/macrolet.lisp b/test/ansi/macrolet.lisp index aa23818..0424e51 100644 --- a/test/ansi/macrolet.lisp +++ b/test/ansi/macrolet.lisp @@ -57,7 +57,7 @@ (deftest macrolet.5 (let ((x nil)) (macrolet ((%m ((&whole w arg)) - (list 'progn (list 'setq (list 'quote w)) arg) + (list 'progn (list 'setq 'x (list 'quote w)) arg) #+(or) `(progn (setq x (quote ,w)) ,arg))) @@ -111,7 +111,7 @@ (deftest macrolet.10 (let ((x nil)) (macrolet ((%m (b &rest a) - (list 'setq x (list 'quote a)) + (list 'setq 'x (list 'quote a)) #+(or) `(setq x (quote ,a)))) (values (%m a1 a2) x))) From 893b0f52c36e291082cc2077c1f892651d0f3e48 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 15:53:11 -0400 Subject: [PATCH 27/32] Fix overly special binding in optional/keyword parameters It checked for local specialness, which doesn't actually mean that a new binding should also be special. Failed ANSI's FLET.40. Also, the stuff about remaking optionals and keys as special that I deleted in this commit is now moot, because default forms are no longer compiled in new-env. --- compile.lisp | 33 ++++++++++----------------------- 1 file changed, 10 insertions(+), 23 deletions(-) diff --git a/compile.lisp b/compile.lisp index 840e579..04dfc4f 100644 --- a/compile.lisp +++ b/compile.lisp @@ -583,9 +583,6 @@ (defun constantp (symbol env) (typep (var-info symbol env) 'trucler:constant-variable-description)) -(defun specialp (symbol env) - (typep (var-info symbol env) 'trucler:special-variable-description)) - (defun globally-special-p (symbol env) (typep (var-info symbol env) 'trucler:global-special-variable-description)) @@ -1378,7 +1375,8 @@ (dolist (var required) ;; We account for special declarations in outer environments/globally ;; by checking the original environment - not our new one - for info. - (cond ((or (member var specials) (specialp var env)) + (cond ((or (member var specials) + (globally-special-p var env)) (let ((info (var-info var new-env))) (assemble-maybe-long context m:ref (frame-offset info)) (emit-special-bind context var)) @@ -1402,21 +1400,14 @@ ;; Add everything to opt-key-indices. (dolist (var optvars) (push (cons var (frame-offset (var-info var new-env))) - opt-key-indices)) - ;; Re-mark anything that's special in the outer context as such, - ;; so that default initforms properly treat them as special. - (let ((specials - (remove-if-not - (lambda (sym) (specialp sym env)) - optvars))) - (when specials - (setq new-env (add-specials specials new-env)))))) + opt-key-indices)))) (when rest (assemble-maybe-long context m:listify-rest-args max-count) (assemble-maybe-long context m:set (context-frame-end context)) (setf (values new-env context) (bind-vars (list rest) new-env context)) - (cond ((or (member rest specials) (specialp rest env)) + (cond ((or (member rest specials) + (globally-special-p rest env)) (assemble-maybe-long context m:ref (frame-offset (var-info rest new-env))) (emit-special-bind context rest) @@ -1438,11 +1429,7 @@ (bind-vars keyvars new-env context)) (dolist (var keyvars) (let ((info (var-info var new-env))) - (push (cons var (frame-offset info)) opt-key-indices))) - (let ((specials (remove-if-not (lambda (sym) (specialp sym env)) - keyvars))) - (when specials - (setq new-env (add-specials specials new-env)))))) + (push (cons var (frame-offset info)) opt-key-indices))))) ;; Generate defaulting code for optional args, and special-bind them ;; if necessary. (unless (zerop optional-count) @@ -1455,12 +1442,12 @@ (destructuring-bind (optional-var defaulting-form supplied-var) (first optionals) (let ((optional-special-p (or (member optional-var specials) - (specialp optional-var env))) + (globally-special-p optional-var env))) (index (cdr (assoc optional-var opt-key-indices))) (supplied-special-p (and supplied-var (or (member supplied-var specials) - (specialp supplied-var env))))) + (globally-special-p supplied-var env))))) (setf (values new-env context) (compile-optional/key-item optional-var defaulting-form index @@ -1501,11 +1488,11 @@ (declare (ignore key-name)) (let ((index (cdr (assoc key-var opt-key-indices))) (key-special-p (or (member key-var specials) - (specialp key-var env))) + (globally-special-p key-var env))) (supplied-special-p (and supplied-var (or (member supplied-var specials) - (specialp supplied-var env))))) + (globally-special-p supplied-var env))))) (setf (values new-env context) (compile-optional/key-item key-var defaulting-form index supplied-var next-key-label From 3870ea15e21439cbe5da51ca0ce4ac8c015d308c Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 18:08:03 -0400 Subject: [PATCH 28/32] compiler: actually read from cells when necessary without this, code like (let ((x 0)) ((lambda () (setq x 1))) x) will return a cell (!) instead of the actual value. --- compile.lisp | 1 + 1 file changed, 1 insertion(+) diff --git a/compile.lisp b/compile.lisp index 04dfc4f..b5440c8 100644 --- a/compile.lisp +++ b/compile.lisp @@ -714,6 +714,7 @@ (t (setf (closed-over-p info) t) (assemble context m:closure (closure-index info context)))) + (maybe-emit-cell-ref info context) (when (eql (context-receiving context) 't) (assemble context m:pop)))) From 32ee5d013ea51d1b712a6c31a58e12002406e2fe Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 18:08:48 -0400 Subject: [PATCH 29/32] cross VM: Fix NLX Not actually sure why I used catch originally. I mean obviously it's to avoid the nested VM calls thing the native VM does, but catch instead of block, I don't know. Plus I apparently just completely screwed it up so that NLX would never work. There was a problem (besides NLX just totally failing, that was the lack of GO) that didn't trip any of the ANSI tests I'm running: (let ((x 0)) (declare (special x)) (block nil (let ((x 1)) (declare (special x)) (return-from nil))) x) returned 1 instead of 0 because the dynenv stack wasn't getting undone. Also happened with the NLX version (wrap the block in a thunk). Need tests for this. --- Cross/vm.lisp | 37 +++++++++++++++++++++++++++++-------- 1 file changed, 29 insertions(+), 8 deletions(-) diff --git a/Cross/vm.lisp b/Cross/vm.lisp index 7555632..a54d0cb 100644 --- a/Cross/vm.lisp +++ b/Cross/vm.lisp @@ -107,13 +107,24 @@ (let ((cell (symbol-cell symbol global-cell))) (setf (car cell) new))) -(defvar *dynenv* nil) +(define-condition out-of-extent-unwind (control-error) + ()) + +(defun exit-to (vm entry-dynenv new-ip) + ;; Make sure the entry is still on the DE stack. + ;; If it is, reset the DE stack, and throw. + ;; Otherwise complain. + (let ((old-de-stack (member entry-dynenv (vm-dynenv-stack vm)))) + (when (null old-de-stack) + (error 'out-of-extent-unwind)) + (setf (vm-dynenv-stack vm) old-de-stack) + (throw (entry-dynenv-tag entry-dynenv) new-ip))) (defun instruction-trace (bytecode stack ip bp sp frame-size) (fresh-line *trace-output*) (let ((frame-end (+ bp frame-size)) ;; skip package prefixes on inst names. - (*package* (find-package "CVM/MACHINE"))) + (*package* (find-package "CVM.MACHINE"))) (prin1 (list (m:disassemble-instruction bytecode ip) bp sp @@ -185,6 +196,13 @@ (error "Invalid bytecode: Reached end")) (when trace (instruction-trace bytecode stack ip bp sp frame-size)) + ;; The catch is for NLX. Without NLX, a (go loop) at the + ;; bottom skips back up to the loop without setting IP. + ;; When something NLXs to this frame, we throw the new IP + ;; to the tag, set the IP, and then jump up to the loop. + ;; We use CATCH instead of BLOCK on the theory that BLOCK + ;; will have to allocate each loop, but well, I suspect + ;; CATCH will too generally. (setf ip (catch tag (ecase (code) @@ -380,10 +398,12 @@ :unrecognized-keywords unknown-keys))) (incf ip)) ((#.m:save-sp) - (setf (stack (+ bp (next-code))) sp) + (setf (stack (+ bp (next-code))) + (list sp (vm-dynenv-stack vm))) (incf ip)) ((#.m:restore-sp) - (setf sp (stack (+ bp (next-code)))) + (setf (values sp (vm-dynenv-stack vm)) + (values-list (stack (+ bp (next-code))))) (incf ip)) ((#.m:entry) (let ((de (make-entry-dynenv tag))) @@ -422,13 +442,13 @@ (return)) ((#.m:exit-8) (incf ip (next-code-signed)) - (throw (entry-dynenv-tag (spop)) ip)) + (exit-to vm (spop) ip)) ((#.m:exit-16) (incf ip (next-code-signed-16)) - (throw (entry-dynenv-tag (spop)) ip)) + (exit-to vm (spop) ip)) ((#.m:exit-24) (incf ip (next-code-signed-24)) - (throw (entry-dynenv-tag (spop)) ip)) + (exit-to vm (spop) ip)) ((#.m:entry-close) (pop (vm-dynenv-stack vm)) (incf ip)) @@ -502,7 +522,8 @@ (#.m:const (spush (constant (+ (next-code) (ash (next-code) 8)))) (incf ip))))) - (go loop))))))) + (go loop))) + (go loop))))) (defmethod m:compute-instance-function ((client cvm.cross:client) (closure m:bytecode-closure)) From 8a85b90744f49de20757f5256c4e51e244667fdd Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 18:26:27 -0400 Subject: [PATCH 30/32] Dummy out CL:CATCH test for the moment The compiler should be doing the right thing but the instructions are untested (so far). --- test/ansi/tagbody.lisp | 1 + 1 file changed, 1 insertion(+) diff --git a/test/ansi/tagbody.lisp b/test/ansi/tagbody.lisp index 30db45d..07d8e9a 100644 --- a/test/ansi/tagbody.lisp +++ b/test/ansi/tagbody.lisp @@ -95,6 +95,7 @@ result) 10) +#+(or) ; catch not working yet (deftest tagbody.11 (let (result) (tagbody From dbc60d7765952a1f9e621f685a978793b82916f1 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 20:30:45 -0400 Subject: [PATCH 31/32] Skip ecclesia-broken macrolet tests, restore some others the restored ones were causing stack overflows (??) when I first ran the tests. Since I completely redid PARSE-MACRO those seem to have disappeared. --- test/ansi/macrolet.lisp | 90 ++++++++++++++++++++++------------------- 1 file changed, 48 insertions(+), 42 deletions(-) diff --git a/test/ansi/macrolet.lisp b/test/ansi/macrolet.lisp index 0424e51..48a0b90 100644 --- a/test/ansi/macrolet.lisp +++ b/test/ansi/macrolet.lisp @@ -65,10 +65,11 @@ 1 (1)) ;;; key parameter -#+(or) (deftest macrolet.6 (let ((x nil)) (macrolet ((%m (&key (a 'xxx) b) + (list 'setq 'x (list 'quote a)) + #+(or) `(setq x (quote ,a)))) (values (%m :a foo) x (%m :b bar) x))) @@ -97,10 +98,11 @@ foo foo 10 10) ;;; keyword parameter with supplied-p parameter -#+(or) (deftest macrolet.9 (let ((x nil)) (macrolet ((%m (&key (a 'xxx a-p) b) + (list 'setq 'x (list 'quote (list a (not (not a-p))))) + #+(or) `(setq x (quote ,(list a (not (not a-p))))))) (values (%m :a foo) x (%m :b bar) x))) @@ -169,15 +171,15 @@ collect s) nil) -#+(or) (deftest macrolet.17 - (macrolet ((%m (&key (a t)) `(quote ,a))) + (macrolet ((%m (&key (a t)) (list 'quote a))) (%m :a nil)) nil) -#+(or) (deftest macrolet.18 - (macrolet ((%m (&key (a t a-p)) `(quote (,a ,(notnot a-p))))) + (macrolet ((%m (&key (a t a-p)) + (list 'quote (list a (s:notnot a-p))) + #+(or) `(quote (,a ,(s:notnot a-p))))) (%m :a nil)) (nil t)) @@ -236,39 +238,41 @@ ;;; According to 3.4.4.1.2, the entity following &rest is ;;; 'a destructuring pattern that matches the rest of the list.' -(deftest macrolet.24 - (macrolet ((%m (&rest (x y z)) - (list 'quote (list x y z)) - #+(or) `(quote (,x ,y ,z)))) - (%m 1 2 3)) - (1 2 3)) - -(deftest macrolet.25 - (macrolet ((%m (&body (x y z)) - (list 'quote (list x y z)) - #+(or) `(quote (,x ,y ,z)))) - (%m 1 2 3)) - (1 2 3)) +(5am:test macrolet.24 + (5am:skip "Ecclesia considers this invalid syntax") + #+(or) + (is-values-eval (macrolet ((%m (&rest (x y z)) + (list 'quote (list x y z)) + #+(or) `(quote (,x ,y ,z)))) + (%m 1 2 3)) + (1 2 3))) + +(5am:test macrolet.25 + (5am:skip "Ecclesia considers this invalid syntax") + #+(or) + (is-values-eval (macrolet ((%m (&body (x y z)) + (list 'quote (list x y z)) + #+(or) `(quote (,x ,y ,z)))) + (%m 1 2 3)) + (1 2 3))) ;;; More key parameters -#+(or) (deftest macrolet.26 - (macrolet ((%m (&key ((:a b))) `(quote ,b))) + (macrolet ((%m (&key ((:a b))) (list 'quote b))) (values (%m) (%m :a x))) nil x) -#+(or) (deftest macrolet.27 - (macrolet ((%m (&key ((:a (b c)))) `(quote (,c ,b)))) + (macrolet ((%m (&key ((:a (b c)))) (list 'quote (list c b)))) (%m :a (1 2))) (2 1)) -#+(or) (deftest macrolet.28 - (macrolet ((%m (&key ((:a (b c)) '(3 4))) `(quote (,c ,b)))) + (macrolet ((%m (&key ((:a (b c)) '(3 4))) + (list 'quote (list c b)))) (values (%m :a (1 2)) (%m :a (1 2) :a (10 11)) (%m))) @@ -276,9 +280,8 @@ (2 1) (4 3)) -#+(or) (deftest macrolet.29 - (macrolet ((%m (&key a (b a)) `(quote (,a ,b)))) + (macrolet ((%m (&key a (b a)) (list 'quote (list a b)))) (values (%m) (%m :a 1) (%m :b 2) @@ -328,9 +331,8 @@ ;;; Allow-other-keys tests -#+(or) (deftest macrolet.32 - (macrolet ((%m (&key a b c) `(quote (,a ,b ,c)))) + (macrolet ((%m (&key a b c) (list 'quote (list a b c)))) (values (%m :allow-other-keys nil) (%m :a 1 :allow-other-keys nil) @@ -345,9 +347,9 @@ (3 2 1) (3 2 1)) -#+(or) (deftest macrolet.33 - (macrolet ((%m (&key allow-other-keys) `(quote ,allow-other-keys))) + (macrolet ((%m (&key allow-other-keys) + (list 'quote allow-other-keys))) (values (%m) (%m :allow-other-keys nil) @@ -366,9 +368,9 @@ :good :good) -#+(or) (deftest macrolet.35 - (macrolet ((%m (&key a b &allow-other-keys) `(quote (,a ,b)))) + (macrolet ((%m (&key a b &allow-other-keys) + (list 'quote (list a b)))) (values (%m :a 1) (%m :foo t :b 2) @@ -378,12 +380,14 @@ (1 2)) ;;; &whole is followed by a destructuring pattern (see 3.4.4.1.2) -(deftest macrolet.36 - (macrolet ((%m (&whole (m a b) c d) - (list 'quote (list m a b c d)) - #+(or) `(quote (,m ,a ,b ,c ,d)))) - (%m 1 2)) - (%m 1 2 1 2)) +(5am:test macrolet.36 + (5am:skip "Ecclesia considers this invalid syntax") + #+(or) + (is-values-eval (macrolet ((%m (&whole (m a b) c d) + (list 'quote (list m a b c d)) + #+(or) `(quote (,m ,a ,b ,c ,d)))) + (%m 1 2)) + (%m 1 2 1 2))) ;;; Macro names are shadowed by local functions @@ -405,9 +409,11 @@ ;;; Test for bug that showed up in sbcl -(deftest macrolet.39 - (macrolet ((%m (()) :good)) (%m ())) - :good) +(5am:test macrolet.39 + (5am:skip "Ecclesia considers this invalid syntax (probably incorrectly)") + #+(or) + (is-values-eval (macrolet ((%m (()) :good)) (%m ())) + :good)) ;;; Test that macrolets accept declarations From f9cc9d4b95dfedf461f65b6a15a672d0cf4401d0 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 30 Sep 2023 21:09:56 -0400 Subject: [PATCH 32/32] Automate tests on github --- .github/workflows/test.yml | 66 ++++++++++++++++++++++++++++++++++++++ test/cross/script.lisp | 36 +++++++++++++++++++++ test/script.lisp | 33 +++++++++++++++++++ 3 files changed, 135 insertions(+) create mode 100644 .github/workflows/test.yml create mode 100644 test/cross/script.lisp create mode 100644 test/script.lisp diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml new file mode 100644 index 0000000..1308836 --- /dev/null +++ b/.github/workflows/test.yml @@ -0,0 +1,66 @@ +name: Test + +on: + workflow_dispatch: + push: + branches: [ main ] + pull_request: + +jobs: + test: + name: ${{ matrix.host }} / ${{ matrix.mode }} + + defaults: + run: + shell: bash -l {0} + + strategy: + fail-fast: false + matrix: + host: + - sbcl # non-sbcl hosts would require more changes below + mode: + - native + - cross + + runs-on: ubuntu-22.04 + + steps: + - name: Install SBCL + if: matrix.host == 'sbcl' + run: | + sudo apt-get update + sudo apt install -y sbcl + + - name: Install Quicklisp + run: | + curl -kLO https://beta.quicklisp.org/quicklisp.lisp + sbcl --non-interactive --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" --eval "(ql-util:without-prompting (ql:add-to-init-file))" + + - name: Checkout repository + uses: actions/checkout@v4 + with: + path: cvm + +# Clostrum is not in Quicklisp as of now, so get it from github. + + - name: Checkout Clostrum + uses: actions/checkout@v4 + with: + repository: s-expressionists/Clostrum + path: Clostrum + + - name: Configure ASDF to find everything + run: | + mkdir -p $HOME/.config/common-lisp/source-registry.conf.d + echo "(:TREE #P\"${{ github.workspace }}/\")" > $HOME/.config/common-lisp/source-registry.conf.d/cvm.conf + + - name: Run native client tests + if: matrix.mode == 'native' + run: | + sbcl --load "${{ github.workspace }}/cvm/test/script.lisp" + + - name: Run cross client tests + if: matrix.mode == 'cross' + run: | + sbcl --load "${{ github.workspace }}/cvm/test/cross/script.lisp" diff --git a/test/cross/script.lisp b/test/cross/script.lisp new file mode 100644 index 0000000..b048097 --- /dev/null +++ b/test/cross/script.lisp @@ -0,0 +1,36 @@ +;;; This script is used by the github automation to run the tests. +;;; You can also use it yourself: just load this file. SBCL will quit +;;; with exit status based on whether everything passed. + +(ql:quickload '(:cvm/test/cross :clostrum-basic)) + +(defpackage #:cvm.test.script + (:use #:cl)) + +(in-package #:cvm.test.script) + +;;; from ANSI tests +(defun exit (successp &aux (code (if successp 0 1))) + #+abcl (ext:quit :status code) + #+acl (excl:exit code :no-unwind t :quiet t) + #+ccl (ccl:quit code) + #+cmucl (handler-case (ext:quit nil code) + ;; Only the most recent versions of cmucl support an exit code. + ;; If it doesn't, we get a program error (wrong number of args), + ;; so catch that and just call quit without the arg. + (program-error () + (ext:quit))) + #+(or clasp clisp ecl) (ext:quit code) + #+gcl (lisp:quit code) + #+lispworks (lispworks:quit :status code :ignore-errors-p t) + #+sbcl (sb-ext:exit :code code)) + +(defun test () + (cvm.cross.vm:initialize-vm 20000) + (let* ((rte (make-instance 'clostrum-basic:run-time-environment)) + (ce (make-instance 'clostrum-basic:compilation-environment + :parent rte))) + (cvm.test.cross:fill-environment rte) + (exit (cvm.test.cross:run! ce)))) + +(test) diff --git a/test/script.lisp b/test/script.lisp new file mode 100644 index 0000000..fe3de6f --- /dev/null +++ b/test/script.lisp @@ -0,0 +1,33 @@ +;;; This script is used by the github automation to run the tests. +;;; You can also use it yourself: just load this file. SBCL will quit +;;; with exit status based on whether everything passed. + +(ql:quickload :cvm/test) + +(defpackage #:cvm.test.script + (:use #:cl)) + +(in-package #:cvm.test.script) + +;;; from ANSI tests +(defun exit (successp &aux (code (if successp 0 1))) + #+abcl (ext:quit :status code) + #+acl (excl:exit code :no-unwind t :quiet t) + #+ccl (ccl:quit code) + #+cmucl (handler-case (ext:quit nil code) + ;; Only the most recent versions of cmucl support an exit code. + ;; If it doesn't, we get a program error (wrong number of args), + ;; so catch that and just call quit without the arg. + (program-error () + (ext:quit))) + #+(or clasp clisp ecl) (ext:quit code) + #+gcl (lisp:quit code) + #+lispworks (lispworks:quit :status code :ignore-errors-p t) + #+sbcl (sb-ext:exit :code code)) + +(defun test () + (cvm.vm:initialize-vm 20000) + ;; won't work outside SBCL + (exit (cvm.test:run! nil (make-instance 'trucler-native-sbcl:client)))) + +(test)