Skip to content

Commit

Permalink
Many bug fixes - now storable-functions can store unsafe LET* macros.
Browse files Browse the repository at this point in the history
  • Loading branch information
@jessymilare
jessymilare committed May 7, 2016
1 parent 56406dc commit 7340971
Show file tree
Hide file tree
Showing 8 changed files with 99 additions and 70 deletions.
23 changes: 0 additions & 23 deletions cl-store+functions-tests.asd
View file

This file was deleted.

2 changes: 1 addition & 1 deletion cl-store+functions.asd
View file
Expand Up @@ -10,7 +10,7 @@

(defsystem-connection cl-store+functions
:name "cl-store+functions"
:version "0.0.2"
:version "0.0.3"
:maintainer "Jéssica Milaré"
:author "Jéssica Milaré"
:licence "MIT style"
Expand Down
74 changes: 53 additions & 21 deletions src/macros.lisp
View file
Expand Up @@ -9,24 +9,54 @@

(macrolet
((def (name type)
`(defmacro ,name (vars &body body)
(let ((variables (mapcar #'ensure-car vars)))
`(defmacro ,name (vars &body body &environment env)
(declare (ignorable env))
(let* ((vars (mapcar #'ensure-list vars))
(variables (mapcar #'car vars))
(vars
,(if (eq type 'let)
;; In LET, nothing left to do
'vars
;; In LET*, we have to compute a new lexical-environment
;; for each variable (upfrom the second one)
`(loop for (var value) in vars
collect var into vars-until-now
if (and vars-until-now
(needs-lexenv-p value ,'env))
collect (let ((vars-to-bind (butlast vars-until-now)))
`(lexical-environment
(make-instance
'let-closure-info :type 'let*
:environment lexical-environment
:variables
',,'(let ((length (length vars-to-bind)))
(assert (equal (subseq variables 0 length)
vars-to-bind))
(setf vars-until-now nil)
(setf variables (subseq variables length))
vars-to-bind)
:values-accessor
,(generate-closure-values-accessor vars-to-bind)
:declarations nil)))
collect (list var value)))))
(multiple-value-bind (body declarations) (parse-body body)
()
`(,',type ,,'vars
(let ((lexical-environment
(make-instance
'let-closure-info :type 'let*
(let ,(if (needs-lexenv-p `(progn ,@,'body) env)
`((lexical-environment
(make-instance
'let-closure-info :type 'let*
; no need for let since values will
; already be known by restorage time
:environment lexical-environment
:variables ',,'variables
:values-accessor
,(generate-closure-values-accessor variables)
:declarations
',,'(mappend #'cdr declarations))))
,@,'declarations
,@,'body)))))))
:environment lexical-environment
:variables ',,'variables
:values-accessor
,(generate-closure-values-accessor variables)
:declarations
',,'(mappend #'cdr declarations))))
nil)
,@,'declarations
,@,'body)))))))
(def st-let let)
(def st-let* let*))

Expand Down Expand Up @@ -54,7 +84,7 @@

(macrolet
((def (name type)
`(defmacro ,name (fspecs &body body)
`(defmacro ,name (fspecs &body body &environment env)
(let* ((func-names (mapcar #'first fspecs))
(info-names (mapcar #'(lambda (func-name)
(gensym (symbol-name func-name)))
Expand All @@ -69,13 +99,15 @@
(multiple-value-bind (body declarations) (parse-body body)
`(let ,(mapcar #'list info-names infos)
(,',type ,fspecs
(let ((lexical-environment
(make-instance
'flet-closure-info :type ',',type
:environment lexical-environment
:functions (list ,@info-names)
:declarations
',,'(mappend #'cdr declarations))))
(let ,(if (or ,(eq type 'labels)
(needs-lexenv-p `(progn ,@,'body) env))
`((lexical-environment
(make-instance
'flet-closure-info :type ',',type
:environment lexical-environment
:functions (list ,@info-names)
:declarations
',,'(mappend #'cdr declarations)))))
;; Label functions may depend on the entire
;; labels form.
;; Flet functions, on the other hand, don't.
Expand Down
4 changes: 2 additions & 2 deletions src/storage.lisp
View file
Expand Up @@ -15,8 +15,8 @@
;;; The instances of class "function-referrer" are created to be stored instead
;;; of the functions; each instance contains the root of the environment tree
;;; and the function-info instance associated with the function.
;;; Unless something really goes wrong, right after restorage of a instance of
;;; "function-referrence", the entire environment tree will be available without
;;; Unless something really goes wrong, right after restorage of an instance of
;;; "function-referrer", the entire environment tree will be available without
;;; circularities from the root and then it will be possible to generate the code.

(in-package :storable-functions)
Expand Down
24 changes: 24 additions & 0 deletions src/utils.lisp
View file
Expand Up @@ -5,13 +5,37 @@

(in-package :storable-functions)

#+nil
(defun parse-body (body)
(loop for rest on body
for form = (car rest)
while (eq 'declare (first form))
collect form into declarations
finally (return (values rest declarations))))

(defun find-st-macro-in-tree (form env)
(when (consp form)
(let ((head (car form)))
(or (and (symbolp head)
(eq (symbol-package head) (find-package :storable-functions))
(macro-function head env))
(if (consp head)
(some (lambda (subform)
(find-st-macro-in-tree subform env))
form)
(multiple-value-bind (new-form expanded-p)
(ignore-errors (macroexpand-1 form env))
(if (and expanded-p
(not (member head '(function lambda)))
(not (equalp form new-form)))
(find-st-macro-in-tree new-form env)
(some (lambda (subform)
(find-st-macro-in-tree subform env))
(cdr form)))))))))

(defun needs-lexenv-p (form env)
(find-st-macro-in-tree form env))

(defmacro with-collector ((collector) &body body)
(with-gensyms (list last)
`(let ((,list nil) (,last nil))
Expand Down
3 changes: 2 additions & 1 deletion storable-functions-tests.asd
View file
Expand Up @@ -16,7 +16,8 @@
:description "Test system for Storable Functions."
:depends-on (storable-functions lift cl-store+functions cl-store-tests)
:components ((:module "tests"
:components ((:file "general")))))
:components ((:file "general")
(:file "cl-store-tests" :depends-on ("general"))))))

(defmethod perform ((op test-op)
(system (eql (find-system :storable-functions-tests))))
Expand Down
18 changes: 8 additions & 10 deletions tests/cl-store-tests.lisp
View file
Expand Up @@ -5,32 +5,30 @@

(in-package :storable-functions-tests)

(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package '(:cl-store+functions :cl-store)))

(defun run-cl-store+functions-tests (&rest args)
(apply #'run-tests :suite 'test-cl-store+functions args))

(defvar *test-file* #P".storable-functions.cls")

(deftestsuite test-cl-store+functions ()
((cl-store-test-file #P".cl-store+functions-test-file")
(cl-store-backend (find-backend 'cl-store+functions)))
((cl-store-test-file #P".cl-store+functions-test-file"))
(:teardown
(when (or (stringp cl-store-test-file) (pathnamep cl-store-test-file))
(ignore-errors (delete-file cl-store-test-file)))))

(addtest (test-cl-store+functions)
cl-store-compatibility-test
(with-backend cl-store-backend
(let ((cl-store-tests::*test-file* cl-store-test-file)
(with-backend 'cl-store+functions
(let ((cl-store-tests::*test-file* *test-file*)
(rt::*print-circle-on-failure* t)
(rt::*expected-failures* '(cl-store-tests::custom.1 cl-store-tests::nocirc.1)))
(format t "~&Initializing cl-store tests...~%")
(prog1 (rt:do-tests)
(format t "~&Finalized cl-store tests.~%")))))

(def-tester-for-standard-tests test-cl-store+functions ()
(with-backend cl-store-backend
(with-backend 'cl-store+functions
(let ((function-set (get-current-function-set)))
(run-prologue-test-code function-set)
(store function-set cl-store-test-file)
(run-current-test function-set (restore cl-store-test-file)))))
(store function-set *test-file*)
(run-current-test function-set (restore *test-file*)))))
21 changes: 9 additions & 12 deletions tests/general.lisp
View file
Expand Up @@ -4,17 +4,13 @@
;;; See the file license for license information.

(defpackage :storable-functions-tests
(:use :cl :alexandria :storable-functions :lift))
(:use :cl :alexandria :storable-functions :lift :cl-store+functions :cl-store))

(in-package :storable-functions-tests)

(defun run-all-tests (&rest args)
(apply #'run-cl-store+functions-tests args))

;;; The tests here test much more than they need to,
;;; but it is better to test too much than not testing enough.
;;; And each test I'll have to write only once, so, here they come...

(defmacro ensure=-funcall (func1 func2 &rest args)
"Ensures the functions func1 and func2 return values that are =."
`(ensure-same (funcall ,func1 ,@args) (funcall ,func2 ,@args)
Expand Down Expand Up @@ -47,18 +43,18 @@
form))
,function-set))
(run-prologue-test-code (,function-set-var)
(destructuring-bind ,function-vars ,function-set-var
(destructuring-bind ,function-vars (ensure-list ,function-set-var)
(declare (ignorable ,@function-vars))
,prologue-code))
(run-current-test (,function-set-var ,n-function-set-var)
(destructuring-bind ,function-vars ,function-set-var
(destructuring-bind ,function-vars (ensure-list ,function-set-var)
(destructuring-bind
,(mapcar
#'(lambda (var)
(symbolicate "N-"(symbol-name var))))
function-vars) ,n-function-set-var
,@current-body))))
,@body))))))
(symbolicate "N-"(symbol-name var)))
function-vars) (ensure-list ,n-function-set-var)
,@current-body))))
,@body))))))

(defmacro def-std-test (testname (function-vars function-set) prologue-code
&body body)
Expand Down Expand Up @@ -282,5 +278,6 @@
(fun (st (lambda (x)
(+ x a)))))
fun)))
(ensure-cases (x) (6 45 41 6 48 45 11 31 15 4)
nil
(ensure-cases (x) '(6 45 41 6 48 45 11 31 15 4)
(ensure-equal-funcall func n-func x)))

0 comments on commit 7340971

Please sign in to comment.