├── README.md ├── cl-store └── cl-store+functions.lisp ├── licence ├── src ├── classes.lisp ├── deflex.lisp ├── macros.lisp ├── package.lisp ├── storage.lisp └── utils.lisp ├── storable-functions.asd └── tests └── tests.lisp /README.md: -------------------------------------------------------------------------------- 1 | # Storable Functions 2 | ================== 3 | 4 | ## Warning: deprecated 5 | 6 | This library is buggy and deprecated. It turns out it is easier and better to create a serializer from scratch than providing extensions for other libraries on this matter. I've been working on a library that transforms objects (including functions) into a source code that creates a fresh copy of them. 7 | 8 | 9 | ## About 10 | 11 | Storable Functions aims to provide a simple and portable way to serialize functions. 12 | 13 | 14 | Take a look at [our wiki](https://github.com/jessymilare/storable-functions/wiki) for more information. -------------------------------------------------------------------------------- /cl-store/cl-store+functions.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; Copyright (c) 2009-2016 Jéssica Milaré 4 | ;;; See the file license for license information. 5 | 6 | (defpackage :cl-store+functions 7 | (:use :cl :cl-store :storable-functions :alexandria) 8 | (:export #:cl-store+functions)) 9 | 10 | (in-package :cl-store+functions) 11 | 12 | (defconstant +code-information-code+ 250) 13 | 14 | (defbackend cl-store+functions 15 | :magic-number 1025429561 16 | ;; cl-store+functions is meant to be compatible with cl-store 17 | :compatible-magic-numbers (1279478851 1395477571) 18 | :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1414745155 19 | 1349740876 1884506444 1347643724 1349732684 20 | 1953713219 1416850499 1395477571) 21 | :extends (cl-store) 22 | :fields ((restorers :accessor restorers 23 | :initform 24 | (let ((cl-store-backend (find-backend 'cl-store)) 25 | (hash-table (make-hash-table :size 100))) 26 | (maphash #'(lambda (k v) 27 | (setf (gethash k hash-table) v)) 28 | (restorers cl-store-backend)) 29 | (setf (gethash +code-information-code+ hash-table) 30 | 'code-information) 31 | hash-table)))) 32 | 33 | ;;; Now, tell me if it ain't a piece of cake to store functions in a file? 34 | ;;; It even leaves me time to take a little nap after doing this ;) 35 | 36 | (defstore-cl-store+functions (func function stream) 37 | (if-let ((obj (get-function-referrer func))) 38 | ;; A small hack. We don't want the backend-restore-object methods to 39 | ;; check circularities for obj since possible circularities for the 40 | ;; function "func" was already handled by the resolving-backend. 41 | ;; FIXME - This hack use internal information about cl-store 42 | ;; but no alternative was found - unless explictly call functions 43 | ;; store-type-object and restore-type-object. 44 | (cl-store::internal-store-object *current-backend* obj stream) 45 | ;; No information about the function was provided by the user 46 | ;; (e.g. macro st was not used) giving up to cl-store standard storable 47 | ;; methods (which stores the function name) 48 | (call-next-method))) 49 | 50 | (defstore-cl-store+functions (obj code-information stream) 51 | ;; store-code-info receives the object to be stored and a callback 52 | ;; which receives no arguments and should actually store the object. 53 | (cl-store::output-type-code +code-information-code+ stream) 54 | (store-code-info obj #'call-next-method)) 55 | 56 | (defrestore-cl-store+functions (code-information stream) 57 | ;; Another little hack. During storage, the method for code information used 58 | ;; call-next-method for storing the class. This means that the instance for 59 | ;; 'code-information does not count as a new referrenciable value, since 60 | ;; it's the same object restored by this method. 61 | ;; FIXME - see FIXME above. 62 | (let ((obj (cl-store::internal-restore-object 63 | *current-backend* (get-next-reader *current-backend* stream) 64 | stream))) 65 | ;; restore-code-info receives the object that was restored 66 | (restore-code-info obj))) 67 | 68 | (defmethod backend-store ((backend cl-store+functions) (stream stream) obj) 69 | ;; cl-store is a save / load objects library. 70 | ;; The storage / restorage of the objects are modular. 71 | ;; In this case, we need to encapsulate the storage to undo side effects. 72 | ;; and to fix some references (in resolving-backend style) 73 | ;; Elephant, for instance, would not use this macro at all. 74 | (with-storable-functions-storage () 75 | ;; Circular checking is REQUIRED - not only because the code of the 76 | ;; functions could contain gensyms. Closure internal representation 77 | ;; is not exactly circular, but it contains various references to the 78 | ;; same object, and these references are meant to be eq. 79 | (let ((cl-store:*check-for-circs* t)) 80 | (call-next-method)))) 81 | 82 | (defmethod backend-restore ((backend cl-store+functions) (stream stream)) 83 | (with-storable-functions-restorage () 84 | (let ((cl-store:*check-for-circs* t) 85 | (cl-store::*restorers* (restorers backend))) 86 | (call-next-method)))) 87 | -------------------------------------------------------------------------------- /licence: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009-2016 Jéssica Milaré 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The names of the authors and contributors may not be used to endorse 13 | or promote products derived from this software without specific prior 14 | written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND 17 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 20 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 24 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 25 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 26 | SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /src/classes.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; Copyright (c) 2009-2016 Jéssica Milaré 4 | ;;; See the file license for license information. 5 | 6 | (in-package :storable-functions) 7 | 8 | (defvar *storable-function-table* 9 | (tg:make-weak-hash-table :weakness :key :test #'eq :weakness-matters nil)) 10 | 11 | (defvar *id* 0) 12 | (defvar *restored-functions* 13 | (tg:make-weak-hash-table :weakness :key :test #'eq :weakness-matters nil)) 14 | 15 | ;;; We need to lock because we change the field values in storage / restorage. 16 | ;;; This is just for safety, because (I believe) there probably won't be 17 | ;;; concurrent accesses at all. That's why the lock is a global variable, 18 | ;;; and not a field inside each class instance. 19 | 20 | (defvar *storage-lock* 21 | (bt:make-recursive-lock "Storable Functions Storage Lock")) 22 | 23 | (declaim (inline get-function-info (setf get-function-info) rem-function-info)) 24 | 25 | (defun get-function-info (func) 26 | (gethash func *storable-function-table*)) 27 | 28 | (defun (setf get-function-info) (info func) 29 | (setf (gethash func *storable-function-table*) info)) 30 | 31 | (defun rem-function-info (func) 32 | (remhash func *storable-function-table*)) 33 | 34 | (defclass code-information () 35 | ((environment :initarg :environment :accessor info-environment 36 | :initform nil :type (or code-information null)))) 37 | 38 | (defun setting-info-value (info value) 39 | `(setf (gethash ',info *restored-functions*) ,value)) 40 | 41 | (defun get-info-value (info) 42 | (prog1 43 | (or (gethash info *restored-functions*) 44 | (progn 45 | (eval (generate-code info)) 46 | ;; If everything went ok, this should return a value now 47 | (gethash info *restored-functions*))) 48 | (remhash info *restored-functions*))) 49 | 50 | ;;; Functions 51 | 52 | (defclass function-info (code-information) 53 | ()) 54 | 55 | (defclass lambda-info (function-info) 56 | ((body :initarg :body :accessor info-body :type list) 57 | (lambda-list :initarg :lambda-list :accessor info-lambda-list :type list))) 58 | 59 | (defclass named-lambda-info (lambda-info) 60 | ((name :initarg :name :accessor info-name :type symbol))) 61 | 62 | (defclass function-call-info (function-info) 63 | ((function-name :initarg :function-name :accessor info-function-name 64 | :type symbol) 65 | (values :initarg :values :accessor info-values :type list))) 66 | 67 | (defclass quoted-function-info (function-info) 68 | ((body :initarg :body :accessor info-body :type list))) 69 | 70 | ;;; Closures 71 | 72 | (defclass closure-info (code-information) 73 | ((type :initarg :type :accessor info-type :type symbol) 74 | (children :accessor info-children-weak-list :type list 75 | :initform (new-weak-list)) 76 | (declarations :initarg :declarations :accessor info-declarations 77 | :type list))) 78 | 79 | (defclass let-closure-info (closure-info) 80 | ((values-accessor :initarg :values-accessor :accessor info-values-accessor 81 | :type function) 82 | (variables :initarg :variables :accessor info-variables :type list) 83 | (values :initarg :values :accessor info-values :type list))) 84 | 85 | (defclass flet-closure-info (closure-info) 86 | ((functions :initarg :functions :accessor info-functions :type list))) 87 | 88 | (defclass macro-closure-info (closure-info) 89 | ((macros :initarg :macros :accessor info-macros :type list))) 90 | 91 | (defmethod initialize-instance :after ((info code-information) &key) 92 | (let ((env (info-environment info))) 93 | (when (typep env 'closure-info) 94 | (setf (info-children-weak-list env) 95 | (pushnew-weak-list info (info-children-weak-list env)))))) 96 | 97 | (defmethod (setf info-environment) :before (environment (info code-information)) 98 | (when (slot-boundp info 'environment) 99 | (let ((env (info-environment info))) 100 | (when (typep env 'closure-info) 101 | (setf (info-children-weak-list env) 102 | (delete-weak-list info (info-children-weak-list env))))))) 103 | 104 | (defmethod (setf info-environment) :after (environment (info code-information)) 105 | (let ((env (info-environment info))) 106 | (when (typep env 'closure-info) 107 | (setf (info-children-weak-list env) 108 | (pushnew-weak-list info (info-children-weak-list env)))))) 109 | 110 | (defgeneric info-children (info)) 111 | 112 | (defmethod info-children ((info closure-info)) 113 | ;; We put weak pointers here because the children of a closure 114 | ;; are only kept for generating the child code. 115 | ;; If some child can be garbage-collected 116 | ;; it means its functions are not around anymore, 117 | ;; therefore the child don't need to be stored. 118 | (get-list-from-weak-list (info-children-weak-list info))) 119 | 120 | (defgeneric (setf info-children) (children info)) 121 | 122 | (defmethod (setf info-children) (children (info closure-info)) 123 | (set-weak-list (info-children-weak-list info) children)) 124 | 125 | ;;; Define locking methods for accessors. 126 | (macrolet ((def (method class) 127 | `(progn 128 | (defmethod ,method :around ((info ,class)) 129 | (bt:with-recursive-lock-held (*storage-lock*) 130 | (call-next-method))) 131 | (defmethod (setf ,method) :around (value (info ,class)) 132 | (bt:with-recursive-lock-held (*storage-lock*) 133 | (call-next-method)))))) 134 | (def info-values-accessor let-closure-info) 135 | (def info-values let-closure-info)) 136 | 137 | (defun find-root-info (info) 138 | (let ((par (and (slot-boundp info 'environment) 139 | (info-environment info)))) 140 | (if (null par) 141 | info 142 | (find-root-info par)))) 143 | 144 | (defun generate-code (info) 145 | (bt:with-recursive-lock-held (*storage-lock*) 146 | (generate-code-from-info (find-root-info info)))) 147 | 148 | (defun maybe-compile (function) 149 | ;; compiles function if possible. 150 | (or (ignore-errors (compile nil function)) 151 | function)) 152 | 153 | (defun generate-closure-values-accessor (variables) 154 | (with-gensyms (sym info local-p value parent) 155 | `(maybe-compile 156 | (dlambda (,info) 157 | (:get (,sym &optional ,local-p) 158 | (case ,sym 159 | ,@(mapcar (lambda (var) 160 | `(,var (values ,var t))) 161 | variables) 162 | (t (if-let ((,parent (and (not ,local-p) 163 | (info-environment ,info)))) 164 | (funcall (info-values-accessor ,parent) 165 | ,parent :get ,sym) 166 | (values nil nil))))) 167 | (:set (,sym ,value &optional ,local-p) 168 | (case ,sym 169 | ,@(mapcar (lambda (var) 170 | `(,var (values (setf ,var ,value) t))) 171 | variables) 172 | (t (if-let ((,parent (and (not ,local-p) 173 | (info-environment ,info)))) 174 | (funcall (info-values-accessor ,parent) 175 | ,parent :set ,sym ,value) 176 | (values nil nil))))) 177 | (t () (list . ,variables)))))) 178 | 179 | (defgeneric generate-code-from-info (info)) 180 | 181 | (defmethod generate-code-from-info ((info lambda-info)) 182 | (setting-info-value info `(maybe-compile ,(generate-function-lambda info)))) 183 | 184 | (defgeneric generate-function-lambda (info)) 185 | 186 | (defmethod generate-function-lambda ((info lambda-info)) 187 | `(lambda ,(info-lambda-list info) 188 | . ,(info-body info))) ; avoid doing unnecessary consing 189 | 190 | (defmethod generate-function-lambda ((info named-lambda-info)) 191 | `(named-lambda ,(info-name info) ,(info-lambda-list info) 192 | . ,(info-body info))) 193 | 194 | (defmethod generate-code-from-info :around ((info closure-info)) 195 | `(,(info-type info) ,(generate-closure-args info) 196 | (declare ,@(info-declarations info)) 197 | ,(call-next-method))) 198 | 199 | (defmethod generate-code-from-info ((info closure-info)) 200 | `(progn . ,(mapcar #'generate-code-from-info (info-children info)))) 201 | 202 | (defmethod generate-code-from-info ((info let-closure-info)) 203 | `(progn 204 | ,(setting-info-value 205 | info (generate-closure-values-accessor (info-variables info))) 206 | ,(call-next-method))) 207 | 208 | (defmethod generate-code-from-info ((info flet-closure-info)) 209 | `(progn 210 | ,@(mapcar #'(lambda (func) 211 | (setting-info-value func `(function ,(info-name func)))) 212 | (info-functions info)) 213 | ,(call-next-method))) 214 | 215 | (defun generate-closure-args (info) 216 | (ecase (info-type info) 217 | ((let let*) 218 | (mapcar #'(lambda (var value) 219 | `(,var ',value)) 220 | (info-variables info) 221 | (if (slot-boundp info 'values) 222 | (info-values info) 223 | (funcall (info-values-accessor info) info)))) 224 | ((flet labels) 225 | (mapcar (compose #'cdr #'generate-function-lambda) 226 | (info-functions info))) 227 | ((macrolet symbol-macrolet) 228 | (info-macros info)))) 229 | 230 | (defmethod generate-code-from-info ((info function-call-info)) 231 | (setting-info-value 232 | info 233 | (let* ((values (info-values info)) 234 | (vars (loop repeat (length values) 235 | collect (gensym)))) 236 | (declare (type list vars) 237 | (dynamic-extent vars)) 238 | `(let* ,(mapcar #'list vars 239 | ;; quoted values - some value can be a list 240 | (mapcar (curry #'list 'quote) values)) 241 | (,(info-function-name info) ,@vars))))) 242 | 243 | (defmethod generate-code-from-info ((info quoted-function-info)) 244 | (setting-info-value info (info-body info))) 245 | -------------------------------------------------------------------------------- /src/deflex.lisp: -------------------------------------------------------------------------------- 1 | ;;;; deflex.lisp -- Define "global lexical variables" in Common Lisp. 2 | 3 | ;;; Copyright 2003-2007 Rob Warnock . All Rights Reserved. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a 6 | ;;; copy of this software and associated documentation files (the "Software"), 7 | ;;; to deal in the Software without restriction, including without limitation 8 | ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | ;;; and/or sell copies of the Software, and to permit persons to whom the 10 | ;;; Software is furnished to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included 13 | ;;; in all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 17 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 18 | ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 19 | ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 20 | ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 21 | ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 22 | 23 | ;;; [Extracted from my personal "utils.lisp" (available someday, someday...)] 24 | 25 | ;;; DEFLEX -- Define "global lexical variables", that is, top-level 26 | ;;; variables (convenient when debugging) that are lexical in scope, 27 | ;;; and thus don't pollute either the special or lexical variable spaces 28 | ;;; [except for the names of the "shadow" variables (c.f.), which are 29 | ;;; hopefully non-conflicting in most cases]. Thanks to the denizens 30 | ;;; of the "comp.lang.lisp" newsgroup for many useful discussions (and 31 | ;;; flames!) on this topic, and for the suggestion for the simple and 32 | ;;; efficient (albeit inelegant) "shadow" variable approach used here. 33 | ;;; [Note: Like several others, I had previously used a single global 34 | ;;; adjustable vector of shadow values, with complicated compile-time 35 | ;;; allocation of indices so that symbol-macro FOO expanded into something 36 | ;;; like this: (AREF *LEXICAL-STORE* (LOAD-TIME-VALUE {index-for-FOO})). 37 | ;;; But the following approach is much simpler and more maintainable.] 38 | ;;; 39 | ;;; 2005-06-12 -- Package bugfix thanks to Adam Warner 40 | ;;; 41 | 42 | (in-package :storable-functions) 43 | 44 | (defmacro deflex (var val &optional (doc nil docp)) 45 | "Define a top level (global) lexical VAR with initial value VAL, 46 | which is assigned unconditionally as with DEFPARAMETER. If a DOC 47 | string is provided, it is attached to both the name |VAR| and the 48 | name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of 49 | kind 'VARIABLE. The new VAR will have lexical scope and thus may be 50 | shadowed by LET bindings without affecting its dynamic (global) value." 51 | (let* ((s0 (symbol-name '#:*storage-for-deflex-var-)) 52 | (s1 (symbol-name var)) 53 | (s2 (symbol-name '#:*)) 54 | (s3 (symbol-package var)) ; BUGFIX [see above] 55 | (backing-var (intern (concatenate 'string s0 s1 s2) s3))) 56 | ;; Note: The DEFINE-SYMBOL-MACRO must be the last thing we do so 57 | ;; that the value of the form is the symbol VAR. 58 | (if docp 59 | `(progn 60 | (defparameter ,backing-var ,val ,doc) 61 | (setf (documentation ',var 'variable) ,doc) 62 | (define-symbol-macro ,var ,backing-var)) 63 | `(progn 64 | (defparameter ,backing-var ,val) 65 | (define-symbol-macro ,var ,backing-var))))) 66 | 67 | ;;; File downloaded from http://rpw3.org/hacks/lisp/deflex.lisp 68 | -------------------------------------------------------------------------------- /src/macros.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; Copyright (c) 2009-2016 Jéssica Milaré 4 | ;;; See the file license for license information. 5 | 6 | (in-package :storable-functions) 7 | 8 | (deflex lexical-environment nil) 9 | 10 | (macrolet 11 | ((def (name type) 12 | `(defmacro ,name (vars &body body &environment env) 13 | (declare (ignorable env)) 14 | (let* ((vars (mapcar #'ensure-list vars)) 15 | (variables (mapcar #'car vars)) 16 | (vars 17 | ,(if (eq type 'let) 18 | ;; In LET, nothing left to do 19 | 'vars 20 | ;; In LET*, we have to compute a new lexical-environment 21 | ;; for each variable (upfrom the second one) 22 | `(loop for (var value) in vars 23 | collect var into vars-until-now 24 | if (and vars-until-now 25 | (needs-lexenv-p value ,'env)) 26 | collect (let ((vars-to-bind (butlast vars-until-now))) 27 | `(lexical-environment 28 | (make-instance 29 | 'let-closure-info :type 'let* 30 | :environment lexical-environment 31 | :variables 32 | ',,'(let ((length (length vars-to-bind))) 33 | (assert (equal (subseq variables 0 length) 34 | vars-to-bind)) 35 | (setf vars-until-now nil) 36 | (setf variables (subseq variables length)) 37 | vars-to-bind) 38 | :values-accessor 39 | ,(generate-closure-values-accessor vars-to-bind) 40 | :declarations nil))) 41 | collect (list var value))))) 42 | (multiple-value-bind (body declarations) (parse-body body) 43 | () 44 | `(,',type ,,'vars 45 | (let ,(if (needs-lexenv-p `(progn ,@,'body) env) 46 | `((lexical-environment 47 | (make-instance 48 | 'let-closure-info :type 'let* 49 | ; no need for let since values will 50 | ; already be known by restorage time 51 | :environment lexical-environment 52 | :variables ',,'variables 53 | :values-accessor 54 | ,(generate-closure-values-accessor variables) 55 | :declarations 56 | ',,'(mappend #'cdr declarations)))) 57 | nil) 58 | ,@,'declarations 59 | ,@,'body))))))) 60 | (def st-let let) 61 | (def st-let* let*)) 62 | 63 | (defun parse-function (class lambda-list body 64 | &optional name (get-environment t)) 65 | `(make-instance ',class 66 | :lambda-list ',lambda-list :body ',body 67 | ,@(if get-environment 68 | `(:environment lexical-environment)) 69 | ,@(if name `(:name ',name)))) 70 | 71 | (defmacro st-lambda (lambda-list &body body) 72 | (with-unique-names (function) 73 | `(let ((,function (lambda ,lambda-list ,@body))) 74 | (setf (get-function-info ,function) 75 | ,(parse-function 'lambda-info lambda-list body)) 76 | ,function))) 77 | 78 | (defmacro st-named-lambda (name lambda-list &body body) 79 | (with-unique-names (function) 80 | `(let ((,function (named-lambda ,lambda-list ,@body))) 81 | (setf (get-function-info ,function) 82 | ,(parse-function 'named-lambda-info lambda-list body name)) 83 | ,function))) 84 | 85 | (macrolet 86 | ((def (name type) 87 | `(defmacro ,name (fspecs &body body &environment env) 88 | (let* ((func-names (mapcar #'first fspecs)) 89 | (info-names (mapcar #'(lambda (func-name) 90 | (gensym (symbol-name func-name))) 91 | func-names)) 92 | (infos (mapcar 93 | (curry #'apply 94 | #'(lambda (name lambda-list &rest func-body) 95 | (parse-function 96 | 'named-lambda-info lambda-list 97 | func-body name ,(eq type 'flet)))) 98 | fspecs))) 99 | (multiple-value-bind (body declarations) (parse-body body) 100 | `(let ,(mapcar #'list info-names infos) 101 | (,',type ,fspecs 102 | (let ,(if (or ,(eq type 'labels) 103 | (needs-lexenv-p `(progn ,@,'body) env)) 104 | `((lexical-environment 105 | (make-instance 106 | 'flet-closure-info :type ',',type 107 | :environment lexical-environment 108 | :functions (list ,@info-names) 109 | :declarations 110 | ',,'(mappend #'cdr declarations))))) 111 | ;; Label functions may depend on the entire 112 | ;; labels form. 113 | ;; Flet functions, on the other hand, don't. 114 | ,@,(when (eq type 'labels) 115 | `(mapcar #'(lambda (info) 116 | `(setf (info-environment ,info) 117 | lexical-environment)) 118 | info-names)) 119 | ,@(mapcar #'(lambda (func-name info-name) 120 | `(setf (get-function-info 121 | (function ,func-name)) 122 | ,info-name)) 123 | func-names info-names) 124 | ,@,'declarations 125 | ,@,'body)))))))) 126 | (def st-flet flet) 127 | (def st-labels labels)) 128 | 129 | (macrolet ((def (name type) 130 | `(defmacro ,name (macros &body body) 131 | (multiple-value-bind (body declarations) (parse-body body) 132 | `(,',type ,macros 133 | (let ((lexical-environment 134 | (make-instance 135 | 'macro-closure-info :type ',',type 136 | :environment lexical-environment 137 | :macros ',macros 138 | :declarations 139 | ',,'(mappend #'cdr declarations)))) 140 | ,@,'declarations 141 | ,@,'body)))))) 142 | (def st-macrolet macrolet) 143 | (def st-symbol-macrolet symbol-macrolet)) 144 | 145 | (defmacro st ((function-name &rest arguments)) 146 | (case function-name 147 | (function 148 | (assert (not (cdr arguments))) 149 | (let ((arg (first arguments))) 150 | (if (and (consp arg) 151 | (member (car arg) '(lambda named-lambda))) 152 | `(st ,arg) 153 | ;; Either this is a global function (e.g. (function sin)) 154 | ;; (which we do not handle - cl-store or any persistence 155 | ;; library can easily handle this) or a local function 156 | ;; (which should already have been handled by st-flet 157 | ;; or st-lambda macro) 158 | ;; either way, there is nothing left to do here. 159 | `(function ,arg)))) 160 | ((lambda named-lambda let let* flet labels macrolet symbol-macrolet) 161 | `(,(find-symbol (concatenate 'string "ST-" (symbol-name function-name)) 162 | :storable-functions) 163 | ,@arguments)) 164 | (t (let ((new-args (loop repeat (length arguments) 165 | collect (gensym)))) 166 | (with-unique-names (function) 167 | `(let* (,@(mapcar #'list new-args arguments) 168 | (,function (,function-name . ,new-args))) 169 | (when (functionp ,function) 170 | (setf (get-function-info ,function) 171 | (make-instance 'function-call-info 172 | :function-name ',function-name 173 | :values (list . ,new-args)))) 174 | ,function)))))) 175 | 176 | (defmacro stq (form) 177 | (with-unique-names (function) 178 | `(let ((,function ,form)) 179 | (when (functionp ,function) 180 | (setf (get-function-info ,function) 181 | (make-instance 'quoted-function-info 182 | :body ',form))) 183 | ,function))) 184 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; Copyright (c) 2009-2016 Jéssica Milaré 4 | ;;; See the file license for license information. 5 | 6 | (defpackage :storable-functions 7 | (:use :trivial-garbage :cl :alexandria) 8 | (:nicknames :st-fun) 9 | (:export #:code-information 10 | 11 | #:with-storable-functions-restorage #:with-storable-functions-storage 12 | #:store-code-info #:restore-code-info #:get-function-referrer 13 | 14 | #:get-function-info #:rem-function-info 15 | 16 | #:st-let #:st-let* 17 | #:st-lambda #:st-named-lambda 18 | #:st-flet #:st-labels 19 | #:st-macrolet #:st-symbol-macrolet 20 | #:st #:stq 21 | 22 | ;; cl-store backend to store and restore functions 23 | #:cl-store+functions)) 24 | -------------------------------------------------------------------------------- /src/storage.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; Copyright (c) 2009-2016 Jéssica Milaré 4 | ;;; See the file license for license information. 5 | 6 | ;;; About the approach here: 7 | ;;; It is needed to avoid circularity on closures because the code needs to be 8 | ;;; generated right after restorage. 9 | ;;; So, during storage, the environment slot is removed from every instance of a 10 | ;;; subclass of code-information. 11 | ;;; This slot will be safelly recoverred during restorage. This way there is no 12 | ;;; internal circularity 13 | ;;; from the root down to all the leaves. 14 | ;;; 15 | ;;; The instances of class "function-referrer" are created to be stored instead 16 | ;;; of the functions; each instance contains the root of the environment tree 17 | ;;; and the function-info instance associated with the function. 18 | ;;; Unless something really goes wrong, right after restorage of an instance of 19 | ;;; "function-referrer", the entire environment tree will be available without 20 | ;;; circularities from the root and then it will be possible to generate the code. 21 | 22 | (in-package :storable-functions) 23 | 24 | (defclass function-referrer (code-information) 25 | ((function-info :accessor info-function-info :initarg :function-info 26 | :type function-info) 27 | (root :accessor info-root :initarg :root :type code-information))) 28 | 29 | ;;; During restorage, it is not good to keep weak pointers to the children 30 | ;;; of closures. So we keep a list of weaklists that need to be set at the 31 | ;;; end (see utils.lisp). 32 | (defvar *weak-lists-to-set* nil) 33 | 34 | (defmacro with-storable-functions-restorage ((&key (restorage-table :create) 35 | &allow-other-keys) 36 | &body body) 37 | `(let ((*restored-functions* ,(ecase restorage-table 38 | (:create '(make-hash-table)) 39 | (:clear '(clrhash *restored-functions*)) 40 | (:reuse '*restored-functions*))) 41 | (*weak-lists-to-set* nil)) 42 | (prog1 (progn ,@body) 43 | (mapcar #'set-weak-list *weak-lists-to-set*)))) 44 | 45 | (defmacro with-storable-functions-storage ((&key (execute-gc t) 46 | &allow-other-keys) 47 | &body body) 48 | `(progn 49 | ;; GC avoids to store functions which aren't around anymore. 50 | (when ,execute-gc 51 | (tg:gc)) 52 | ,@body)) 53 | 54 | (defun get-function-referrer (function) 55 | (let ((info (get-function-info function))) 56 | (when info 57 | (make-instance 'function-referrer 58 | :root (find-root-info info) 59 | :function-info info)))) 60 | 61 | (defgeneric store-code-info (info callback) 62 | (:method ((info code-information) callback) 63 | (let ((env (info-environment info))) 64 | (bt:with-recursive-lock-held (*storage-lock*) 65 | ;; avoids circularity - the circularity is well known, 66 | ;; it is restored after call to restore-code-info 67 | (slot-makunbound info 'environment) 68 | (unwind-protect 69 | (funcall callback) 70 | (setf (info-environment info) env)))))) 71 | 72 | (defmethod store-code-info ((info function-referrer) callback) 73 | (funcall callback)) 74 | 75 | (defmethod store-code-info ((info closure-info) callback) 76 | (bt:with-recursive-lock-held (*storage-lock*) 77 | ;; avoids implementation-dependent details in the storage 78 | (unset-weak-list (info-children-weak-list info)) 79 | (unwind-protect (call-next-method) 80 | ;; now restores the list of weak-pointers 81 | (set-weak-list (info-children-weak-list info))))) 82 | 83 | (defmethod store-code-info ((info let-closure-info) callback) 84 | (let ((func (info-values-accessor info))) 85 | (bt:with-recursive-lock-held (*storage-lock*) 86 | ;; unbounds the unstorable function slot 87 | (slot-makunbound info 'values-accessor) 88 | ;; takes a "snapshot" of the current closure status 89 | (setf (info-values info) (funcall func info)) 90 | (unwind-protect (call-next-method) 91 | ;; removes unnecessary information 92 | (slot-makunbound info 'values) 93 | ;; and rebinds the function slot 94 | (setf (info-values-accessor info) func))))) 95 | 96 | (defgeneric restore-code-info (info) 97 | (:method ((info code-information)) 98 | (unless (slot-boundp info 'environment) 99 | (setf (info-environment info) nil)) 100 | info)) 101 | 102 | (defmethod restore-code-info ((info function-referrer)) 103 | (setf (info-environment info) nil 104 | (info-environment (info-root info)) nil) 105 | (let* ((function-info (info-function-info info)) 106 | (func (get-info-value function-info))) 107 | (setf (get-function-info func) function-info) 108 | func)) 109 | 110 | (defmethod restore-code-info ((info closure-info)) 111 | (prog1 (call-next-method) 112 | (let ((children (get-list-from-weak-list (info-children-weak-list info)))) 113 | (push (info-children-weak-list info) *weak-lists-to-set*) 114 | (dolist (child children) 115 | (setf (info-environment child) info) 116 | #+ignore 117 | (restore-code-info child)) 118 | ;; Rebuilds the list of weak pointers 119 | (setf (info-children info) children)))) 120 | 121 | (defmethod restore-code-info ((info let-closure-info)) 122 | (prog1 (call-next-method) 123 | (setf (info-values-accessor info) (get-info-value info)) 124 | (slot-makunbound info 'values))) 125 | 126 | (defmethod restore-code-info ((info flet-closure-info)) 127 | (prog1 (call-next-method) 128 | ;; the standard method will set info-environment to nil if 129 | ;; the 'environment slot is unbound 130 | (let ((environment 131 | (ecase (info-type info) 132 | (labels info) 133 | (flet (info-environment info))))) 134 | (dolist (function (info-functions info)) 135 | (setf (info-environment function) environment) 136 | #+ignore 137 | (restore-code-info function))))) 138 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; Copyright (c) 2009-2016 Jéssica Milaré 4 | ;;; See the file license for license information. 5 | 6 | (in-package :storable-functions) 7 | 8 | #+nil 9 | (defun parse-body (body) 10 | (loop for rest on body 11 | for form = (car rest) 12 | while (eq 'declare (first form)) 13 | collect form into declarations 14 | finally (return (values rest declarations)))) 15 | 16 | (defun find-st-macro-in-tree (form env) 17 | (when (consp form) 18 | (let ((head (car form))) 19 | (or (and (symbolp head) 20 | (eq (symbol-package head) (find-package :storable-functions)) 21 | (macro-function head env)) 22 | (if (consp head) 23 | (some (lambda (subform) 24 | (find-st-macro-in-tree subform env)) 25 | form) 26 | (multiple-value-bind (new-form expanded-p) 27 | (ignore-errors (macroexpand-1 form env)) 28 | (if (and expanded-p 29 | (not (member head '(function lambda))) 30 | (not (equalp form new-form))) 31 | (find-st-macro-in-tree new-form env) 32 | (some (lambda (subform) 33 | (find-st-macro-in-tree subform env)) 34 | (cdr form))))))))) 35 | 36 | (defun needs-lexenv-p (form env) 37 | (find-st-macro-in-tree form env)) 38 | 39 | (defmacro with-collector ((collector) &body body) 40 | (with-gensyms (list last) 41 | `(let ((,list nil) (,last nil)) 42 | (flet ((,collector (elt) 43 | (if ,list 44 | (setf (cdr ,last) (cons elt nil)) 45 | (setf ,last (setf ,list (cons elt nil)))) 46 | ,list)) 47 | ,@body) 48 | ,list))) 49 | 50 | (defmacro dlambda (preargs &body ds) 51 | (with-gensyms (args) 52 | `(lambda (,@preargs &rest ,args) 53 | ,@(loop while (or (stringp (car ds)) 54 | (and (listp (car ds)) 55 | (eq 'declare (caar ds)))) 56 | collect (pop ds)) 57 | (case (car ,args) 58 | ,@(mapcar 59 | (lambda (d) 60 | `(,(if (eq t (car d)) 61 | t 62 | (ensure-list (car d))) 63 | (apply (lambda ,@(cdr d)) 64 | ,(if (eq t (car d)) 65 | args 66 | `(cdr ,args))))) 67 | ds))))) 68 | 69 | (declaim (inline #+ignore safe-weak-pointer-value pushnew-weak-list)) 70 | 71 | #+ignore 72 | (defun safe-weak-pointer-value (pointer) 73 | (if (tg:weak-pointer-p pointer) 74 | (tg:weak-pointer-value pointer) 75 | pointer)) 76 | 77 | (defun pushnew-weak-list (elt list) 78 | (if (car list) 79 | (pushnew (tg:make-weak-pointer elt) (cdr list) 80 | :key #'tg:weak-pointer-value) 81 | (pushnew elt (cdr list))) 82 | list) 83 | 84 | (defun delete-weak-list (elt list) 85 | (setf (cdr list) 86 | (if (car list) 87 | (delete elt (cdr list) :key #'tg:weak-pointer-value) 88 | (delete elt (cdr list)))) 89 | list) 90 | 91 | (defun get-list-from-weak-list (list) 92 | (if (car list) 93 | (with-collector (collect) 94 | (setf (cdr list) 95 | (delete-if #'(lambda (child) 96 | (not (when child 97 | (collect child) 98 | t))) 99 | (cdr list) 100 | :key #'tg:weak-pointer-value))) 101 | (cdr list))) 102 | 103 | (declaim (inline set-weak-list unset-weak-list new-weak-list)) 104 | 105 | (defun set-weak-list (weak-list &optional (list (cdr weak-list) listp)) 106 | (if (or listp (not (car weak-list))) 107 | (setf (cdr weak-list) (mapcar #'tg:make-weak-pointer list))) 108 | (setf (car weak-list) t) 109 | list) 110 | 111 | (defun unset-weak-list (weak-list &optional (list (get-list-from-weak-list weak-list))) 112 | (setf (car weak-list) nil 113 | (cdr weak-list) list)) 114 | 115 | (defun new-weak-list () 116 | (cons t nil)) 117 | -------------------------------------------------------------------------------- /storable-functions.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; Copyright (c) 2009-2016 Jéssica Milaré 4 | ;;; See the file license for license information. 5 | 6 | (defpackage :storable-functions-system 7 | (:use :cl :asdf)) 8 | 9 | (in-package :storable-functions-system) 10 | 11 | (defsystem storable-functions 12 | :name "Storable Functions" 13 | :version "0.0.3" 14 | :maintainer "Jéssica Milaré" 15 | :author "Jéssica Milaré" 16 | :licence "MIT style" 17 | :description "Implements a way to transform functions from and to CLOS 18 | instances of some specific classes. It contains a set of macros for making 19 | this transformation possible, and tools for actually doing the transformation. 20 | The goal is to provide a simple, portable way to serialize functions. Portable 21 | in the sense that it should work across multiple Common Lisp implementations. 22 | Simple in the sense that supporting the serialization of all functions defined 23 | using this library should be just a matter of defining / redefining one or two 24 | methods of the serialization protocol. 25 | The only restriction to make functions serializable is to use a set of macros 26 | to create closure and function information." 27 | :depends-on (trivial-garbage alexandria asdf-system-connections) 28 | :components ((:module "src" 29 | :components ((:file "package") 30 | (:file "utils" :depends-on ("package")) 31 | (:file "classes" :depends-on ("utils")) 32 | (:file "storage" :depends-on ("classes")) 33 | (:file "deflex" :depends-on ("package")) 34 | (:file "macros" :depends-on ("deflex" "classes")))))) 35 | 36 | (defmethod perform ((op test-op) (system (eql (find-system :storable-functions)))) 37 | (oos 'load-op :storable-functions-tests) 38 | (oos 'test-op :storable-functions-tests)) 39 | -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; Copyright (c) 2009-2016 Jéssica Milaré 4 | ;;; See the file license for license information. 5 | 6 | (defpackage :storable-functions-tests 7 | (:use :cl :alexandria :storable-functions :lift :cl-store+functions :cl-store)) 8 | 9 | (in-package :storable-functions-tests) 10 | 11 | (defun run-all-tests (&rest args) 12 | (apply #'run-cl-store+functions-tests args)) 13 | 14 | (defmacro ensure=-funcall (func1 func2 &rest args) 15 | "Ensures the functions func1 and func2 return values that are =." 16 | `(ensure-same (funcall ,func1 ,@args) (funcall ,func2 ,@args) 17 | :test #'= :ignore-multiple-values? t)) 18 | 19 | (defmacro ensure-equal-funcall (func1 func2 &rest args) 20 | "Ensures the functions func1 and func2 return values that are =." 21 | `(ensure-same (funcall ,func1 ,@args) (funcall ,func2 ,@args) 22 | :test #'equal :ignore-multiple-values? t)) 23 | 24 | (eval-when (:compile-toplevel :load-toplevel :execute) 25 | (defparameter *all-standard-tests* nil)) 26 | 27 | (defmacro def-tester-for-standard-tests (testsuite-name options &body body) 28 | (declare (ignorable options)) 29 | (with-unique-names (function-set-var n-function-set-var) 30 | `(progn 31 | ,@(loop 32 | for (testname function-vars function-set prologue-code current-body) 33 | in (reverse *all-standard-tests*) 34 | collect 35 | `(addtest (,testsuite-name) 36 | ,testname 37 | (flet ((get-current-function-set () 38 | ,function-set) 39 | (get-current-function-set-disable-st-macro () 40 | ;; runs code as if st macro did nothing 41 | (macrolet ((st (form &rest others) 42 | (declare (ignore others)) 43 | form)) 44 | ,function-set)) 45 | (run-prologue-test-code (,function-set-var) 46 | (destructuring-bind ,function-vars (ensure-list ,function-set-var) 47 | (declare (ignorable ,@function-vars)) 48 | ,prologue-code)) 49 | (run-current-test (,function-set-var ,n-function-set-var) 50 | (destructuring-bind ,function-vars (ensure-list ,function-set-var) 51 | (destructuring-bind 52 | ,(mapcar 53 | #'(lambda (var) 54 | (symbolicate "N-"(symbol-name var))) 55 | function-vars) (ensure-list ,n-function-set-var) 56 | ,@current-body)))) 57 | ,@body)))))) 58 | 59 | (defmacro def-std-test (testname (function-vars function-set) prologue-code 60 | &body body) 61 | `(eval-when (:compile-toplevel :load-toplevel :execute) 62 | (pushnew '(,testname ,function-vars ,function-set ,prologue-code ,body) 63 | *all-standard-tests* :key #'car) 64 | ',testname)) 65 | 66 | (def-std-test simple-sum-lambda-test 67 | ((func) (list (st (lambda (a b) 68 | (the fixnum (+ (the fixnum a) 69 | (the fixnum b))))))) 70 | ;; First the code that should be evaluated before the storage / restorage 71 | nil 72 | ;; Then the standard test code 73 | (ensure-cases (a b) '((2 3) (5 10) (14 11)) 74 | (ensure=-funcall func n-func a b))) 75 | 76 | ;;; This test shows that a function that has been just restored 77 | ;;; can be seen as a copy of the old function, copying the closure variables 78 | ;;; as well. 79 | ;;; Do not forget to use (st (let ...)) or (st-let ...) instead of using 80 | ;;; (let ...) 81 | (def-std-test increment-acc-test 82 | ((func) (list (st (let ((acc 0)) 83 | (declare (fixnum acc)) 84 | (st (lambda (&optional (diff 1)) 85 | (the fixnum (incf acc (the fixnum diff))))))))) 86 | nil 87 | ;; n-func is bound to the restored "copy" of the function 88 | (dotimes (i 3) 89 | (ensure=-funcall func n-func)) 90 | (ensure-cases (x) '(16 -4 -18 5) 91 | (ensure=-funcall func n-func x))) 92 | 93 | ;;; Multiple closures work just fine as well 94 | ;;; IF they are stored in the same file and restored together (for cl-store). 95 | (def-std-test increment-and-set-acc-test 96 | ((inc-func set-func) (st (let ((acc 0)) 97 | (declare (fixnum acc)) 98 | (list (st (lambda (&optional (diff 1)) 99 | (incf acc (the fixnum diff)))) 100 | (st (lambda (&optional (value 0)) 101 | (setf acc (the fixnum value)))))))) 102 | ;; Changing the value of acc BEFORE storage / restorage - closures should be saved 103 | ;; with the functions at the time they are stored 104 | (funcall set-func 8) 105 | ;; Now storage and restorage has taken place. Comparing two versions... 106 | (dotimes (i 3) 107 | (ensure=-funcall inc-func n-inc-func)) 108 | (ensure=-funcall set-func n-set-func 5) 109 | (dotimes (i 3) 110 | (ensure=-funcall inc-func n-inc-func)) 111 | (ensure=-funcall set-func n-set-func 10) 112 | (ensure-cases (x) '(19 -6 -2 3) 113 | (ensure=-funcall inc-func n-inc-func x)) 114 | (ensure=-funcall set-func n-set-func 12)) 115 | 116 | ;;; Recursive closures should work as well in the expected way 117 | (def-std-test recursive-increment-and-set-acc-closure-test 118 | ((inner-inc1 inner-set1 outer-inc1 outer-set1 119 | inner-inc2 inner-set2 outer-inc2 outer-set2) 120 | (st (let ((outer-acc 0)) 121 | (nconc 122 | (st (let ((inner-acc 0)) 123 | (st (flet ((inner-inc (&optional (diff 1)) 124 | (incf inner-acc (the fixnum diff))) 125 | (inner-set (value) 126 | (setf inner-acc (the fixnum value))) 127 | (outer-inc (&optional (diff 1)) 128 | (incf outer-acc (the fixnum diff))) 129 | (outer-set (value) 130 | (setf outer-acc (the fixnum value)))) 131 | (list #'inner-inc #'inner-set 132 | #'outer-inc #'outer-set))))) 133 | (st (let ((inner-acc 0)) 134 | (st (flet ((inner-inc (&optional (diff 1)) 135 | (incf inner-acc (the fixnum diff))) 136 | (inner-set (value) 137 | (setf inner-acc (the fixnum value))) 138 | (outer-inc (&optional (diff 1)) 139 | (incf outer-acc (the fixnum diff))) 140 | (outer-set (value) 141 | (setf outer-acc (the fixnum value)))) 142 | (list #'inner-inc #'inner-set 143 | #'outer-inc #'outer-set))))))))) 144 | (progn ;; Changing the values of the closures variables 145 | (funcall inner-set1 19) 146 | (funcall inner-set2 7) 147 | (funcall outer-set1 1)) 148 | ;; set 1 of functions 149 | (dotimes (i 3) 150 | (ensure=-funcall inner-inc1 n-inner-inc1)) 151 | (ensure=-funcall inner-set1 n-inner-set1 3) 152 | (ensure=-funcall outer-set1 n-outer-set1 14) 153 | (dotimes (i 3) 154 | (ensure=-funcall outer-inc1 n-outer-inc1)) 155 | ;; set 2 of functions 156 | (dotimes (i 3) 157 | (ensure=-funcall inner-inc2 n-inner-inc2)) 158 | (ensure=-funcall inner-set2 n-inner-set2 17) 159 | (ensure=-funcall outer-set2 n-outer-set2 8) 160 | (dotimes (i 3) 161 | (ensure=-funcall outer-inc2 n-outer-inc2)) 162 | ;; mixed set 1 and 2 163 | (ensure=-funcall outer-set2 n-outer-set2 9) 164 | (dotimes (i 3) 165 | (ensure=-funcall outer-inc1 n-outer-inc1) 166 | (ensure=-funcall outer-inc2 n-outer-inc2)) 167 | (dotimes (i 3) 168 | (ensure=-funcall inner-inc1 n-inner-inc1) 169 | (ensure=-funcall inner-inc2 n-inner-inc2)) 170 | ;; other increment values 171 | (ensure-cases (inn1 out1 inn2 out2) 172 | '((3 0 7 1) (11 -5 4 -3) (-2 8 -9 -15) (2 -13 16 11)) 173 | (ensure=-funcall inner-inc1 n-inner-inc1 inn1) 174 | (ensure=-funcall outer-inc2 n-outer-inc2 out2) 175 | (ensure=-funcall inner-inc2 n-inner-inc2 inn2) 176 | (ensure=-funcall outer-inc1 n-outer-inc1 out1))) 177 | 178 | ;;; No problem with multiple variables as well 179 | (def-std-test shifting-closure-test 180 | ((func) (list (st (let ((a 0) (b 1) (c 2)) 181 | (declare (fixnum a b c)) 182 | ;; This function returns the value received 3 calls ago. 183 | (st (lambda (value) 184 | (shiftf a b c (the fixnum value)))))))) 185 | (dolist (x '(3 11 10 8 16)) 186 | (funcall func x)) 187 | (ensure-cases (x) '(10 6 -13 -7 10 13 -15 -18 0 0 0) 188 | (ensure=-funcall func n-func x))) 189 | 190 | (def-std-test recursive-shifting-closure-test 191 | ((func1 func2) (st (let ((a 0) (b 1)) 192 | (declare (fixnum a b)) 193 | ;; Another interesting example. 194 | (list 195 | (st (let ((c 2) (d 3)) 196 | (declare (fixnum c d)) 197 | (st (lambda (value) 198 | (shiftf a b c d (the fixnum value)))))) 199 | (st (let ((c 2) (d 3)) 200 | (declare (fixnum c d)) 201 | (st (lambda (value) 202 | (shiftf a b c d (the fixnum value)))))))))) 203 | (progn 204 | (dolist (x '(6 18 6)) 205 | (funcall func1 x)) 206 | (dolist (x '(8 14 0)) 207 | (funcall func2 x))) 208 | (ensure-cases (x) '(2 0 -13) 209 | (ensure=-funcall func1 n-func1 x)) 210 | (ensure-cases (x) '(2 0 -13) 211 | (ensure=-funcall func1 n-func1 x)) 212 | (ensure-cases (x) '(-8 8) 213 | (ensure=-funcall func2 n-func2 x)) 214 | (ensure-cases (x) '(15 -3) 215 | (ensure=-funcall func1 n-func1 x)) 216 | (ensure-cases (x) '(4 -1 18) 217 | (ensure=-funcall func2 n-func2 x)) 218 | (ensure-cases (x) '(0 0) 219 | (ensure=-funcall func1 n-func1 x)) 220 | (ensure-cases (x) '(0 0 0) 221 | (ensure=-funcall func2 n-func2 x))) 222 | 223 | (def-std-test labels-add-sub-test 224 | ((set-acc add-sub sub-add add-and-sub) 225 | (st (let ((acc 0)) 226 | (declare (fixnum acc)) 227 | (cons (st #'(lambda (x) 228 | (setf acc x))) 229 | (st (labels ((add-sub (values) 230 | (if values 231 | (cons (+ (the fixnum (car values)) acc) 232 | (the list (sub-add (cdr values)))))) 233 | (sub-add (values) 234 | (if values 235 | (cons (- (the fixnum (car values)) acc) 236 | (the list (add-sub (cdr values))))))) 237 | (list #'add-sub #'sub-add 238 | (st #'(lambda (values1 values2) 239 | (list (add-sub values1) 240 | (sub-add values2))))))))))) 241 | (funcall set-acc 11) 242 | (ensure-cases (as sa aas1 aas2 set) 243 | '(((16 12 11 19 4 7 0 8) (10 17 14 4 11) (14 13 5) (15 0 12 9) 4) 244 | ((4 9 3 16 13 17) (3 5 9 15 11 10 4 18 9) (15 11 17 3 13 7) (19 1) 12) 245 | ((3 13 2 13) (3 9 7 11 8 16) (9 19 6 7 7 12 9 19 15) (1 6 7 12 14 16) 15) 246 | ((4 3) (6 11 14 16 9 10 1 3 6) (7 1 1) (11 11 4 18 14 0 15 9 4) 9)) 247 | (ensure-equal-funcall add-sub n-add-sub as) 248 | (ensure-equal-funcall sub-add n-sub-add sa) 249 | (ensure-equal-funcall add-and-sub n-add-and-sub aas1 aas2) 250 | (ensure-equal-funcall set-acc n-set-acc set))) 251 | 252 | ;;; The st macro can mark any form that should return a function; 253 | ;;; e.g., compose, complement, adjoin... 254 | ;;; When requested to save the returned function, the function name and 255 | ;;; arguments are saved. 256 | ;;; After restorage, the same function is called again with the "same" arguments 257 | ;;; (i.e., a copy of the arguments) in the corresponding lexical closure. 258 | (def-std-test st-compose-test ((func) (list (st (compose #'cadr #'reverse)))) 259 | nil 260 | (ensure (funcall n-func (list nil nil nil nil nil t nil)))) 261 | 262 | (def-std-test st-curry-test ((func) (list (st (curry #'list 1 2 3 4)))) 263 | nil 264 | (ensure-same (funcall n-func 5 6) '(1 2 3 4 5 6) 265 | :test #'equal)) 266 | 267 | (def-std-test stq-compose-test ((func) (list (stq (compose #'cadr #'reverse)))) 268 | nil 269 | (ensure (funcall n-func (list nil nil nil nil nil t nil)))) 270 | 271 | (def-std-test stq-curry-test ((func) (list (stq (curry #'list 1 2 3 4)))) 272 | nil 273 | (ensure-same (funcall n-func 5 6) '(1 2 3 4 5 6) 274 | :test #'equal)) 275 | 276 | (def-std-test unsafe-let*-call 277 | ((func) (st (let* ((a 32) 278 | (fun (st (lambda (x) 279 | (+ x a))))) 280 | fun))) 281 | nil 282 | (ensure-cases (x) '(6 45 41 6 48 45 11 31 15 4) 283 | (ensure-equal-funcall func n-func x))) 284 | --------------------------------------------------------------------------------