├── LICENSE.TXT ├── src ├── tools │ ├── package.lisp │ └── types.lisp ├── common │ ├── package.lisp │ ├── util.lisp │ ├── macro-util.lisp │ └── let-over-lambda.lisp ├── walker │ ├── cl-environments.lisp │ ├── package.lisp │ ├── hook.lisp │ ├── util.lisp │ ├── cltl2-interface.lisp │ ├── special-forms.lisp │ ├── def-forms.lisp │ ├── walker.lisp │ ├── cltl2-interface.ccl-cmucl.lisp │ ├── declarations.lisp │ ├── cl-overrides.lisp │ ├── let-forms.lisp │ ├── cltl2-interface.ecl.lisp │ ├── lambda.lisp │ └── augment-environment.lisp └── other │ ├── lispworks.lisp │ ├── allegro.lisp │ └── sbcl.lisp ├── test └── cltl2 │ ├── lambda.lisp │ ├── macrolet.lisp │ ├── letstar.lisp │ ├── let.lisp │ ├── def-forms.lisp │ ├── labels.lisp │ ├── test.lisp │ ├── flet.lisp │ ├── define-declaration.lisp │ └── special-forms.lisp └── cl-environments.asd /LICENSE.TXT: -------------------------------------------------------------------------------- 1 | Copyright 2017 - 2021 Alexander Gutev 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /src/tools/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; Copyright 2019 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (defpackage :cl-environments.tools 27 | (:use :cl-environments 28 | :alexandria 29 | :anaphora 30 | :optima) 31 | 32 | (:export :get-return-types 33 | :get-return-type 34 | :get-value-type)) 35 | -------------------------------------------------------------------------------- /src/common/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; Copyright 2018 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (defpackage :cl-environments.util 27 | (:use :common-lisp 28 | :alexandria 29 | :anaphora 30 | :optima) 31 | 32 | (:export :defmacro! 33 | 34 | :let-if 35 | :slot-values 36 | :match-state 37 | :reexport-all-symbols)) 38 | -------------------------------------------------------------------------------- /src/walker/cl-environments.lisp: -------------------------------------------------------------------------------- 1 | ;;;; cl-environments.lisp 2 | ;;;; 3 | ;;;; Copyright 2018 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :cl-environments.cltl2) 27 | 28 | (eval-when (:compile-toplevel :load-toplevel :execute) 29 | (pushnew #-(or ccl cmucl ecl) :cl-environments-full 30 | #+(or ccl cmucl ecl) :cl-environments-partial 31 | *features*)) 32 | 33 | #-(or ccl cmucl ecl) 34 | (defconstant +walk-macros+ 35 | '(cl:defun 36 | cl:defgeneric 37 | cl:defmethod 38 | cl:defparameter 39 | cl:defvar 40 | cl:defmacro 41 | cl:define-symbol-macro 42 | cl:declaim) 43 | 44 | "List of macros which should be walked prior expansion.") 45 | 46 | #+(or ccl cmucl ecl) 47 | (defconstant +walk-macros+ 48 | '(cl:declaim) 49 | 50 | "List of macros which should be walked prior expansion.") 51 | -------------------------------------------------------------------------------- /src/walker/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; Copyright 2017-2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (defpackage :cl-environments.cltl2 27 | (:use :common-lisp 28 | :alexandria 29 | :anaphora 30 | :iterate 31 | :optima 32 | 33 | :cl-environments.util) 34 | 35 | (:import-from :collectors 36 | :make-simple-collector 37 | :make-simple-collector-to-place) 38 | 39 | (:export :variable-information 40 | :function-information 41 | :declaration-information 42 | :define-declaration 43 | 44 | :augment-environment 45 | :in-environment 46 | :augmented-macroexpand-1 47 | :augmented-macroexpand 48 | :augmented-macro-function 49 | :augmented-get-setf-expansion 50 | :augmented-compiler-macro-function 51 | :augmented-constantp 52 | 53 | :enclose 54 | :parse-macro 55 | :enclose-macro 56 | 57 | :enable-hook 58 | :disable-hook 59 | 60 | :walk-environment) 61 | 62 | #+ccl 63 | (:import-from :ccl 64 | :enclose 65 | :parse-macro) 66 | 67 | #+cmucl 68 | (:import-from :extensions 69 | :augment-environment 70 | :parse-macro) 71 | 72 | (:documentation 73 | "Package exporting the base CLTL2 environments API.")) 74 | -------------------------------------------------------------------------------- /src/common/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :cl-environments.util) 27 | 28 | 29 | (defun gensyms (syms &key (key #'identity)) 30 | (mapcar (compose #'gensym #'symbol-name (curry #'funcall key)) syms)) 31 | 32 | (defun reexport-all-symbols (from-package) 33 | (let ((shadowed (mapcar #'symbol-name (package-shadowing-symbols *package*)))) 34 | (do-external-symbols (sym from-package) 35 | (export (if (member (symbol-name sym) shadowed :test #'string=) 36 | (find-symbol (symbol-name sym) *package*) 37 | (list sym)) 38 | *package*)))) 39 | 40 | (defmacro! let-if ((&rest bindings) condition &body body) 41 | "Allows variables to be initialized with different init-forms based 42 | on a condition. BINDINGS is a list of bindings where the first 43 | element is the symbol the second element is the init-form to 44 | evaluated if CONDITION evaluates to true, the second element is the 45 | init-form to evaluate if CONDITION evaluates to false." 46 | 47 | (labels ((make-setf (sym value) 48 | `(setf ,sym ,value)) 49 | (make-binding (binding sym) 50 | `(,(first binding) ,sym))) 51 | 52 | (let ((gensyms (gensyms bindings :key #'car))) 53 | `(let ((,g!test ,condition) ,@gensyms) 54 | (if ,g!test 55 | (progn 56 | ,@(mapcar #'make-setf gensyms (mapcar #'second bindings))) 57 | (progn 58 | ,@(mapcar #'make-setf gensyms (mapcar #'third bindings)))) 59 | (let 60 | ,(mapcar #'make-binding bindings gensyms) 61 | ,@body))))) 62 | 63 | (defmacro! slot-values ((&rest slots) o!form &body body) 64 | (flet ((parse-slot (slot) 65 | (if (listp slot) 66 | slot 67 | (list slot slot)))) 68 | `(let-if 69 | ,(loop 70 | for slot in slots 71 | for (var slot-name) = (parse-slot slot) 72 | collect `(,var (slot-value ,g!form ',slot-name))) 73 | ,g!form 74 | ,@body))) 75 | -------------------------------------------------------------------------------- /src/walker/hook.lisp: -------------------------------------------------------------------------------- 1 | ;;;; hook.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Adds a macro expansion hook 27 | 28 | (in-package :cl-environments.cltl2) 29 | 30 | (defvar *previous-hook* #'funcall 31 | "Contains the previous *MACROEXPAND-HOOK* function, prior to calling 32 | ENABLE-HOOK.") 33 | 34 | 35 | (defun pre-expand-walk (form) 36 | "If FORM is a function macro-form and the macro symbol is a member 37 | of the list +WALK-MACROS+, walks the form, otherwise returns FORM 38 | as is." 39 | 40 | (match form 41 | ((list* (guard op (member op +walk-macros+)) _) 42 | (walk-form form)) 43 | 44 | (_ form))) 45 | 46 | (defun walker-hook (fn form *env*) 47 | "Macro-expansion hook function. Walks the result of the expansion of 48 | FORM." 49 | 50 | (let ((*macroexpand-hook* *previous-hook*)) 51 | (let* ((form (pre-expand-walk form)) 52 | (expansion (funcall *previous-hook* fn form *env*))) 53 | 54 | (match form 55 | ((list* (not '%walk-form) _) 56 | 57 | (let ((walked-form (walk-form expansion))) 58 | (if (equal walked-form form) 59 | form 60 | walked-form))) 61 | 62 | (_ expansion))))) 63 | 64 | (defun enable-hook (&optional (previous-hook *macroexpand-hook*)) 65 | "Sets the code-walker as the macro-expansion hook, this allows 66 | information about the lexical-environment to be stored and 67 | retrieved later. The optional PREVIOUS-HOOK argument is the next 68 | hook function to call after the current hook is enabled." 69 | 70 | (setf *previous-hook* previous-hook) 71 | (setf *macroexpand-hook* #'walker-hook)) 72 | 73 | (defun disable-hook (&optional (previous-hook *previous-hook*)) 74 | "Restores the macro-expansion hook to FUNCALL, thus disabling the 75 | top-level form code-walker. Lexical-environment information will no 76 | longer be stored and thus will no longer be retrievable. The 77 | optional PREVIOUS-HOOK argument is the value to set 78 | *MACROEXPAND-HOOK* to. By default it is bound to *PREVIOUS-HOOK* 79 | which contains the value of the PREVIOUS-HOOK argument to 80 | ENABLE-HOOK." 81 | 82 | (setf *macroexpand-hook* previous-hook)) 83 | -------------------------------------------------------------------------------- /test/cltl2/lambda.lisp: -------------------------------------------------------------------------------- 1 | ;;;; lambda.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test that environment information is extracted from LAMBDA forms 27 | 28 | (defpackage :cl-environments.test.cltl2.lambda-forms 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :fiveam)) 32 | 33 | (in-package :cl-environments.test.cltl2.lambda-forms) 34 | 35 | (def-suite lambda-forms 36 | :description "Test extraction of environment information from LAMBDA forms" 37 | :in cltl2-test) 38 | 39 | (in-suite lambda-forms) 40 | 41 | (test (lambda-arg-information :compile-at :run-time) 42 | "Test that lambda arguments are added to environment" 43 | 44 | (let ((f (lambda (x) 45 | (declare (ignore x)) 46 | 47 | (info variable x)))) 48 | 49 | (is (info= '(:lexical t ((ignore . t))) 50 | (funcall f 1))))) 51 | 52 | (test (lambda-optional-args :compile-at :run-time) 53 | "Test LAMBDA form with all argument types" 54 | 55 | #+sbcl (declare (optimize (sb-ext:inhibit-warnings 3))) 56 | 57 | (let ((f (lambda (a &optional (b (info variable a)) c &rest d &key (e (info variable d) ep) ((:argf f) (info variable ep)) g &allow-other-keys &aux (h (info variable f))) 58 | (declare (ignorable a b c d e ep f g h)) 59 | (values b e f h)))) 60 | 61 | (multiple-value-bind (info-a info-d info-ep info-f) (funcall f 1) 62 | (is-every info= 63 | ('(:lexical t nil) info-a) 64 | ('(:lexical t nil) info-d) 65 | ('(:lexical t nil) info-ep) 66 | ('(:lexical t nil) info-f))))) 67 | 68 | (test (lambda-closure :compile-at :run-time) 69 | "Test information of variables in LAMBDA closure" 70 | 71 | (let ((x 1) 72 | (y 2)) 73 | (declare (type integer x y) 74 | (ignorable x y)) 75 | 76 | (let ((f (lambda (y) 77 | (declare (type number y) 78 | (ignorable y)) 79 | 80 | (values 81 | (info variable x) 82 | (info variable y))))) 83 | 84 | (multiple-value-bind (info-x info-y) (funcall f 1) 85 | (is-every info= 86 | ('(:lexical t ((type . integer))) info-x) 87 | ('(:lexical t ((type . number))) info-y))) 88 | 89 | (is (info= '(:lexical t ((type . integer))) 90 | (info variable y)))))) 91 | 92 | (test (lambda-with-docstring :compile-at :run-time) 93 | "Test that LAMBDA's with docstrings are walked correctly" 94 | 95 | (let ((f (lambda (x) 96 | "A docstring" 97 | 98 | (declare (ignore x)) 99 | (info variable x)))) 100 | 101 | (is (info= '(:lexical t ((ignore . t))) 102 | (funcall f 1))))) 103 | -------------------------------------------------------------------------------- /src/common/macro-util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; macro-util.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :cl-environments.util) 27 | 28 | 29 | (defmacro! match-state (arg &body states) 30 | "Implements an FSM where each state may specify a pattern and a list 31 | of from states, when the argument matches the pattern of a 32 | particular and the current state is in the state's from states 33 | list, the FSM transitions to that state. Each element in STATES is 34 | a list of the following form: (STATE PATTERN [:FROM STATES] . BODY) 35 | where STATE is a symbol identifying the state, PATTERN is the 36 | pattern to be matched, and STATES is the optional list of from 37 | states (it and the :FROM keyword may be excluded), if there is only 38 | one state it does not have to be in a list. If a state specifies no 39 | from states, it is as if all declared states are specifed as from 40 | states. When a state becomes the current state the forms in its 41 | BODY are executed, in which the machine may either transition to 42 | the next state using the internal function (NEXT NEW-ARG) where 43 | NEW-ARG is the new argument to be matched against the patterns. If 44 | NEXT is never called in body the return value of the last form in 45 | BODY becomes the return value of the MATCH-STATE form. The intiial 46 | argument is given by evaluated the form ARG. The initial state may 47 | be optionally specified, when the first element of STATES is :START 48 | the second element is taken as the form to be evaluated to produce 49 | the start state, otherwise the start state defaults 50 | to :START. Patterns are matched in the order given, the first state 51 | whose pattern matches (both the argument pattern and FROM list) 52 | becomes the current state." 53 | 54 | (let ((next (intern (string 'next))) 55 | (from-state (intern (string 'from-state)))) 56 | (labels ((make-quote (thing) 57 | `(quote ,thing)) 58 | 59 | (extract-from (body) 60 | (if (eq (first body) :from) 61 | (let ((states (second body))) 62 | (values (if (listp states) 63 | (cons 'or (mapcar #'make-quote states)) 64 | (list 'quote states)) 65 | (cddr body))) 66 | (values '_ body))) 67 | 68 | (make-clause (state) 69 | (destructuring-bind (name pattern . body) state 70 | (multiple-value-bind (from body) (extract-from body) 71 | `(((guard ,from (not (and ,g!force (eq ,from-state ',name)))) ,pattern) 72 | (flet ((,next (,g!arg &key force (from ',name)) 73 | (,g!next from force ,g!arg))) 74 | (declare (ignorable (function,next))) 75 | ,@body)))))) 76 | 77 | (let-if ((start (second states) :start) 78 | (body (cddr states) states)) 79 | (eq (first states) :start) 80 | 81 | `(labels ((,g!next (,from-state ,g!force ,g!arg) 82 | (multiple-value-match (values ,from-state ,g!arg) 83 | ,@(mapcar #'make-clause body)))) 84 | (,g!next ,start nil ,arg)))))) 85 | 86 | 87 | 88 | -------------------------------------------------------------------------------- /cl-environments.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-environments.asd 2 | ;;;; 3 | ;;;; Copyright 2017-2019 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (asdf:defsystem #:cl-environments 27 | :description "Implements the CLTL2 environment access functionality 28 | for implementations which do not provide the 29 | functionality to the programmer." 30 | 31 | :author "Alexander Gutev" 32 | :license "MIT" 33 | :version "0.5" 34 | :serial t 35 | :components ((:module "src" 36 | :serial t 37 | :components 38 | 39 | ((:module "common" 40 | :serial t 41 | :components 42 | ((:file "package") 43 | (:file "let-over-lambda") 44 | (:file "util") 45 | (:file "macro-util"))) 46 | 47 | (:file "other/sbcl" 48 | :if-feature :sbcl) 49 | 50 | (:file "other/allegro" 51 | :if-feature :allegro) 52 | 53 | (:file "other/lispworks" 54 | :if-feature :lispworks) 55 | 56 | (:module 57 | "walker" 58 | :serial t 59 | :if-feature (:not (:or :sbcl :allegro :lispworks)) 60 | :components 61 | ((:file "package") 62 | (:file "util") 63 | (:file "walker") 64 | (:file "cl-environments") 65 | (:file "environment") 66 | (:file "declarations") 67 | (:file "lambda") 68 | (:file "let-forms") 69 | (:file "def-forms") 70 | (:file "special-forms") 71 | 72 | (:file "cltl2-interface" 73 | :if-feature (:not (:or :ccl :cmucl :ecl))) 74 | (:file "augment-environment" 75 | :if-feature (:not (:or :ccl :cmucl :ecl))) 76 | 77 | (:file "cltl2-interface.ccl-cmucl" 78 | :if-feature (:or :ccl :cmucl)) 79 | 80 | (:file "cltl2-interface.ecl" 81 | :if-feature :ecl) 82 | 83 | (:file "hook") 84 | (:file "cl-overrides"))) 85 | 86 | (:module 87 | "tools" 88 | :serial t 89 | :components 90 | ((:file "package") 91 | (:file "types")))))) 92 | 93 | :depends-on (#:alexandria 94 | #:anaphora 95 | #:optima 96 | #:collectors 97 | #+sbcl #:parse-declarations-1.0) 98 | 99 | :in-order-to ((asdf:test-op (asdf:test-op :cl-environments/test)))) 100 | 101 | (asdf:defsystem #:cl-environments/test 102 | :description "Tests for cl-environments." 103 | :author "Alexander Gutev" 104 | :license "MIT" 105 | :serial t 106 | :depends-on (:cl-environments :fiveam) 107 | :components ((:module "test" 108 | :components 109 | ((:module 110 | "cltl2" 111 | :serial t 112 | :components 113 | ((:file "test") 114 | (:file "let") 115 | (:file "letstar") 116 | (:file "flet") 117 | (:file "labels") 118 | (:file "macrolet") 119 | (:file "lambda") 120 | (:file "special-forms") 121 | (:file "def-forms") 122 | (:file "define-declaration") 123 | (:file "augment-environment")))))) 124 | 125 | :perform (asdf:test-op (o s) 126 | (uiop:symbol-call :cl-environments.test.cltl2 127 | :test-cl-environments))) 128 | -------------------------------------------------------------------------------- /test/cltl2/macrolet.lisp: -------------------------------------------------------------------------------- 1 | ;;;; macrolet.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test that environment information is extracted from MACROLET and SYMBOL-MACROLET forms. 27 | 28 | (defpackage :cl-environments.test.cltl2.macrolet-forms 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :fiveam)) 32 | 33 | (in-package :cl-environments.test.cltl2.macrolet-forms) 34 | 35 | (def-suite macrolet-forms 36 | :description "Test extraction of environment information from MACROLET and SYMBOL-MACROLET forms" 37 | :in cltl2-test) 38 | 39 | (in-suite macrolet-forms) 40 | 41 | (defmacro test-macro (form) 42 | form) 43 | 44 | (defun global-fn (a b c) 45 | (/ (* a b) c)) 46 | 47 | (define-symbol-macro global-symbol-macro "Hello World") 48 | 49 | (test (macro-types :compile-at :run-time) 50 | "Test extracting lexical macro information" 51 | 52 | (macrolet ((pass-through (form) 53 | "Pass through macro" 54 | form)) 55 | 56 | (is (info= '(:macro t nil) 57 | (info function pass-through))))) 58 | 59 | (test (macro-shadowing :compile-at :run-time) 60 | "Test shadowing of global macros by lexical macros" 61 | 62 | (is (info= '(:macro nil nil) 63 | (info function test-macro))) 64 | 65 | (macrolet ((test-macro (form) 66 | form)) 67 | 68 | (is (info= '(:macro t nil) 69 | (info function test-macro))))) 70 | 71 | (test (function-shadowing :compile-at :run-time) 72 | "Test shadowing of global functions by lexical macros" 73 | 74 | (is (info= '(:function nil nil) 75 | (info function global-fn))) 76 | 77 | (macrolet ((global-fn (form) 78 | form)) 79 | 80 | (is (info= '(:macro t nil) 81 | (info function global-fn))))) 82 | 83 | (test (symbol-macro-types :compile-at :run-time) 84 | "Test extraction of lexical symbol macro information" 85 | 86 | (symbol-macrolet ((sym-macro "a symbol macro") 87 | (sym-macro2 2)) 88 | 89 | (is-every info= 90 | ('(:symbol-macro t nil) (info variable sym-macro)) 91 | ('(:symbol-macro t nil) (info variable sym-macro2))))) 92 | 93 | (test (symbol-macro-shadowing :compile-at :run-time) 94 | "Test shadowing of global symbol macros with lexical symbol macros" 95 | 96 | (is (info= '(:symbol-macro nil nil) 97 | (info variable global-symbol-macro))) 98 | 99 | (symbol-macrolet ((global-symbol-macro "Local symbol macro")) 100 | (is (info= '(:symbol-macro t nil) 101 | (info variable global-symbol-macro))))) 102 | 103 | (test (var-shadow-symbol-macro :compile-at :run-time) 104 | "Test shadowing of symbol macros with lexical variables" 105 | 106 | (symbol-macrolet ((sym-macro "macro")) 107 | (is (info= '(:symbol-macro t nil) 108 | (info variable sym-macro))) 109 | 110 | (let ((sym-macro 1)) 111 | (declare (type integer sym-macro) 112 | (ignorable sym-macro)) 113 | 114 | (is (info= '(:lexical t ((type . integer))) 115 | (info variable sym-macro)))))) 116 | -------------------------------------------------------------------------------- /test/cltl2/letstar.lisp: -------------------------------------------------------------------------------- 1 | ;;;; letstar.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test that environment information is extracted from LET* forms 27 | 28 | (defpackage :cl-environments.test.cltl2.let*-forms 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :fiveam)) 32 | 33 | (in-package :cl-environments.test.cltl2.let*-forms) 34 | 35 | (def-suite let*-forms 36 | :description "Test extraction of environment information from LET* forms" 37 | :in cltl2-test) 38 | 39 | (in-suite let*-forms) 40 | 41 | (defvar *global-var* "hello world") 42 | 43 | (test (let*-binding-types :compile-at :run-time) 44 | (let* ((x 1) 45 | (y "hello")) 46 | (declare (type integer x) 47 | (type string y) 48 | (ignorable x y)) 49 | 50 | (is (info= 51 | '(:lexical t ((type . integer))) 52 | (info variable x))) 53 | 54 | (is (info= 55 | '(:lexical t ((type . string))) 56 | (info variable y))) 57 | 58 | (is (info= 59 | '(:special nil nil) 60 | (info variable *global-var*))) 61 | 62 | (is (info= 63 | '(nil nil nil) 64 | (info variable z))))) 65 | 66 | (test (let*-binding-special :compile-at :run-time) 67 | (let* ((dvar (+ 1 2)) 68 | (lvar (+ 2 3)) 69 | (*global-var* "bye")) 70 | (declare (special dvar) 71 | (type number lvar dvar) 72 | (ignorable lvar)) 73 | 74 | (is (info= 75 | #-sbcl '(:special t (#-ecl (type . number))) 76 | #+sbcl '(:special nil ((type . number))) 77 | 78 | (info variable dvar))) 79 | 80 | (is (info= 81 | '(:lexical t ((type . number))) 82 | (info variable lvar))) 83 | 84 | (is (info= 85 | #-sbcl '(:special t nil) 86 | #+sbcl '(:special nil nil) 87 | 88 | (info variable *global-var*))))) 89 | 90 | (test (let*-binding-dynamic-extent :compile-at :run-time) 91 | (let* ((func (lambda (a b) (+ a b)))) 92 | (declare (dynamic-extent func) 93 | (type (function (number number) number) func) 94 | (ignorable func)) 95 | 96 | (is (info= 97 | ;; CMUCL ignores DYNAMIC-EXTENT here 98 | #-(or cmucl ecl) '(:lexical t ((dynamic-extent . t) 99 | (type . (function (number number) number)))) 100 | 101 | #+(or cmucl ecl) '(:lexical t ((type . (function (number number) number)))) 102 | 103 | (info variable func))))) 104 | 105 | (test (let*-info-in-init-form :compile-at :run-time) 106 | (let ((outer-var (* 8 7))) 107 | (declare (type integer outer-var) 108 | (ignorable outer-var)) 109 | 110 | (let* ((a (progn 111 | (is (info= 112 | '(:lexical t ((type . integer))) 113 | (info variable outer-var))) 114 | 1)) 115 | 116 | (b (progn 117 | (is (info= 118 | '(:lexical t ((type . integer))) 119 | (info variable outer-var))) 120 | 121 | (is (info= 122 | '(:lexical t nil) 123 | (info variable a))))) 124 | 125 | (outer-var "string")) 126 | 127 | (declare (special outer-var) 128 | (type string outer-var) 129 | (dynamic-extent outer-var) 130 | (ignorable a b)) 131 | 132 | (is (info= 133 | #-(or sbcl cmucl ecl) '(:special t ((dynamic-extent . t) (type . string))) 134 | #+sbcl '(:special nil ((type . string))) 135 | #+(or cmucl ecl) '(:special t (#-ecl (type . string))) 136 | 137 | (info variable outer-var)))))) 138 | -------------------------------------------------------------------------------- /src/tools/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; types.lisp 2 | ;;;; 3 | ;;;; Copyright 2019 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Functions for obtaining the types of forms based on the type 27 | ;;;; information stored in the environment. 28 | 29 | (in-package :cl-environments.tools) 30 | 31 | 32 | (defun get-return-types (forms env) 33 | "Determines the return value type of each form in FORMS, in the 34 | environment ENV. Returns a list where each element is the 35 | return-value type of the corresponding form in FORMS." 36 | 37 | (mapcar (rcurry #'get-value-type env) forms)) 38 | 39 | (defun get-value-type (form env &optional (n 0)) 40 | "Determines the type of the N'th value returned by FORM, in the 41 | environment ENV. If N > 0 and there is no information about the 42 | type of the N'th value, NIL is returned." 43 | 44 | (match (get-return-type form env) 45 | ((list* 'values types) 46 | (nth n types)) 47 | 48 | (type 49 | (if (zerop n) 50 | type 51 | nil)))) 52 | 53 | (defun get-return-type (form env) 54 | "Determines the type of the return value of the form FORM, in the 55 | environment ENV." 56 | 57 | (flet ((get-ftype (decl) 58 | (match (cdr (assoc 'ftype decl)) 59 | ((list 'function _ (and (not (eq '*)) return-type)) 60 | return-type) 61 | 62 | (_ t))) 63 | 64 | (get-vtype (decl) 65 | (aif (assoc 'type decl) 66 | (cdr it) 67 | t))) 68 | 69 | (multiple-value-bind (form expanded?) (macroexpand-1 form env) 70 | (if expanded? 71 | (get-return-type form env) 72 | 73 | (match form 74 | ((list 'cl:the type _) 75 | type) 76 | 77 | ((list* op args) 78 | (multiple-value-bind (type local decl) (function-information op env) 79 | (declare (ignore local)) 80 | 81 | (case type 82 | (:function 83 | (get-ftype decl)) 84 | 85 | (:special-form 86 | (get-special-form-return-type op args env)) 87 | 88 | (otherwise t)))) 89 | 90 | ((satisfies symbolp) 91 | (multiple-value-bind (type local decl) (variable-information form env) 92 | (declare (ignore local)) 93 | 94 | (case type 95 | (:constant 96 | `(eql ,(eval form))) 97 | 98 | ((:lexical :special) 99 | (get-vtype decl)) 100 | 101 | (otherwise t)))) 102 | 103 | ((guard value (constantp value env)) 104 | (constant-type value)) 105 | 106 | (_ t)))))) 107 | 108 | (defun constant-type (value) 109 | "Return the type specifier of a constant value. 110 | 111 | If the value is a CHARACTER, NUMBER or SYMBOL an EQL type specifier 112 | is returned. Otherwise the type specifier returned by TYPE-OF is 113 | returned. 114 | 115 | VALUE is the constant value." 116 | 117 | (typecase value 118 | ((or number character symbol) `(eql ,value)) 119 | (otherwise 120 | (type-of value)))) 121 | 122 | (defun get-special-form-return-type (operator operands env) 123 | "Determine the type of value returned by a form in which the 124 | operator is a special operator." 125 | 126 | (case operator 127 | (cl:progn 128 | (get-return-type (lastcar operands) env)) 129 | 130 | (cl:quote 131 | (when (length= operands 1) 132 | `(eql ,(first operands)))) 133 | 134 | (cl:setq 135 | (when (evenp (length operands)) 136 | (get-return-type (lastcar operands) env))))) 137 | -------------------------------------------------------------------------------- /src/walker/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp 2 | ;;;; 3 | ;;;; Copyright 2018 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :cl-environments.cltl2) 27 | 28 | ;;; Conditions 29 | 30 | (define-condition walk-program-error (program-error) 31 | ((message :initarg :message 32 | :reader message 33 | :initform nil)) 34 | 35 | (:documentation 36 | "Condition raised when a syntax error is encountered in code being 37 | walked.")) 38 | 39 | (defun skip-walk (&optional c) 40 | "Invokes the SKIP-WALK restart. The SKIP-WALK restart skips walking 41 | over the form and simply returns it as is." 42 | 43 | (declare (ignore c)) 44 | (invoke-restart 'skip-walk)) 45 | 46 | 47 | (defun walk-error (form msg) 48 | "Signals a WALK-PROGRAM-ERROR with a SKIP-WALK restart established, 49 | which returns FORM if invoked. MSG is the value of the MESSAGE slot 50 | of the WALK-PROGRAM-ERROR condition object which is to be 51 | signaled." 52 | 53 | (restart-case 54 | (error 'walk-program-error :message msg) 55 | (skip-walk () form))) 56 | 57 | 58 | ;;; Functions 59 | 60 | (defun next-2 (list) 61 | "Equivalent to CDDR however if LIST has only one element left (that 62 | is the original list being traversed is not of even length) signals 63 | a WALK-PROGRAM-ERROR. Does not establish any restarts." 64 | 65 | (when list 66 | (aif (cdr list) 67 | (cdr it) 68 | (error 'walk-program-error :message "List of uneven length")))) 69 | 70 | 71 | 72 | ;;; Optima Patterns 73 | 74 | (defpattern optional (arg) 75 | `(or ,arg nil)) 76 | 77 | 78 | ;;; Macros 79 | 80 | (defmacro! skip-walk-errors (&body body) 81 | "Surrounds BODY in a HANDLER-BIND which invokes the SKIP-WALK 82 | restart when the WALK-PROGRAM-ERROR condition is signaled." 83 | 84 | `(handler-bind ((walk-program-error #'skip-walk)) 85 | ,@body)) 86 | 87 | (defmacro! match-form (pattern o!form &body body) 88 | "Performs list destructuring on FORM with PATTERN being the list 89 | structure. If FORM does not match the structure described by 90 | PATTERN a WALK-PROGRAM-ERROR is signaled, with a SKIP-WALK restart 91 | established. PATTERN may contain nested lists, dotted lists, 92 | &OPTIONAL (without init-forms or supplied-p variables) and &REST 93 | parameters. The difference between &REST and a dotted list is that 94 | the &REST var is checked to be a proper list whereas no type 95 | checking is performed for a dotted list." 96 | 97 | (labels ((list->cons (list) 98 | (match list 99 | ((list '&rest var) 100 | `(guard ,var (typep ,var 'proper-list))) 101 | 102 | ((cons '&optional rest) 103 | `(or ,(list->cons rest) 104 | nil)) 105 | 106 | ((list 'quote arg) 107 | (list 'quote arg)) 108 | 109 | ((cons item rest) 110 | `(cons ,(list->cons item) 111 | ,(list->cons rest))) 112 | 113 | (_ list)))) 114 | 115 | `(match ,g!form 116 | (,(list->cons pattern) 117 | ,@body) 118 | (_ (walk-error ,g!form "Invalid form syntax"))))) 119 | 120 | (defmacro! check-list (o!thing &body body) 121 | "Checks that THING is a proper list and evaluates the forms in 122 | BODY. If THING is not a proper list, a WALK-ERROR is signaled, with 123 | a SKIP-WALK restart established (which simply returns THING)." 124 | 125 | `(if (proper-list-p ,g!thing) 126 | (progn ,@body) 127 | (walk-error ,g!thing "Invalid form syntax"))) 128 | -------------------------------------------------------------------------------- /src/walker/cltl2-interface.lisp: -------------------------------------------------------------------------------- 1 | ;;;; cltl2-interface.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Implements the VARIABLE-INFORMATION, FUNCTION-INFORMATION and 27 | ;;;; DECLARATION-INFORMATION FUNCTIONS as specified in Common Lisp the 28 | ;;;; Language 2 (CLTL2) 29 | 30 | (in-package :cl-environments.cltl2) 31 | 32 | (defun variable-information (variable &optional env) 33 | "Returns information about the variable binding for the symbol 34 | VARIABLE, in the environment ENV. Returns three values: the first 35 | value is the binding type nil, :SPECIAL, :LEXICAL, :SYMBOL-MACRO 36 | or :CONSTANT, the second value is true if there is a local binding 37 | and the third value is an association list containing declaration 38 | information." 39 | 40 | (slot-values (binding-type local declarations) 41 | (variable-binding variable (extended-environment env)) 42 | (values binding-type local declarations))) 43 | 44 | (defun function-information (function &optional env) 45 | "Returns information about the function binding for the symbol 46 | FUNCTION in the environment ENV. Returns three values: the first 47 | value is the binding type nil, :FUNCTION, :MACRO or :SPECIAL-FORM, 48 | the second value is true if there is a local binding and the third 49 | value is an association list containing declaration information." 50 | 51 | (slot-values (binding-type local declarations) 52 | (function-binding function (extended-environment env)) 53 | (values binding-type local declarations))) 54 | 55 | (defun declaration-information (decl-name &optional env) 56 | "Returns information about the declaration DECL-NAME in the 57 | environment ENV." 58 | 59 | (nth-value 0 (declaration-info decl-name (extended-environment env)))) 60 | 61 | (defun extended-environment (env) 62 | "Retrieve the extended environment object for ENV. 63 | 64 | If ENV is a lexical environment the extended environment is 65 | retrieved using GET-ENVIRONMENT, otherwise if it is an 66 | `ENVIRONMENT' object it is returned as is." 67 | 68 | (typecase env 69 | (environment env) 70 | (otherwise (get-environment env)))) 71 | 72 | 73 | (defmacro define-declaration (decl-name (arg-var &optional (env-var (gensym "ENV"))) &body body) 74 | "Defines a handler function for the user-defined declaration 75 | DECL-NAME. ARG-VAR is a symbol bound to the argument list of the 76 | declaration expression, ENV-VAR is a symbol bound to the lexical 77 | environment in which the declaration appears. The function should 78 | return two values: the first value is a keyword identifying whether 79 | the declaration applies to variable bindings (:VARIABLE), function 80 | bindings (:FUNCTION) or is a free declaration :DECLARE. If the 81 | first value is :VARIABLE or :FUNCTION the second must be a list 82 | where each element is of the form (BINDING-NAME KEY VALUE) where 83 | BINDING-NAME is the function or variable binding to which the 84 | declaration applies, and (KEY . VALUE) is the key value pair added 85 | to the declaration list of the binding. If the first value 86 | is :DECLARE the second value must be a CONS of the (KEY . VALUE), 87 | which is added to the declarations list of the lexical 88 | environment." 89 | 90 | `(eval-when (:compile-toplevel :load-toplevel :execute) 91 | (declaim (declaration ,decl-name)) 92 | (setf (declaration-function ',decl-name) 93 | (lambda (,arg-var ,env-var) 94 | (declare (ignorable ,env-var)) 95 | ,@body)) 96 | ',decl-name)) 97 | -------------------------------------------------------------------------------- /test/cltl2/let.lisp: -------------------------------------------------------------------------------- 1 | ;;;; let.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test that environment information is extracted from LET forms. 27 | 28 | (defpackage :cl-environments.test.cltl2.let-forms 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :fiveam)) 32 | 33 | (in-package :cl-environments.test.cltl2.let-forms) 34 | 35 | (def-suite let-forms 36 | :description "Test extraction of environment information from LET forms" 37 | :in cltl2-test) 38 | 39 | (in-suite let-forms) 40 | 41 | (defvar *global-var* "hello world") 42 | 43 | (test (let-binding-types :compile-at :run-time) 44 | (let ((x 1) 45 | (y "hello")) 46 | (declare (type integer x) 47 | (type string y) 48 | (ignorable x y)) 49 | 50 | (is (info= 51 | '(:lexical t ((type . integer))) 52 | (info variable x))) 53 | 54 | (is (info= 55 | '(:lexical t ((type . string))) 56 | (info variable y))) 57 | 58 | (is (info= 59 | '(:special nil nil) 60 | (info variable *global-var*))) 61 | 62 | (is (info= 63 | '(nil nil nil) 64 | (info variable z))))) 65 | 66 | (test (let-binding-special :compile-at :run-time) 67 | (let ((dvar (+ 1 2)) 68 | (lvar (+ 2 3)) 69 | (*global-var* "bye")) 70 | (declare (special dvar) 71 | (type number lvar dvar) 72 | (ignorable lvar)) 73 | 74 | (is (info= 75 | ;; SBCL does not recognize shadowed binding as local binding 76 | #-sbcl '(:special t (#-ecl (type . number))) 77 | #+sbcl '(:special nil ((type . number))) 78 | 79 | (info variable dvar))) 80 | 81 | (is (info= 82 | '(:lexical t ((type . number))) 83 | (info variable lvar))) 84 | 85 | (is (info= 86 | #-sbcl '(:special t nil) 87 | #+sbcl '(:special nil nil) 88 | 89 | (info variable *global-var*))))) 90 | 91 | (test (let-binding-dynamic-extent :compile-at :run-time) 92 | (let ((func (lambda (a b) (+ a b)))) 93 | (declare (dynamic-extent func) 94 | (type (function (number number) number) func) 95 | (ignorable func)) 96 | 97 | (is (info= 98 | ;; CMUCL ignores DYNAMIC-EXTENT here 99 | ;; ECL ignores DYNAMIC-EXTENT entirely 100 | 101 | #-(or cmucl ecl) '(:lexical t ((dynamic-extent . t) 102 | (type . (function (number number) number)))) 103 | 104 | #+(or cmucl ecl) '(:lexical t ((type . (function (number number) number)))) 105 | 106 | (info variable func))))) 107 | 108 | (test (let-info-in-init-form :compile-at :run-time) 109 | (let ((outer-var (* 8 7))) 110 | (declare (type integer outer-var) 111 | (ignorable outer-var)) 112 | 113 | (let ((a (progn 114 | (is (info= 115 | '(:lexical t ((type . integer))) 116 | (info variable outer-var))) 117 | 1)) 118 | 119 | (b (progn 120 | (is (info= 121 | '(:lexical t ((type . integer))) 122 | (info variable outer-var))) 123 | 124 | (is (info= 125 | '(nil nil nil) 126 | (info variable a))))) 127 | 128 | (outer-var "string")) 129 | 130 | (declare (special outer-var) 131 | (type string outer-var) 132 | (dynamic-extent outer-var) 133 | (ignorable a b)) 134 | 135 | (is (info= 136 | ;; Not recognized as local binding on SBCL, and DYNAMIC-EXTENT 137 | ;; declaration discarded on SBCL and CMUCL 138 | 139 | ;; ECL does not record the types of local special variables 140 | 141 | #-(or sbcl cmucl ecl) '(:special t ((dynamic-extent . t) (type . string))) 142 | #+sbcl '(:special nil ((type . string))) 143 | #+(or cmucl ecl) '(:special t (#-ecl (type . string))) 144 | 145 | (info variable outer-var)))))) 146 | -------------------------------------------------------------------------------- /test/cltl2/def-forms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; def-forms.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test extracting environment information in definition forms 27 | 28 | (defpackage :cl-environments.test.cltl2.definition-forms 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :alexandria 32 | :fiveam)) 33 | 34 | (in-package :cl-environments.test.cltl2.definition-forms) 35 | 36 | (def-suite definition-forms 37 | :description "Test extraction of environment information in definition forms" 38 | :in cltl2-test) 39 | 40 | (in-suite definition-forms) 41 | 42 | (defun test-function (a) 43 | "Test function to check that DEFUN bodies are walked." 44 | 45 | (declare (ignore a)) 46 | (info variable a)) 47 | 48 | (defmacro test-macro (form) 49 | "Test Macro to check that DEFMACRO bodies are walked." 50 | 51 | (declare (ignore form)) 52 | `',(info variable form)) 53 | 54 | (defgeneric test-generic (a) 55 | (:method ((a integer)) 56 | (declare (type integer a)) 57 | (1+ a) 58 | (info variable a))) 59 | 60 | (defmethod test-generic ((b string)) 61 | (declare (type string b)) 62 | (concatenate 'string "string" b) 63 | (info variable b)) 64 | 65 | (defparameter *test-param* (cl:let ((var)) 66 | (declare (type null var)) 67 | (list var) 68 | 69 | (info variable var)) 70 | "Tests walking DEFPARAMETER") 71 | 72 | (defvar *test-var* (cl:let ((var)) 73 | (declare (type null var)) 74 | (list var) 75 | 76 | (info variable var)) 77 | 78 | "Tests walking DEFVAR") 79 | 80 | (defconstant +a-constant+ 15) 81 | 82 | (define-symbol-macro symbol-mac "symbol-macro") 83 | 84 | (declaim (declaration my-declaration)) 85 | 86 | (test defun 87 | "Test extracting environment information in DEFUN" 88 | 89 | (is (info= '(:lexical t ((ignore . t))) (test-function 1)))) 90 | 91 | (test defmacro 92 | "Test extracting environment information in DEFMACRO" 93 | 94 | (is (info= #-ecl '(:lexical t ((ignore . t))) 95 | #+ecl '(:lexical t nil) 96 | (test-macro 'x)))) 97 | 98 | (test defgeneric 99 | "Test extracting environment information in DEFGENERIC" 100 | 101 | (is (info= '(:lexical t ((type . integer))) (test-generic 100)))) 102 | 103 | (test defmethod 104 | "Test extracting environment information in DEFMETHOD" 105 | 106 | (is (info= '(:lexical t ((type . string))) (test-generic "hello")))) 107 | 108 | (test defparameter 109 | "Test extracting environment information in DEFPARAMETER" 110 | 111 | (is (info= '(:lexical t ((type . null))) *test-param*))) 112 | 113 | (test defvar 114 | "Test extracting environment information in DEFPARAMETER" 115 | 116 | (is (info= '(:lexical t ((type . null))) *test-var*))) 117 | 118 | (test (declaim :compile-at :run-time) 119 | "Test that global declarations are added to environment" 120 | 121 | ;; Fails on CMUCL, where the native DECLARATION-INFORMATION function 122 | ;; is used. 123 | 124 | (is (member 'my-declaration 125 | (first (info declaration declaration))))) 126 | 127 | (test (global-definitions :compile-at :run-time) 128 | "Test that global definitions added to environment" 129 | 130 | (is (info= '(:function nil nil) 131 | (info function test-function))) 132 | 133 | (is (info= '(:macro nil nil) 134 | (info function test-macro))) 135 | 136 | (is (info= '(:function nil nil) 137 | (info function test-generic))) 138 | 139 | (is (info= '(:special nil nil) 140 | (info variable *test-param*))) 141 | 142 | (is (info= '(:special nil nil) 143 | (info variable *test-var*))) 144 | 145 | (is (info= '(:constant nil nil) 146 | (info variable +a-constant+))) 147 | 148 | (is (info= '(:symbol-macro nil nil) 149 | (info variable symbol-mac)))) 150 | -------------------------------------------------------------------------------- /test/cltl2/labels.lisp: -------------------------------------------------------------------------------- 1 | ;;;; labels.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test that environment information is extracted from LABELS forms. 27 | 28 | (defpackage :cl-environments.test.cltl2.labels-forms 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :fiveam)) 32 | 33 | (in-package :cl-environments.test.cltl2.labels-forms) 34 | 35 | (def-suite labels-forms 36 | :description "Test extraction of environment information from LABELS forms" 37 | :in cltl2-test) 38 | 39 | (in-suite labels-forms) 40 | 41 | (defun global-fn (a b c) 42 | (/ (* a b) c)) 43 | 44 | (declaim (ftype (function (integer integer integer) number) global-fn)) 45 | 46 | (defmacro test-macro (form) 47 | form) 48 | 49 | (test (function-types :compile-at :run-time) 50 | "Test extracting function information" 51 | 52 | (labels ((inc (a) 53 | (1+ a)) 54 | 55 | (add (a b) 56 | (+ a b))) 57 | 58 | (declare (ftype (function (integer) integer) inc) 59 | (ftype (function (number number) number) add) 60 | (ignorable #'inc #'add)) 61 | 62 | (declare (dynamic-extent #'inc) 63 | (inline add) 64 | (notinline global-fn)) 65 | 66 | (is (info= 67 | #-(or cmucl ecl) 68 | '(:function t ((ftype . (function (integer) integer)) 69 | (dynamic-extent . t))) 70 | 71 | #+(or cmucl ecl) 72 | '(:function t ((ftype . (function (integer) integer)))) 73 | 74 | (info function inc))) 75 | 76 | (is (info= 77 | '(:function t ((ftype . (function (number number) number)) 78 | (inline . inline))) 79 | 80 | (info function add))) 81 | 82 | (is (info= 83 | ;; For some reason CCL doesn't store global declarations. 84 | #-ccl '(:function nil ((ftype . (function (integer integer integer) number)) 85 | (inline . notinline))) 86 | #+ccl '(:function nil ((inline . notinline))) 87 | 88 | (info function global-fn))) 89 | 90 | (is (info= 91 | '(:macro nil nil) 92 | (info function test-macro))) 93 | 94 | (is (info= 95 | '(:macro nil nil) 96 | (info function cl:defun))) 97 | 98 | (is (info= 99 | '(:special-form nil nil) 100 | (info function cl:if))) 101 | 102 | (is (info= 103 | '(nil nil nil) 104 | (info function not-a-function))))) 105 | 106 | (test (shadowing :compile-at :run-time) 107 | "Test lexical shadowing of functions" 108 | 109 | (labels ((f2 (a b) 110 | (+ a b))) 111 | (declare (ftype (function (number number) number) f2) 112 | (inline f2) 113 | (ignorable #'f2)) 114 | 115 | (labels ((f1 (x) 116 | (declare (type integer x) 117 | (ignore x)) 118 | 119 | (values 120 | (info variable x) 121 | (info function f2) 122 | (info function global-fn))) 123 | 124 | (f2 (a b) 125 | (declare (ignore a b)) 126 | 127 | (values 128 | (info variable a) 129 | (info variable b) 130 | (info function f1))) 131 | 132 | (global-fn (x) x)) 133 | 134 | (declare (notinline f2) 135 | (ignore #'global-fn) 136 | (ignorable #'f1 #'f2)) 137 | 138 | (multiple-value-bind (info-x info-f2 info-global-fn) 139 | (f1 1) 140 | 141 | (is-every info= 142 | ('(:lexical t ((type . integer) #-ecl(ignore . t))) info-x) 143 | ('(:function t nil) info-f2) 144 | ('(:function t nil) info-global-fn))) 145 | 146 | (multiple-value-bind (info-a info-b info-f1) 147 | (f2 1 2) 148 | 149 | (is-every info= 150 | ('(:lexical t ((ignore . t))) info-a) 151 | ('(:lexical t ((ignore . t))) info-b) 152 | ('(:function t nil) info-f1))) 153 | 154 | (is (info= 155 | '(:function t ((inline . notinline))) 156 | (info function f2))) 157 | 158 | (is (info= 159 | #-(or sbcl ccl ecl) '(:function t ((ignore . t))) 160 | #+(or sbcl ccl ecl) '(:function t nil) 161 | 162 | (info function global-fn)))))) 163 | -------------------------------------------------------------------------------- /src/other/lispworks.lisp: -------------------------------------------------------------------------------- 1 | ;;;; allegro.lisp 2 | ;;;; 3 | ;;;; Copyright 2018-2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (defpackage :cl-environments.cltl2 27 | (:use :common-lisp 28 | :alexandria 29 | :optima 30 | :hcl 31 | :cl-environments.util) 32 | 33 | (:shadow :define-declaration) 34 | 35 | (:export :variable-information 36 | :function-information 37 | :declaration-information 38 | :define-declaration 39 | 40 | :augment-environment 41 | :enclose 42 | :parse-macro 43 | :enclose-macro 44 | 45 | :in-environment 46 | :augmented-macroexpand-1 47 | :augmented-macroexpand 48 | :augmented-macro-function 49 | :augmented-get-setf-expansion 50 | :augmented-compiler-macro-function 51 | :augmented-constantp 52 | 53 | :enable-hook 54 | :disable-hook 55 | 56 | :walk-environment)) 57 | 58 | (defpackage :cl-environments-cl 59 | (:nicknames :cl-environments) 60 | (:use :common-lisp 61 | :cl-environments.util 62 | :cl-environments.cltl2) 63 | 64 | (:export :variable-information 65 | :function-information 66 | :declaration-information 67 | :define-declaration 68 | 69 | :augment-environment 70 | :enclose 71 | :enclose-macro 72 | 73 | :in-environment 74 | :augmented-macroexpand-1 75 | :augmented-macroexpand 76 | :augmented-macro-function 77 | :augmented-get-setf-expansion 78 | :augmented-compiler-macro-function 79 | :augmented-constantp 80 | 81 | :enable-hook 82 | :disable-hook 83 | 84 | :walk-environment)) 85 | 86 | (in-package :cl-environments.cltl2) 87 | 88 | ;; Declaration name is included in arguments 89 | 90 | (defmacro define-declaration (decl-name (arg-var &optional (env-var (gensym "ENV"))) &body body) 91 | (with-gensyms (args) 92 | `(hcl:define-declaration ,decl-name (,args ,env-var) 93 | (declare (ignorable ,env-var)) 94 | (let ((,arg-var (rest ,args))) 95 | ,@body)))) 96 | 97 | (defun enclose-macro (name lambda-list body &optional env) 98 | (enclose (parse-macro name lambda-list body env) env)) 99 | 100 | (defmacro in-environment ((env-var &optional (environment env-var)) (&rest bindings) &body forms) 101 | (flet ((make-binding (binding) 102 | (match binding 103 | ((type symbol) 104 | (list binding binding)) 105 | 106 | (_ binding)))) 107 | 108 | `(let ((,env-var ,environment) ,@(mapcar #'make-binding bindings)) 109 | ,@forms))) 110 | 111 | (defun augmented-macroexpand-1 (form &optional env) 112 | (macroexpand-1 form env)) 113 | 114 | (defun augmented-macroexpand (form &optional env) 115 | (macroexpand form env)) 116 | 117 | (defun augmented-macro-function (name &optional env) 118 | (macro-function name env)) 119 | 120 | (defun augmented-get-setf-expansion (form &optional env) 121 | (get-setf-expansion form env)) 122 | 123 | (defun augmented-compiler-macro-function (name &optional environment) 124 | (compiler-macro-function name environment)) 125 | 126 | (defun augmented-constantp (form &optional environment) 127 | (constantp form environment)) 128 | 129 | 130 | (defun enable-hook (&optional (previous-hook *macroexpand-hook*)) 131 | "Does nothing, provided for compatibility with implementations where 132 | the code walker is required." 133 | 134 | (declare (ignore previous-hook))) 135 | 136 | (defun disable-hook (&optional (previous-hook *previous-hook*)) 137 | "Does nothing, provided for compatibility with implementations where 138 | the code walker is required." 139 | 140 | (declare (ignore previous-hook))) 141 | 142 | (defmacro walk-environment (&body forms) 143 | `(progn ,@forms)) 144 | 145 | (defmacro disable-walker (&body body) 146 | `(progn ,@body)) 147 | 148 | ;;; Reexport symbols in CL package 149 | 150 | (in-package :cl-environments-cl) 151 | 152 | (eval-when (:compile-toplevel :load-toplevel :execute) 153 | (reexport-all-symbols :cl)) 154 | -------------------------------------------------------------------------------- /test/cltl2/test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; test.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Master test suite for full code walker implementation 27 | 28 | (defpackage :cl-environments.test.cltl2 29 | (:use :cl-environments-cl 30 | :cl-environments.util 31 | 32 | :alexandria 33 | :fiveam) 34 | 35 | (:import-from :cl-environments.util 36 | :symb) 37 | 38 | (:export :cltl2-test 39 | :in-lexical-environment 40 | :info 41 | :info=)) 42 | 43 | (in-package :cl-environments.test.cltl2) 44 | 45 | (def-suite cltl2-test 46 | :description "Tests for the full CLTL2 implementation using code-walker") 47 | 48 | (in-suite cltl2-test) 49 | 50 | (defun test-cl-environments () 51 | (run! 'cltl2-test)) 52 | 53 | 54 | ;;; Utilities 55 | 56 | (defmacro in-lexical-environment ((env-var) &body forms) 57 | "Evaluate forms in the current lexical environment. 58 | 59 | ENV-VAR is the name of the variable to which the lexical 60 | environment is bound. This binding is visible to FORMS. 61 | 62 | FORMS is the list of forms which are evaluated in an explicit 63 | PROGN. The forms are evaluated during macroexpansion, and this form 64 | is substituted by a quoted list containing the all the return 65 | values of the last form in FORMS." 66 | 67 | (with-gensyms (expand) 68 | `(macrolet ((,expand (&environment ,env-var) 69 | `',(multiple-value-list (progn ,@forms)))) 70 | (,expand)))) 71 | 72 | (defmacro info (type thing) 73 | "Retrieve information about a binding/declaration from the environment. 74 | 75 | TYPE is the type of binding to retrieve information for, either 76 | VARIABLE, FUNCTION or DECLARATION. 77 | 78 | THING is the name of the binding (or declaration in the case of 79 | TYPE being DECLARATION) of which to retrieve the information." 80 | 81 | (with-gensyms (env) 82 | `(in-lexical-environment (,env) 83 | (,(symb type '-information) ',thing ,env)))) 84 | 85 | (defun decl= (got expected) 86 | "Check that the declaration information GOT has all the keys in the 87 | declaration information EXPECTED. It may have more keys." 88 | 89 | (loop 90 | for (key . value) in expected 91 | for assoc = (assoc key got) 92 | always (and assoc (decl-key= key (cdr assoc) value)))) 93 | 94 | (defun info= (expected got) 95 | "Check that the binding information GOT is equal to expected. 96 | 97 | GOT and EXPECTED are expected to be lists of three elements the 98 | first two being the binding type and whether it is local or global, 99 | both are compared directly with EQ. The third element is the 100 | declaration information compared with DECL=" 101 | 102 | (destructuring-bind (&optional got-type got-local got-decls) got 103 | (destructuring-bind (exp-type exp-local exp-decls) expected 104 | (and (eq got-type exp-type) 105 | (eq got-local exp-local) 106 | (decl= got-decls exp-decls))))) 107 | 108 | 109 | ;;;; Comparing various declaration keys 110 | 111 | (defgeneric decl-key= (key got exp) 112 | (:documentation 113 | "Compare the values for a given declaration information key.")) 114 | 115 | (defmethod decl-key= ((key t) got exp) 116 | "Compare values with EQUAL." 117 | 118 | (equal got exp)) 119 | 120 | 121 | ;;; SUBTYPEP does not work on ABCL for function types. It's not 122 | ;;; necessary anyway since ABCL does not provided FUNCTION-INFORMATION 123 | ;;; there the result should be exactly as expected. 124 | 125 | #-abcl 126 | (defmethod decl-key= ((key (eql 'type)) got exp) 127 | "Compare TYPE declaration information fields. 128 | 129 | Returns true if the type GOT is a subtype of the expected type 130 | EXP." 131 | 132 | (subtypep got exp)) 133 | 134 | #-abcl 135 | (defmethod decl-key= ((key (eql 'ftype)) got exp) 136 | "Compare FTYPE declaration information fields. 137 | 138 | Returns true if the type GOT is a subtype of the expected type 139 | EXP." 140 | 141 | (subtypep got exp)) 142 | -------------------------------------------------------------------------------- /src/common/let-over-lambda.lisp: -------------------------------------------------------------------------------- 1 | ;; This file contains utility functions and macros, taken from 2 | ;; let-over-lambda, which are used in the cl-environments project. 3 | ;; The only modification is that the functions and macros have been 4 | ;; moved from the :let-over-lambda package to the 5 | ;; :cl-environments.util package, and the flatten function has been 6 | ;; renamed to lol-flatten to avoid conflicts with the flatten function 7 | ;; from the alexandria package. 8 | 9 | ;; Antiweb (C) Doug Hoyte 10 | 11 | ;; This is a "production" version of LOL with bug-fixes 12 | ;; and new features in the spirit of the book. 13 | 14 | ;; See http://letoverlambda.com 15 | 16 | ;; This is the source code for the book 17 | ;; _Let_Over_Lambda_ by Doug Hoyte. 18 | ;; This code is (C) 2002-2008, Doug Hoyte. 19 | ;; 20 | ;; You are free to use, modify, and re-distribute 21 | ;; this code however you want, except that any 22 | ;; modifications must be clearly indicated before 23 | ;; re-distribution. There is no warranty, 24 | ;; expressed nor implied. 25 | ;; 26 | ;; Attribution of this code to me, Doug Hoyte, is 27 | ;; appreciated but not necessary. If you find the 28 | ;; code useful, or would like documentation, 29 | ;; please consider buying the book! 30 | 31 | ;; Modifications by "the Phoeron" Colin J.E. Lupton, 2012--2014 32 | ;; - Support for ASDF/Quicklisp 33 | ;; - Cheap hacks to support new Backquote implementation in SBCL v1.2.2 34 | 35 | (in-package :cl-environments.util) 36 | 37 | #+sbcl 38 | (eval-when (:compile-toplevel :execute) 39 | (handler-case 40 | (progn 41 | (sb-ext:assert-version->= 1 2 2) 42 | (setq *features* (remove 'old-sbcl *features*))) 43 | (error () 44 | (pushnew 'old-sbcl *features*)))) 45 | 46 | (defun group (source n) 47 | (if (zerop n) (error "zero length")) 48 | (labels ((rec (source acc) 49 | (let ((rest (nthcdr n source))) 50 | (if (consp rest) 51 | (rec rest (cons 52 | (subseq source 0 n) 53 | acc)) 54 | (nreverse 55 | (cons source acc)))))) 56 | (if source (rec source nil) nil))) 57 | 58 | (eval-when (:compile-toplevel :execute :load-toplevel) 59 | (defun mkstr (&rest args) 60 | (with-output-to-string (s) 61 | (dolist (a args) (princ a s)))) 62 | 63 | (defun symb (&rest args) 64 | (values (intern (apply #'mkstr args)))) 65 | 66 | (defun lol-flatten (x) 67 | (labels ((rec (x acc) 68 | (cond ((null x) acc) 69 | #+(and sbcl (not old-sbcl)) 70 | ((typep x 'sb-impl::comma) (rec (sb-impl::comma-expr x) acc)) 71 | ((atom x) (cons x acc)) 72 | (t (rec 73 | (car x) 74 | (rec (cdr x) acc)))))) 75 | (rec x nil))) 76 | 77 | (defun g!-symbol-p (s) 78 | (and (symbolp s) 79 | (> (length (symbol-name s)) 2) 80 | (string= (symbol-name s) 81 | "G!" 82 | :start1 0 83 | :end1 2))) 84 | 85 | (defun o!-symbol-p (s) 86 | (and (symbolp s) 87 | (> (length (symbol-name s)) 2) 88 | (string= (symbol-name s) 89 | "O!" 90 | :start1 0 91 | :end1 2))) 92 | 93 | (defun o!-symbol-to-g!-symbol (s) 94 | (symb "G!" 95 | (subseq (symbol-name s) 2)))) 96 | 97 | (defmacro defmacro/g! (name args &rest body) 98 | (let ((syms (remove-duplicates 99 | (remove-if-not #'g!-symbol-p 100 | (lol-flatten body))))) 101 | (multiple-value-bind (body declarations docstring) 102 | (parse-body body :documentation t) 103 | `(defmacro ,name ,args 104 | ,@(when docstring 105 | (list docstring)) 106 | ,@declarations 107 | (let ,(mapcar 108 | (lambda (s) 109 | `(,s (gensym ,(subseq 110 | (symbol-name s) 111 | 2)))) 112 | syms) 113 | ,@body))))) 114 | 115 | (defmacro defmacro! (name args &rest body) 116 | (let* ((os (remove-if-not #'o!-symbol-p (lol-flatten args))) 117 | (gs (mapcar #'o!-symbol-to-g!-symbol os))) 118 | (multiple-value-bind (body declarations docstring) 119 | (parse-body body :documentation t) 120 | `(defmacro/g! ,name ,args 121 | ,@(when docstring 122 | (list docstring)) 123 | ,@declarations 124 | `(let ,(mapcar #'list (list ,@gs) (list ,@os)) 125 | ,(progn ,@body)))))) 126 | 127 | (defmacro defun! (name args &body body) 128 | (let ((syms (remove-duplicates 129 | (remove-if-not #'g!-symbol-p 130 | (lol-flatten body))))) 131 | (multiple-value-bind (body declarations docstring) 132 | (parse-body body :documentation t) 133 | `(defun ,name ,args 134 | ,@(when docstring 135 | (list docstring)) 136 | ,@declarations 137 | (let ,(mapcar (lambda (s) 138 | `(,s (gensym ,(subseq (symbol-name s) 139 | 2)))) 140 | syms) 141 | ,@body))))) 142 | 143 | -------------------------------------------------------------------------------- /test/cltl2/flet.lisp: -------------------------------------------------------------------------------- 1 | ;;;; flet.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test that environment information is extracted from FLET forms. 27 | 28 | (defpackage :cl-environments.test.cltl2.flet-forms 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :fiveam)) 32 | 33 | (in-package :cl-environments.test.cltl2.flet-forms) 34 | 35 | (def-suite flet-forms 36 | :description "Test extraction of environment information from FLET forms" 37 | :in cltl2-test) 38 | 39 | (in-suite flet-forms) 40 | 41 | (defun global-fn (a b c) 42 | (/ (* a b) c)) 43 | 44 | (declaim (ftype (function (integer integer integer) number) global-fn)) 45 | 46 | (defmacro test-macro (form) 47 | form) 48 | 49 | (test (function-types :compile-at :run-time) 50 | "Test extracting function information" 51 | 52 | (flet ((inc (a) 53 | (1+ a)) 54 | 55 | (add (a b) 56 | (+ a b))) 57 | 58 | (declare (ftype (function (integer) integer) inc) 59 | (ftype (function (number number) number) add) 60 | (ignorable #'inc #'add)) 61 | 62 | (declare (dynamic-extent #'inc) 63 | (inline add) 64 | (notinline global-fn)) 65 | 66 | (is (info= 67 | ;; CMUCL ignores DYNAMIC-EXTENT here 68 | ;; ECL ignores DYNAMIC-EXTENT entirely 69 | 70 | #-(or cmucl ecl) '(:function t ((ftype . (function (integer) integer)) 71 | (dynamic-extent . t))) 72 | 73 | #+(or cmucl ecl) '(:function t ((ftype . (function (integer) integer)))) 74 | 75 | (info function inc))) 76 | 77 | (is (info= 78 | '(:function t ((ftype . (function (number number) number)) 79 | (inline . inline))) 80 | 81 | (info function add))) 82 | 83 | (is (info= 84 | ;; CCL sometimes doesn't store global declarations 85 | #-ccl '(:function nil ((ftype . (function (integer integer integer) number)) 86 | (inline . notinline))) 87 | 88 | #+ccl '(:function nil ((inline . notinline))) 89 | 90 | (info function global-fn))) 91 | 92 | (is (info= 93 | '(:macro nil nil) 94 | (info function test-macro))) 95 | 96 | (is (info= 97 | '(:macro nil nil) 98 | (info function cl:defun))) 99 | 100 | (is (info= 101 | '(:special-form nil nil) 102 | (info function cl:if))) 103 | 104 | (is (info= 105 | '(nil nil nil) 106 | (info function not-a-function))))) 107 | 108 | (test (shadowing :compile-at :run-time) 109 | "Test lexical shadowing of functions" 110 | 111 | (flet ((f2 (a b) 112 | (+ a b))) 113 | (declare (ftype (function (number number) number) f2) 114 | (inline f2) 115 | (ignorable #'f2)) 116 | 117 | (flet ((f1 (x) 118 | (declare (type integer x) 119 | (ignore x)) 120 | 121 | (values 122 | (info variable x) 123 | (info function f2) 124 | (info function global-fn))) 125 | 126 | (f2 (a b) 127 | (declare (ignore a b)) 128 | 129 | (values 130 | (info variable a) 131 | (info variable b) 132 | (info function f1))) 133 | 134 | (global-fn (x) x)) 135 | 136 | (declare (notinline f2) 137 | (ignore #'global-fn) 138 | (ignorable #'f1 #'f2)) 139 | 140 | (multiple-value-bind (info-x info-f2 info-global-fn) 141 | (f1 1) 142 | 143 | (is-every info= 144 | #-ecl ('(:lexical t ((type . integer) (ignore . t))) info-x) 145 | 146 | ;; ECL does not recognize IGNORE declarations referring to 147 | ;; function argument variables. 148 | 149 | #+ecl ('(:lexical t ((type . integer))) info-x) 150 | 151 | ('(:function t ((ftype . (function (number number) number)) 152 | (inline . inline))) 153 | info-f2) 154 | 155 | #-ccl ('(:function nil ((ftype . (function (integer integer integer) number)))) info-global-fn) 156 | #+ccl ('(:function nil nil) info-global-fn))) 157 | 158 | (multiple-value-bind (info-a info-b info-f1) 159 | (f2 1 2) 160 | 161 | (is-every info= 162 | ('(:lexical t ((ignore . t))) info-a) 163 | ('(:lexical t ((ignore . t))) info-b) 164 | ('(nil nil nil) info-f1))) 165 | 166 | (is (info= 167 | '(:function t ((inline . notinline))) 168 | (info function f2))) 169 | 170 | (is (info= 171 | #-(or sbcl ccl cmucl ecl) '(:function t ((ignore . t))) 172 | #+(or sbcl ccl cmucl ecl) '(:function t nil) 173 | 174 | (info function global-fn)))))) 175 | -------------------------------------------------------------------------------- /test/cltl2/define-declaration.lisp: -------------------------------------------------------------------------------- 1 | ;;;; define-declaration 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test defining custom declarations 27 | 28 | (defpackage :cl-environments.test.cltl2.define-declaration 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :alexandria 32 | :fiveam)) 33 | 34 | (in-package :cl-environments.test.cltl2.define-declaration) 35 | 36 | (def-suite define-declaration 37 | :description "Test defining custom declarations using DEFINE-DECLARATION" 38 | :in cltl2-test) 39 | 40 | (in-suite define-declaration) 41 | 42 | 43 | ;;; Variable Declarations 44 | 45 | (define-declaration foo-type (args) 46 | (destructuring-bind (foo-type &rest vars) args 47 | (values 48 | :variable 49 | (mapcar 50 | (lambda (var) 51 | `(,var foo-type ,foo-type)) 52 | vars)))) 53 | 54 | 55 | ;;; Function Declarations 56 | 57 | (define-declaration bar-type (args) 58 | (destructuring-bind (bar-type &rest fns) args 59 | (values 60 | :function 61 | (mapcar 62 | (lambda (fn) 63 | `(,fn bar-type ,bar-type)) 64 | fns)))) 65 | 66 | 67 | ;;; Other Declarations 68 | 69 | (define-declaration foobar-types (args) 70 | (destructuring-bind (&rest types) args 71 | (values 72 | :declare 73 | (cons 'foobar-types types)))) 74 | 75 | 76 | ;;; Custom declarations in global functions 77 | 78 | (defun test-function (a b) 79 | (declare (foo-type foo1 a b)) 80 | 81 | (+ a b) 82 | (values 83 | (info variable a) 84 | (info variable b))) 85 | 86 | (defmacro test-macro (form) 87 | (declare (foo-type macfoo form)) 88 | 89 | (list form) 90 | `',(info variable form)) 91 | 92 | (defgeneric test-generic (a) 93 | (:method ((a number)) 94 | (declare (foo-type genericfoo a)) 95 | (1+ a) 96 | (info variable a))) 97 | 98 | (defmethod test-generic ((str string)) 99 | (declare (foo-type stringfoo str)) 100 | (string-capitalize str) 101 | (info variable str)) 102 | 103 | 104 | ;;; Tests 105 | 106 | (test (variable-declarations :compile-at :run-time) 107 | "Custom declarations applying to variables" 108 | 109 | (is 110 | (info= 111 | '(:lexical t ((foo-type . my-foo))) 112 | 113 | (let ((x 1)) 114 | (declare (foo-type my-foo x)) 115 | (1+ x) 116 | (info variable x))))) 117 | 118 | (test (function-declarations :compile-at :run-time) 119 | "Custom declarations applying to functions" 120 | 121 | (is 122 | (info= 123 | '(:function t ((bar-type . my-bar))) 124 | 125 | (flet ((f (x) (1+ x))) 126 | (declare (bar-type my-bar f)) 127 | (f 1) 128 | (info function f))))) 129 | 130 | (test (other-declarations :compile-at :run-time) 131 | "Custom declarations neither applying to variables nor functions" 132 | 133 | (is 134 | (equal 135 | '(foo1 foo2 bar3) 136 | 137 | (locally (declare (foobar-types foo1 foo2 bar3)) 138 | (first (info declaration foobar-types)))))) 139 | 140 | (test in-global-definitions 141 | "Test usage of custom declarations in global definitions" 142 | 143 | (multiple-value-bind (info1 info2) 144 | (test-function 1 2) 145 | 146 | (is (info= '(:lexical t ((foo-type . foo1))) info1)) 147 | (is (info= '(:lexical t ((foo-type . foo1))) info2))) 148 | 149 | (is 150 | (info= '(:lexical t ((foo-type . macfoo))) (test-macro x))) 151 | 152 | (is 153 | (info= '(:lexical t ((foo-type . genericfoo))) 154 | (test-generic 1))) 155 | 156 | (is 157 | (info= '(:lexical t ((foo-type . stringfoo))) 158 | (test-generic "hello")))) 159 | 160 | (test (augment-environment-declarations :compile-at :run-time) 161 | "Test custom declarations added using AUGMENT-ENVIRONMENT" 162 | 163 | (let ((env (augment-environment 164 | nil 165 | :variable '(x) 166 | :function '(fn1) 167 | :declare '((foo-type some-foo x) 168 | (bar-type some-bar fn1) 169 | (foobar-types type1 type2))))) 170 | 171 | (is 172 | (info= 173 | '(:lexical t ((foo-type . some-foo))) 174 | (multiple-value-list (variable-information 'x env)))) 175 | 176 | (is 177 | (info= 178 | '(:function t ((bar-type . some-bar))) 179 | (multiple-value-list (function-information 'fn1 env)))) 180 | 181 | (is 182 | (equal 183 | '(type1 type2) 184 | (declaration-information 'foobar-types env))))) 185 | -------------------------------------------------------------------------------- /src/other/allegro.lisp: -------------------------------------------------------------------------------- 1 | ;;;; allegro.lisp 2 | ;;;; 3 | ;;;; Copyright 2018-2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (defpackage :cl-environments.cltl2 27 | (:use :common-lisp 28 | :optima) 29 | 30 | (:import-from :cl-environments.util 31 | :reexport-all-symbols) 32 | 33 | (:import-from :sys :augment-environment) 34 | 35 | (:shadow :variable-information 36 | :function-information 37 | :define-declaration) 38 | 39 | (:export :variable-information 40 | :function-information 41 | :declaration-information 42 | :define-declaration 43 | 44 | :augment-environment 45 | :enclose 46 | :parse-macro 47 | :enclose-macro 48 | 49 | :in-environment 50 | :augmented-macroexpand-1 51 | :augmented-macroexpand 52 | :augmented-macro-function 53 | :augmented-get-setf-expansion 54 | :augmented-compiler-macro-function 55 | :augmented-constantp 56 | 57 | :enable-hook 58 | :disable-hook 59 | 60 | :walk-environment)) 61 | 62 | (defpackage :cl-environments-cl 63 | (:nicknames :cl-environments) 64 | (:use :common-lisp 65 | :cl-environments.util 66 | :cl-environments.cltl2) 67 | 68 | (:export :variable-information 69 | :function-information 70 | :declaration-information 71 | :define-declaration 72 | 73 | :augment-environment 74 | :enclose 75 | :enclose-macro 76 | 77 | :in-environment 78 | :augmented-macroexpand-1 79 | :augmented-macroexpand 80 | :augmented-macro-function 81 | :augmented-get-setf-expansion 82 | :augmented-compiler-macro-function 83 | :augmented-constantp 84 | 85 | :enable-hook 86 | :disable-hook 87 | 88 | :walk-environment)) 89 | 90 | (in-package :cl-environments.cltl2) 91 | 92 | (defun variable-information (variable &optional env) 93 | (multiple-value-bind (type binding declarations local) 94 | (sys:variable-information variable env t) 95 | (declare (ignore binding)) 96 | (values type local declarations))) 97 | 98 | 99 | (defun function-information (function &optional env) 100 | (let ((env (sys:augment-environment env))) 101 | (setf (sys::augmentable-environment-kind env) :evaluation) 102 | 103 | (multiple-value-bind (type binding declarations local) 104 | (sys:function-information function env t nil) 105 | (declare (ignore binding)) 106 | (values 107 | (case type 108 | (:special-operator :special-form) 109 | (t type)) 110 | local 111 | declarations)))) 112 | 113 | 114 | (defun convert-declaration (type info) 115 | (flet ((cons->list (cons) 116 | (list (car cons) (cdr cons)))) 117 | (values type 118 | (case type 119 | (:declare 120 | (mapcar #'cons->list info)) 121 | 122 | (otherwise 123 | info))))) 124 | 125 | (defmacro define-declaration (decl-name (arg-var &optional (env-var (gensym "ENV"))) &body body) 126 | `(sys:define-declaration ,decl-name (&rest ,(gensym "args")) 127 | nil :both 128 | (lambda (,arg-var ,env-var) 129 | (declare (ignorable env-var)) 130 | (multiple-value-call #'convert-declaration (progn ,@body))))) 131 | 132 | (defmacro in-environment ((env-var &optional (environment env-var)) (&rest bindings) &body forms) 133 | (flet ((make-binding (binding) 134 | (match binding 135 | ((type symbol) 136 | (list binding binding)) 137 | 138 | (_ binding)))) 139 | 140 | `(let ((,env-var ,environment) ,@(mapcar #'make-binding bindings)) 141 | ,@forms))) 142 | 143 | (defun augmented-macroexpand-1 (form &optional env) 144 | (macroexpand-1 form env)) 145 | 146 | (defun augmented-macroexpand (form &optional env) 147 | (macroexpand form env)) 148 | 149 | (defun augmented-macro-function (name &optional env) 150 | (macro-function name env)) 151 | 152 | (defun augmented-get-setf-expansion (form &optional env) 153 | (get-setf-expansion form env)) 154 | 155 | (defun augmented-compiler-macro-function (name &optional environment) 156 | (compiler-macro-function name environment)) 157 | 158 | (defun augmented-constantp (form &optional environment) 159 | (constantp form environment)) 160 | 161 | (defun parse-macro (name lambda-list body &optional env) 162 | (declare (ignorable name lambda-list body env)) 163 | (excl::defmacro-expander `(,name ,lambda-list ,@body) env)) 164 | 165 | (defun enclose (lambda-expression &optional env) 166 | (excl:compile-lambda-expr-in-env lambda-expression env)) 167 | 168 | (defun enclose-macro (name lambda-list body &optional env) 169 | (enclose (parse-macro name lambda-list body env) env)) 170 | 171 | (defun enable-hook (&optional (previous-hook *macroexpand-hook*)) 172 | "Does nothing, provided for compatibility with implementations where 173 | the code walker is required." 174 | 175 | (declare (ignore previous-hook))) 176 | 177 | (defun disable-hook (&optional (previous-hook *previous-hook*)) 178 | "Does nothing, provided for compatibility with implementations where 179 | the code walker is required." 180 | 181 | (declare (ignore previous-hook))) 182 | 183 | (defmacro walk-environment (&body forms) 184 | `(progn ,@forms)) 185 | 186 | (defmacro disable-walker (&body body) 187 | `(progn ,@body)) 188 | 189 | ;;; Reexport symbols in CL package 190 | 191 | (in-package :cl-environments-cl) 192 | 193 | (eval-when (:compile-toplevel :load-toplevel :execute) 194 | (reexport-all-symbols :cl)) 195 | -------------------------------------------------------------------------------- /src/walker/special-forms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; special-forms.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Code-walkers for the standard Common Lisp forms, which are not 27 | ;;;; macros, excluding the lexical binding forms (LET, FLET, etc) 28 | ;;;; which are implemented in let-forms.lisp. 29 | 30 | (in-package :cl-environments.cltl2) 31 | 32 | 33 | ;;; Standard Common Lisp Special Forms 34 | 35 | ;;; Generic walker for special-forms which evaluate all arguments. 36 | 37 | (eval-when (:compile-toplevel :load-toplevel :execute) 38 | (defun walk-all-args (op args) 39 | "Walks the arguments as ordinary lisp forms." 40 | 41 | (cons op 42 | (check-list args 43 | (enclose-forms args)))) 44 | 45 | (set-walker-functions 46 | '(cl:catch 47 | cl:throw 48 | cl:if 49 | cl:multiple-value-call 50 | cl:multiple-value-prog1 51 | cl:progn 52 | cl:progv 53 | cl:unwind-protect) 54 | #'walk-all-args)) 55 | 56 | 57 | ;;; BLOCK 58 | 59 | (defwalker cl:block (args) 60 | "Walks the body of the BLOCK form (excluding the block name symbol)" 61 | 62 | (match-form (name &rest forms) args 63 | `(,name ,@(enclose-forms forms)))) 64 | 65 | (defwalker cl:return-from (args) 66 | "Walks the result-form of the RETURN-FROM form." 67 | 68 | (match-form (name form) args 69 | `(,name ,(enclose-form form)))) 70 | 71 | 72 | ;;; EVAL-WHEN 73 | 74 | (defwalker cl:eval-when (args) 75 | "Walks the body of the EVAL-WHEN form." 76 | 77 | (match-form (situation &rest forms) args 78 | (cons situation (enclose-forms forms)))) 79 | 80 | 81 | ;;; FUNCTION 82 | 83 | (defwalker cl:function (args) 84 | "If the body of the FUNCTION form is a lambda expression, it is 85 | walked as a function definition. Otherwise the form arguments are 86 | returned as is." 87 | 88 | (match args 89 | ((list (list* 'cl:lambda expr)) 90 | (list (cons 'cl:lambda (walk-fn-def expr (get-environment *env*) t)))) 91 | 92 | #+clisp 93 | ((list name (and (list* 'cl:lambda _) expr)) 94 | (list name (second (walk-list-form 'function (list expr))))) 95 | 96 | #+ecl 97 | ((list (list* 'ext:lambda-block name expr)) 98 | (list (list* 'ext:lambda-block name (walk-fn-def expr (get-environment *env*))))) 99 | 100 | #+abcl 101 | ((list (list* 'system:named-lambda name expr)) 102 | (list (list* 'system:named-lambda name (walk-fn-def expr (get-environment *env*))))) 103 | 104 | (_ args))) 105 | 106 | 107 | ;;; LOAD-TIME-VALUE 108 | 109 | (defwalker cl:load-time-value (args) 110 | "Walks the value form in the global NIL environment." 111 | 112 | (match-form (form &optional read-only-p) args 113 | `(,(enclose-in-env *global-environment* (list form)) ,read-only-p))) 114 | 115 | 116 | ;;; LOCALLY 117 | 118 | (defwalker cl:locally (args) 119 | "Encloses the body of the LOCALLY form in an environment, augmented 120 | with the declaration information." 121 | 122 | (let ((ext-env (copy-environment (get-environment *env*)))) 123 | (walk-body args ext-env))) 124 | 125 | 126 | ;;; QUOTE 127 | 128 | (defwalker cl:quote (args) 129 | "Returns the arguments unchanged." 130 | 131 | args) 132 | 133 | 134 | ;;; SETQ 135 | 136 | (defwalker cl:setq (args) 137 | "Walks the value forms." 138 | 139 | (check-list args 140 | (loop for (var form) on args by #'next-2 141 | nconc (list var (enclose-form form))))) 142 | 143 | 144 | ;;; TAGBODY 145 | 146 | (defwalker cl:tagbody (args) 147 | "Walks the body forms (excluding the tags)." 148 | 149 | (flet ((walk-form (form) 150 | (if (atom form) 151 | form 152 | (enclose-form form)))) 153 | 154 | (check-list args 155 | (mapcar #'walk-form args)))) 156 | 157 | 158 | (defwalker cl:go (args) 159 | "Returns the argument as is." 160 | 161 | args) 162 | 163 | ;;; THE 164 | 165 | (defwalker cl:the (args) 166 | "Walks the value form." 167 | 168 | (match-form (type form) args 169 | `(,type ,(enclose-form form)))) 170 | 171 | 172 | ;;; Clisp specific special forms 173 | 174 | #+clisp 175 | (defwalker system::function-macro-let (args) 176 | "Encloses the body of the form in an environment augmented with the 177 | lexical functions introduced by the form. The bodies of the 178 | functions are not walked as this form is only used internally by 179 | Clisp's implementation of CLOS." 180 | 181 | (match-form ((&rest fns) . body) args 182 | (let ((ext-env (copy-environment (get-environment *env*)))) 183 | (loop for (fn) in fns do (add-function fn ext-env)) 184 | `(,fns ,@(walk-body body ext-env))))) 185 | 186 | 187 | ;;; CCL specific special forms 188 | 189 | #+ccl 190 | (defwalker ccl::nfunction (args) 191 | (match-form (name ('cl:lambda . _)) args 192 | (list name (second (walk-list-form 'function (cdr args)))))) 193 | 194 | #+ccl 195 | (defwalker ccl::compiler-let (args) 196 | (match-form (bindings . body) args 197 | (cons bindings (enclose-forms body)))) 198 | 199 | 200 | ;;; ECL special special forms 201 | 202 | #+ecl 203 | (defwalker multiple-value-bind (args) 204 | "ECL has a buggy macroexpansion for MULTIPLE-VALUE-BIND which 205 | results in an error at runtime if more/less values are returned 206 | than expected." 207 | 208 | (match-form ((&rest vars) form . body) args 209 | (let ((env (copy-environment (get-environment *env*)))) 210 | (mapc (rcurry #'add-variable env) vars) 211 | `(,vars ,(enclose-form form) ,@(walk-body body env nil))))) 212 | -------------------------------------------------------------------------------- /src/walker/def-forms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; def-forms.lisp 2 | ;;;; 3 | ;;;; Copyright 2017-2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Code-walkers for forms which modify the global environment such 27 | ;;;; as global function, variable, macro definition forms and 28 | ;;;; global declaration (DECLAIM) forms. 29 | 30 | (in-package :cl-environments.cltl2) 31 | 32 | 33 | ;;; Functions 34 | 35 | (defwalker cl:defun (args) 36 | "Walks DEFUN forms, adds the function to the global environment." 37 | 38 | #+cl-environments-full 39 | (walk-global-function args :function) 40 | 41 | (match-form (name . def) args 42 | (let ((env (copy-environment (get-environment *env*)))) 43 | `(,name ,@(walk-fn-def def env t))))) 44 | 45 | 46 | ;;;; Generic Functions 47 | 48 | ;;; DEFGENERIC 49 | 50 | (defwalker cl:defgeneric (args) 51 | "Walks DEFGENERIC forms, adds the function to the global 52 | environment." 53 | 54 | #+cl-environments-full 55 | (walk-global-function args :function) 56 | 57 | (match-form (name lambda-list &rest options) args 58 | `(,name 59 | ,lambda-list 60 | ,@(loop 61 | for option in options 62 | collect 63 | (match option 64 | ((list* :method def) 65 | `(:method ,@(walk-method def))) 66 | 67 | (_ option)))))) 68 | 69 | ;;; DEFMETHOD 70 | 71 | (defwalker cl:defmethod (args) 72 | "Walks DEFMETHOD forms, adds the function to the global 73 | environment." 74 | 75 | #+cl-environments-full 76 | (walk-global-function args :function) 77 | 78 | (match-form (name . def) args 79 | `(,name ,@(walk-method def)))) 80 | 81 | (defun walk-method (def) 82 | "Walks the method definition DEF where DEF is the part of the 83 | definition following the method's name. Encloses the body in an 84 | environment augmented with the variable bindings in the method's 85 | generic function lambda-list." 86 | 87 | (flet ((consume-qualifiers (def) 88 | (loop 89 | for rest on def 90 | for (thing) = rest 91 | while (symbolp thing) 92 | collect thing into qualifiers 93 | finally 94 | (return (values qualifiers rest))))) 95 | 96 | (multiple-value-bind (qualifiers def) 97 | (consume-qualifiers def) 98 | 99 | (match-form ((&rest lambda-list) . body) def 100 | (multiple-value-bind (lambda-list env) 101 | (walk-generic-lambda-list lambda-list (get-environment *env*)) 102 | `(,@qualifiers ,lambda-list 103 | ,@ (walk-body body env t))))))) 104 | 105 | 106 | ;;; Variable Definitions 107 | 108 | (defwalker cl:defparameter (args) 109 | "Walks DEFPARAMETER forms. Adds the variable binding (of 110 | type :SPECIAL) to the global environment and walks the init-form." 111 | 112 | (match-form (name init-form . doc) args 113 | 114 | #+cl-environments-full 115 | (add-global-variable name) 116 | 117 | (list* name (enclose-form init-form) doc))) 118 | 119 | (defwalker cl:defvar (args) 120 | "Walks DEFVAR forms. Adds the variable binding (of type :SPECIAL) to 121 | the global environment and walks the init-form." 122 | 123 | (match-form (name . args) args 124 | 125 | #+cl-environments-full 126 | (add-global-variable name) 127 | 128 | (cons name 129 | (destructuring-bind (&optional (init-form nil init-p) &rest doc) args 130 | (when init-p 131 | (cons (enclose-form init-form) doc)))))) 132 | 133 | ;;;; Constant Definitions 134 | 135 | (defwalker cl:defconstant (args) 136 | "Walks DEFCONSTANT forms. Adds the variable binding (of 137 | type :CONSTANT) to the global environment and walks the init-form." 138 | 139 | (match-form (name init-form . doc) args 140 | 141 | #+cl-environments-full 142 | (add-global-variable name :constant) 143 | 144 | (list* name (enclose-form init-form) doc))) 145 | 146 | 147 | ;;; Macros 148 | 149 | ;;; DEFMACRO 150 | 151 | (defwalker cl:defmacro (args) 152 | "Walks DEFMACRO forms, adds the the macro to the global 153 | environment." 154 | 155 | #+cl-environments-full 156 | (walk-global-function args :macro) 157 | 158 | (match-form (name . def) args 159 | (let ((env (copy-environment (get-environment *env*)))) 160 | `(,name ,@(walk-macro-def def env))))) 161 | 162 | 163 | ;;; DEFINE-SYMBOL-MACRO 164 | 165 | #+cl-environments-full 166 | (defwalker cl:define-symbol-macro (args) 167 | "Walks DEFINE-SYMBOL-MACRO forms. Adds the symbol macro to the 168 | global environment." 169 | 170 | (match-form (name form) args 171 | (add-global-variable name :symbol-macro) 172 | (list name form))) 173 | 174 | 175 | ;;; Global Declarations (DECLAIM) 176 | 177 | (defwalker cl:declaim (args) 178 | "Walks DECLAIM forms. Walks the declarations, as global 179 | declarations, and adds the declaration information to the global 180 | environment." 181 | 182 | (check-list args 183 | (dolist (arg args args) 184 | (match-form (decl &rest args) arg 185 | (let ((*env* nil)) 186 | (walk-declaration decl args *global-environment* t)))))) 187 | 188 | 189 | ;;; Utility Functions 190 | 191 | #+cl-environments-full 192 | (progn 193 | (defun walk-global-function (args type) 194 | "Walks a global function definition, where ARGS is the arguments 195 | list of the DEFUN/DEFMACRO/etc form. Adds a function binding of 196 | type TYPE to the global environment." 197 | 198 | (when (consp args) 199 | (add-global-function (first args) type))) 200 | 201 | (defun add-global-function (sym &optional (type :function)) 202 | "Adds a function binding for the symbol SYM, of type TYPE to the 203 | global environment." 204 | 205 | (ensure-function-type sym *global-environment* :binding-type type :local nil :global t)) 206 | 207 | (defun add-global-variable (sym &optional (type :special)) 208 | "Adds a variable binding for the symbol SYM, of type TYPE to the 209 | global environment." 210 | 211 | (ensure-variable-type sym *global-environment* :binding-type type :local nil :global t))) 212 | -------------------------------------------------------------------------------- /src/walker/walker.lisp: -------------------------------------------------------------------------------- 1 | ;;;; walker.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :cl-environments.cltl2) 27 | 28 | (defvar *env* nil 29 | "The implementation-specific environment in which the form, 30 | currently being walked, occurs.") 31 | 32 | (defmacro walk-environment (&body body) 33 | "Walks the BODY forms to extract environment information." 34 | 35 | `(progn 36 | ,@(enclose-forms body))) 37 | 38 | (defmacro disable-walker (&body body) 39 | "Disable the code-walker for the forms in BODY. 40 | 41 | Environment information will not be extracted." 42 | 43 | `(symbol-macrolet ((disable-walker t)) 44 | ,@body)) 45 | 46 | ;;; Code-Walker Macro 47 | 48 | (defmacro %walk-form (form &environment *env*) 49 | "Code-walker macro, simply invokes the WALK-FORM function. This 50 | macro is used when FORM needs to be walked in an augmented 51 | environment." 52 | 53 | (multiple-value-bind (walk expandedp) 54 | (macroexpand 'disable-walker *env*) 55 | 56 | (if (and expandedp walk) 57 | form 58 | (walk-form form)))) 59 | 60 | (defun enclose-form (form) 61 | "Encloses FORM in the code-walker macro." 62 | 63 | (match form 64 | ((not (list* '%walk-form _)) 65 | `(%walk-form ,form)) 66 | 67 | (_ form))) 68 | 69 | (defun enclose-forms (forms) 70 | "Encloses each form, in FORMS, in the code-walker macro." 71 | 72 | (mapcar #'enclose-form forms)) 73 | 74 | 75 | ;;; Code-Walker function 76 | 77 | (defun walk-form (form) 78 | "Walks the form FORM and its sub-forms, enclosing them in an 79 | augmented environment if necessary." 80 | 81 | (match form 82 | ((cons op args) 83 | (walk-list-form op args)) 84 | 85 | (_ (walk-atom-form form)))) 86 | 87 | (defun walk-forms (forms) 88 | "Walks each form in FORMS." 89 | 90 | (mapcar #'walk-form forms)) 91 | 92 | 93 | ;;; Walking atom forms 94 | 95 | (defun walk-atom-form (form) 96 | "Walks atom forms. If the form is a symbol-macro, it is expanded and 97 | the result is walked otherwise FORM is returned as is." 98 | 99 | (multiple-value-bind (form expanded-p) (macroexpand-1 form *env*) 100 | (if expanded-p 101 | (enclose-form form) 102 | form))) 103 | 104 | 105 | ;;; Walking function call forms 106 | 107 | (defvar *walker-functions* (make-hash-table :test #'eq) 108 | "Hash-table mapping special operator symbols to their walker 109 | functions. The walker function is responsible for walking the 110 | arguments, according to the special operator's evaluation rules and 111 | returning a new form with an augmented environment if 112 | necessary. Walker functions can be added either using 113 | SET-WALKER-FUNCTION, SET-WALKER-FUNCTIONS or the DEFWALKER macro.") 114 | 115 | (defun walk-list-form (operator args) 116 | "Walks a function call expression with function/macro/special 117 | operator OPERATOR and arguments ARGS." 118 | 119 | (aif (gethash operator *walker-functions*) 120 | (funcall it operator args) 121 | (walk-function-call operator args))) 122 | 123 | (defun walk-function-call (function args) 124 | "Walks a function call expression which is not a recognized special 125 | form. If FUNCTION names a macro or a special operator, the form is 126 | simply returned unchanged (the arguments are not walked). If 127 | FUNCTION is neither a macro nor special operator it is assumed to 128 | be a function, all arguments are walked." 129 | 130 | (multiple-value-bind (form expanded-p) (macroexpand-1 (cons function args) *env*) 131 | (if expanded-p 132 | (enclose-form form) 133 | (walk-function function args)))) 134 | 135 | 136 | (defun walk-function (function args) 137 | "Walks the function call expression where FUNCTION does not name a 138 | macro function. If FUNCTION is a LAMBDA expression it is walked 139 | otherwise FUNCTION is left as is. The form arguments ARGS are 140 | walked, if FUNCTION is not a special operator." 141 | 142 | (flet ((walk-args (args) 143 | (check-list args 144 | (walk-forms args)))) 145 | 146 | (match function 147 | ((cons 'cl:lambda _) 148 | (cons (second (walk-list-form 'function (list function))) (walk-args args))) 149 | 150 | ((type symbol) 151 | (if (special-operator-p function) 152 | (cons function args) ; Cannot be walked 153 | (cons function (walk-args args)))) 154 | 155 | (_ (cons function args))))) 156 | 157 | 158 | ;;; Utilities for adding walker functions 159 | 160 | (defun set-walker-function (operator function) 161 | "Sets the walker function for OPERATOR." 162 | 163 | (setf (gethash operator *walker-functions*) function)) 164 | 165 | (defun set-walker-functions (operators function) 166 | "Sets the walker function for each operator in the list OPERATORS to 167 | FUNCTION." 168 | 169 | (mapc (rcurry #'set-walker-function function) operators)) 170 | 171 | (defmacro! defwalker (op (arg-var) &body body) 172 | "Defines a walker function for the operator OP. ARG-VAR is bound to 173 | the arguments of the form. The forms in BODY, enclosed in an 174 | implicit PROGN, should return the new operator arguments. The 175 | result returned by the walker method is the form with the operator 176 | OP and the arguments returned by the last form in BODY, 177 | effectively (CONS ,OP (PROGN ,@BODY)). BODY is additionally 178 | surrounded in a RESTART-CASE, which establishes the restart 179 | SKIP-WALK (returns the arguments unchanged) and in a HANDLER-BIND 180 | which invokes the restart in the case of a WALK-PROGRAM-ERROR." 181 | 182 | (multiple-value-bind (body decl doc) 183 | (parse-body body :documentation t) 184 | (declare (ignore doc)) 185 | 186 | `(eval-when (:compile-toplevel :load-toplevel :execute) 187 | (set-walker-function ',op 188 | (compile nil 189 | (lambda (,g!op-var ,arg-var) 190 | ,@decl 191 | (declare (ignore ,g!op-var)) 192 | (cons ',op (skip-walk-errors 193 | (restart-case (progn ,@body) 194 | (skip-walk () ,arg-var)))))))))) 195 | -------------------------------------------------------------------------------- /test/cltl2/special-forms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; special-forms.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Test extracting environment information in special forms 27 | 28 | (defpackage :cl-environments.test.cltl2.special-forms 29 | (:use :cl-environments-cl 30 | :cl-environments.test.cltl2 31 | :alexandria 32 | :fiveam)) 33 | 34 | (in-package :cl-environments.test.cltl2.special-forms) 35 | 36 | (def-suite special-forms 37 | :description "Test extraction of environment information in special forms" 38 | :in cltl2-test) 39 | 40 | (in-suite special-forms) 41 | 42 | (test (block :compile-at :run-time) 43 | "Accessing environment information in BLOCK forms" 44 | 45 | (is 46 | (info= 47 | '(:lexical t ((type . integer))) 48 | 49 | (walk-environment 50 | (block x 51 | (cl:let ((x 1)) 52 | (declare (type integer x)) 53 | 54 | (1+ x) 55 | (return-from x (info variable x)))))))) 56 | 57 | (test (catch :compile-at :run-time) 58 | "Accessing environment information in CATCH forms" 59 | 60 | (is 61 | (info= 62 | '(:lexical t ((type . integer))) 63 | 64 | (walk-environment 65 | (catch 'x 66 | (cl:let ((x 1)) 67 | (declare (type integer x)) 68 | 69 | (1+ x) 70 | (throw 'x (info variable x)))))))) 71 | 72 | (test (eval-when :compile-at :run-time) 73 | "Accessing environment information in CATCH forms" 74 | 75 | (is 76 | (info= 77 | '(:lexical t ((ignore . t))) 78 | 79 | (walk-environment 80 | (eval-when (:compile-toplevel :load-toplevel :execute) 81 | (cl:let ((x 1)) 82 | (declare (ignore x)) 83 | (info variable x))))))) 84 | 85 | (test (if :compile-at :run-time) 86 | "Accessing environment information in IF forms" 87 | 88 | #+sbcl (declare (optimize (sb-ext:inhibit-warnings 3))) 89 | 90 | (is 91 | (info= 92 | '(:lexical t ((ignore . t))) 93 | 94 | (walk-environment 95 | (if (evenp (* 2 3)) 96 | (cl:let ((var 1)) 97 | (declare (ignore var)) 98 | (info variable var)))))) 99 | 100 | (is 101 | (info= 102 | '(:lexical t ((ignore . t))) 103 | 104 | (walk-environment 105 | (if (oddp (* 2 3)) 106 | 'true 107 | 108 | (cl:let ((var 1)) 109 | (declare (ignore var)) 110 | (info variable var))))))) 111 | 112 | (test (locally :compile-at :run-time) 113 | "Accessing environment information in LOCALLY forms" 114 | 115 | (is (subsetp 116 | '((speed 2) (safety 3) (space 0)) 117 | (locally (declare (optimize (speed 2) safety (space 0))) 118 | (first (info declaration optimize))) 119 | 120 | :test #'equal))) 121 | 122 | (test (multiple-value-call :compile-at :run-time) 123 | "Accessing environment information in MULTIPLE-VALUE-CALL forms" 124 | 125 | (is 126 | (info= 127 | '(:lexical t ((ignore . t))) 128 | 129 | (walk-environment 130 | (multiple-value-call #'identity 131 | (cl:let ((x 1)) 132 | (declare (ignore x)) 133 | 134 | (info variable x))))))) 135 | 136 | (test (multiple-value-prog1 :compile-at :run-time) 137 | "Accessing environment information in MULTIPLE-VALUE-PROG1 forms" 138 | 139 | (is 140 | (info= 141 | '(:lexical t ((ignore . t))) 142 | 143 | (walk-environment 144 | (multiple-value-prog1 145 | (cl:let ((z "hello")) 146 | (declare (ignore z)) 147 | 148 | (info variable z))))))) 149 | 150 | (test (progn :compile-at :run-time) 151 | "Accessing environment information in PROGN forms" 152 | 153 | (let (info-a info-b) 154 | (setf 155 | info-b 156 | (progn 157 | (setf info-a 158 | (cl:let ((a 1)) 159 | (declare (type integer a) 160 | (ignorable a)) 161 | (info variable a))) 162 | 163 | (cl:let ((z "hello")) 164 | (declare (type string z) 165 | (ignorable z)) 166 | 167 | (info variable z)))) 168 | 169 | (is (info= '(:lexical t ((type . integer))) info-a)) 170 | (is (info= '(:lexical t ((type . string))) info-b)))) 171 | 172 | (test (progv :compile-at :run-time) 173 | "Accessing environment information in PROGV forms" 174 | 175 | (is 176 | (info= 177 | '(:lexical t ((ignore . t))) 178 | 179 | (walk-environment 180 | (progv nil nil 181 | (cl:let ((z "hello")) 182 | (declare (ignore z)) 183 | 184 | (info variable z))))))) 185 | 186 | (test (setq :compile-at :run-time) 187 | "Accessing environment information in SETQ forms" 188 | 189 | (let (info1 info2) 190 | (setq 191 | info1 192 | (cl:let ((var #(1 2 3))) 193 | (declare (ignore var)) 194 | (info variable var)) 195 | 196 | info2 197 | (cl:let ((var2 123)) 198 | (declare (type integer var2) 199 | (ignorable var2)) 200 | (info variable var2))) 201 | 202 | (is-every info= 203 | ('(:lexical t ((ignore . t))) info1) 204 | ('(:lexical t ((type . integer))) info2)))) 205 | 206 | (test (tagbody :compile-at :run-time) 207 | "Accessing environment information in TAGBODY forms" 208 | 209 | #+sbcl (declare (optimize (sb-ext:inhibit-warnings 3))) 210 | 211 | (is 212 | (info= 213 | '(:lexical t ((type . string))) 214 | 215 | (walk-environment 216 | (block nil 217 | (tagbody 218 | tag1 219 | (go tag3) 220 | 221 | tag2 222 | (pprint "Hello World") 223 | (go tag1) 224 | 225 | tag3 226 | (return 227 | (cl:let ((z "hello")) 228 | (declare (type string z) 229 | (ignorable z)) 230 | (info variable z))))))))) 231 | 232 | (test (the :compile-at :run-time) 233 | "Accessing environment information in THE forms" 234 | 235 | (is 236 | (info= 237 | '(:lexical t ((ignore . t))) 238 | 239 | (walk-environment 240 | (the list 241 | (cl:let ((z "hello")) 242 | (declare (ignore z)) 243 | 244 | (info variable z))))))) 245 | 246 | (test (unwind-protect :compile-at :run-time) 247 | "Accessing environment information in UNWIND-PROTECT forms" 248 | 249 | (is 250 | (info= 251 | '(:lexical t ((ignore . t))) 252 | 253 | (walk-environment 254 | (unwind-protect 255 | (cl:let ((a-var "hello")) 256 | (declare (ignore a-var)) 257 | 258 | (info variable a-var)) 259 | 260 | (* 2 3)))))) 261 | -------------------------------------------------------------------------------- /src/walker/cltl2-interface.ccl-cmucl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; cltl2-interface.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Implements the VARIABLE-INFORMATION, FUNCTION-INFORMATION and 27 | ;;;; DECLARATION-INFORMATION FUNCTIONS as specified in Common Lisp the 28 | ;;;; Language 2 (CLTL2) for CCL and CMUCL 29 | 30 | (in-package :cl-environments.cltl2) 31 | 32 | (defmacro cltl2-fn (fn &rest args) 33 | `(,(intern (symbol-name fn) 34 | #+ccl :ccl 35 | #+cmucl :extensions) ,@args)) 36 | 37 | (defun variable-information (variable &optional env) 38 | "Returns information about the variable binding for the symbol 39 | VARIABLE, in the environment ENV. Returns three values: the first 40 | value is the binding type nil, :SPECIAL, :LEXICAL, :SYMBOL-MACRO 41 | or :CONSTANT, the second value is true if there is a local binding 42 | and the third value is an association list containing declaration 43 | information." 44 | 45 | (let ((info (variable-binding variable (get-environment env)))) 46 | (multiple-value-bind (type local decl) 47 | (cltl2-fn variable-information variable env) 48 | (values type local (append decl info))))) 49 | 50 | (defun function-information (function &optional env) 51 | "Returns information about the function binding for the symbol 52 | FUNCTION in the environment ENV. Returns three values: the first 53 | value is the binding type nil, :FUNCTION, :MACRO or :SPECIAL-FORM, 54 | the second value is true if there is a local binding and the third 55 | value is an association list containing declaration information." 56 | 57 | (let ((info (function-binding function (get-environment env)))) 58 | (multiple-value-bind (type local decl) 59 | (cltl2-fn function-information function env) 60 | (values type local (append decl info))))) 61 | 62 | (defun declaration-information (decl-name &optional env) 63 | "Returns information about the declaration DECL-NAME in the 64 | environment ENV." 65 | 66 | (let ((ext-env (get-environment env))) 67 | (if (declaration-function decl-name) 68 | (declaration-info decl-name (get-environment env)) 69 | (cltl2-fn declaration-information decl-name env)))) 70 | 71 | #+ccl 72 | (defun augment-environment (env &key variable symbol-macro function macro declare) 73 | (when declare 74 | (let ((ext-env (copy-environment (get-environment env)))) 75 | (walk-declarations `((cl:declare ,@declare)) ext-env) 76 | (pushnew (list *env-sym* ext-env) symbol-macro :key #'ensure-car))) 77 | 78 | (cltl2-fn augment-environment 79 | env 80 | :variable variable 81 | :function function 82 | :macro macro 83 | :declare declare 84 | 85 | :symbol-macro symbol-macro)) 86 | 87 | (defmacro define-declaration (decl-name (arg-var &optional (env-var (gensym "ENV"))) &body body) 88 | "Defines a handler function for the user-defined declaration 89 | DECL-NAME. ARG-VAR is a symbol bound to the argument list of the 90 | declaration expression, ENV-VAR is a symbol bound to the lexical 91 | environment in which the declaration appears. The function should 92 | return two values: the first value is a keyword identifying whether 93 | the declaration applies to variable bindings (:VARIABLE), function 94 | bindings (:FUNCTION) or is a free declaration :DECLARE. If the 95 | first value is :VARIABLE or :FUNCTION the second must be a list 96 | where each element is of the form (BINDING-NAME KEY VALUE) where 97 | BINDING-NAME is the function or variable binding to which the 98 | declaration applies, and (KEY . VALUE) is the key value pair added 99 | to the declaration list of the binding. If the first value 100 | is :DECLARE the second value must be a CONS of the (KEY . VALUE), 101 | which is added to the declarations list of the lexical 102 | environment." 103 | 104 | 105 | (with-gensyms (args) 106 | (declare (ignorable args)) 107 | `(eval-when (:compile-toplevel :load-toplevel :execute) 108 | (declaim (declaration ,decl-name)) 109 | (setf (declaration-function ',decl-name) 110 | (lambda (,arg-var ,env-var) 111 | (declare (ignorable ,env-var)) 112 | ,@body)) 113 | 114 | #+ccl 115 | (ccl:define-declaration ,decl-name (,args) 116 | (let ((,arg-var (rest ,args)) ,env-var) 117 | (declare (ignorable ,env-var)) 118 | ,@body)) 119 | 120 | ',decl-name))) 121 | 122 | (defmacro in-environment ((env-var &optional (environment env-var)) (&rest bindings) &body forms) 123 | (flet ((make-binding (binding) 124 | (match binding 125 | ((type symbol) 126 | (list binding binding)) 127 | 128 | (_ binding)))) 129 | 130 | `(let ((,env-var ,environment) ,@(mapcar #'make-binding bindings)) 131 | ,@forms))) 132 | 133 | (defun augmented-macroexpand-1 (form &optional environment) 134 | (macroexpand-1 form environment)) 135 | 136 | (defun augmented-macroexpand (form &optional environment) 137 | (macroexpand form environment)) 138 | 139 | (defun augmented-macro-function (symbol &optional environment) 140 | (macro-function symbol environment)) 141 | 142 | (defun augmented-get-setf-expansion (form &optional environment) 143 | (get-setf-expansion form environment)) 144 | 145 | (defun augmented-compiler-macro-function (name &optional environment) 146 | (compiler-macro-function name environment)) 147 | 148 | (defun augmented-constantp (form &optional environment) 149 | (constantp form environment)) 150 | 151 | #+ccl 152 | (defun enclose-macro (name lambda-list body &optional environment) 153 | (enclose (ccl:parse-macro name lambda-list body environment) environment)) 154 | 155 | #+cmucl 156 | (defun enclose (lambda-expression &optional env) 157 | (flet ((walk-form (subform context env) 158 | (declare (ignore context)) 159 | 160 | ;; Expand symbol-macros since WALKER:MACROEXPAND-ALL does 161 | ;; not. 162 | 163 | (typecase subform 164 | (symbol 165 | (macroexpand-1 subform env)) 166 | 167 | (otherwise 168 | subform)))) 169 | 170 | (compile 171 | nil 172 | (walker:macroexpand-all ;; Expand all macros 173 | (walker:walk-form lambda-expression env #'walk-form) ;; Expand SYMBOL-MACROS 174 | env)))) 175 | 176 | #+cmucl 177 | (defun enclose-macro (name lambda-list body &optional env) 178 | (enclose 179 | (extensions:parse-macro 180 | name lambda-list 181 | `((block ,name ,@body)) ; Wrap in BLOCK since PARSE-MACRO does not 182 | env) 183 | env)) 184 | -------------------------------------------------------------------------------- /src/walker/declarations.lisp: -------------------------------------------------------------------------------- 1 | ;;;; declarations.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :cl-environments.cltl2) 27 | 28 | (defun walk-declarations (decl ext-env) 29 | "Walks the declare expressions in DECL and adds the information to 30 | EXT-ENV." 31 | 32 | (labels ((walk-decl (decl) 33 | (match-form (decl . args) decl 34 | (walk-declaration decl args ext-env))) 35 | 36 | (walk-declare (decl) 37 | (match-form ('cl:declare &rest decl) decl 38 | (mapc #'walk-decl decl)))) 39 | 40 | (check-list decl 41 | (mapc #'walk-declare decl)))) 42 | 43 | (defgeneric walk-declaration (decl args ext-env &optional global) 44 | (:documentation 45 | "Walks the declaration DECL with arguments ARGS and adds the 46 | information to EXT-ENV. If GLOBAL is true, the declarations are 47 | treated as global declarations, established by DECLAIM or 48 | PROCLAIM.")) 49 | 50 | 51 | ;;; Type Declarations 52 | 53 | #+cl-environments-full 54 | (defmethod walk-declaration ((decl (eql 'type)) args ext-env &optional global) 55 | "Adds type information to the information list of the variables in ARGS." 56 | 57 | (declare (ignore global)) 58 | 59 | (match-form (type &rest vars) args 60 | (add-variables-info vars 'type type ext-env))) 61 | 62 | #+cl-environments-full 63 | (defmethod walk-declaration ((decl (eql 'ftype)) args ext-env &optional global) 64 | "Adds type information to the information list of the functions in ARGS." 65 | 66 | (declare (ignore global)) 67 | 68 | (match-form (type &rest fns) args 69 | (add-functions-info fns 'ftype type ext-env))) 70 | 71 | 72 | ;;; Special declarations 73 | 74 | #+cl-environments-full 75 | (defmethod walk-declaration ((decl (eql 'special)) args ext-env &optional global) 76 | "Changes the binding types of the variables in ARGS to :SPECIAL. If 77 | a variable does not exist in the environment a new variable with 78 | binding type :SPECIAL is added." 79 | 80 | (check-list args 81 | (mapc 82 | (if global 83 | (rcurry #'ensure-variable-type ext-env :binding-type :special :global t) 84 | (rcurry #'ensure-special-variable ext-env)) 85 | args))) 86 | 87 | 88 | ;;; Dynamic extent declarations 89 | 90 | #+cl-environments-full 91 | (defmethod walk-declaration ((decl (eql 'dynamic-extent)) args ext-env &optional global) 92 | "Adds (DYNAMIC-EXTENT . T) to the information list of the variables 93 | and functions in ARGS." 94 | 95 | (unless global 96 | (check-list args 97 | (dolist (arg args) 98 | (match arg 99 | ((list 'function fn) 100 | (add-function-info fn 'dynamic-extent t ext-env)) 101 | ((satisfies symbolp) 102 | (add-variable-info arg 'dynamic-extent t ext-env))))))) 103 | 104 | 105 | ;;; Ignore declarations 106 | 107 | #+cl-environments-full 108 | (defmethod walk-declaration ((decl (eql 'ignore)) args ext-env &optional global) 109 | "Adds (IGNORE . T) to the information list of the variables in ARGS." 110 | 111 | (unless global 112 | (check-list args 113 | (dolist (arg args) 114 | (match arg 115 | ((list 'function fn) 116 | (add-function-info fn 'ignore t ext-env)) 117 | ((satisfies symbolp) 118 | (add-variable-info arg 'ignore t ext-env))))))) 119 | 120 | #+cl-environments-full 121 | (defmethod walk-declaration ((decl (eql 'ignorable)) args ext-env &optional global) 122 | "Currently does nothing as IGNORABLE declarations are not mentioned 123 | in CLTL2." 124 | 125 | (declare (ignore args ext-env global))) 126 | 127 | 128 | ;;; Inlining declarations 129 | 130 | #+cl-environments-full 131 | (defmethod walk-declaration ((decl (eql 'inline)) args ext-env &optional global) 132 | "Adds (INLINE . INLINE) to the information list of the functions in ARGS." 133 | 134 | (declare (ignore global)) 135 | (check-list args 136 | (add-functions-info args 'inline 'inline ext-env))) 137 | 138 | #+cl-environments-full 139 | (defmethod walk-declaration ((decl (eql 'notinline)) args ext-env &optional global) 140 | "Adds (INLINE . NOTINLINE) to the information list of the functions in ARGS." 141 | 142 | (declare (ignore global)) 143 | (check-list args 144 | (add-functions-info args 'inline 'notinline ext-env))) 145 | 146 | 147 | ;;; Optimization declarations 148 | 149 | ;; Non-standard implementation-specific optimization qualities are 150 | ;; currently ignored completely. 151 | 152 | #+cl-environments-full 153 | (defmethod walk-declaration ((decl (eql 'optimize)) args ext-env &optional global) 154 | "Normalizes the optimization qualities (in ARGS) to a list of 6 155 | elements, one for each quality, of the form (QUALITY . PPRIORITY) 156 | and adds the optimization information to the general declaration 157 | information in the environment. If ARGS does not contain an element 158 | for each quality, the priority for the quality in EXT-ENV is used 159 | instead." 160 | 161 | (declare (ignore global)) 162 | 163 | (check-list args 164 | (let ((info (declaration-info 'optimize ext-env))) 165 | (labels ((find-assoc (item list) 166 | (find item list :key #'ensure-car)) 167 | 168 | (priority (quality) 169 | (or (find-assoc quality args) 170 | (find-assoc quality info))) 171 | 172 | (ensure-quality (quality) 173 | (if (symbolp quality) 174 | (list quality 3) 175 | quality)) 176 | 177 | (get-priority (quality) 178 | (ensure-quality (priority quality)))) 179 | 180 | (setf (declaration-info 'optimize ext-env) 181 | (mapcar #'get-priority +optimize-qualities+)))))) 182 | 183 | 184 | ;;; Non-standard and user-defined declarations 185 | 186 | #+cl-environments-full 187 | (defmethod walk-declaration ((decl (eql 'declaration)) args ext-env &optional global) 188 | "Adds the declaration to the list of valid declarations." 189 | 190 | (when global 191 | (check-list args 192 | (unionf (declaration-info 'declaration ext-env) args :test #'eq)))) 193 | 194 | (defmethod walk-declaration (decl args ext-env &optional global) 195 | "If there is a declaration function, for DECL, (defined using 196 | DEFINE-DECLARATION) in EXT-ENV, it is called and the information 197 | returned by the function is added to the environment." 198 | 199 | (declare (ignore global)) 200 | 201 | (awhen (declaration-function decl) 202 | (multiple-value-call #'add-decl-info (funcall it args *env*) ext-env))) 203 | 204 | (defun add-decl-info (type info ext-env) 205 | "Adds the information returned by a declaration function to the 206 | environment. TYPE is the first return 207 | value (either :VARIABLE :FUNCTION or :DECLARE), INFO is the second 208 | return value." 209 | 210 | (flet ((add-binding-info (add-info) 211 | (loop 212 | for (sym key value) in info 213 | do (funcall add-info sym key value ext-env)))) 214 | (case type 215 | (:variable 216 | (add-binding-info #'add-variable-info)) 217 | (:function 218 | (add-binding-info #'add-function-info)) 219 | (:declare 220 | (setf (declaration-info (car info) ext-env) (cdr info)))))) 221 | -------------------------------------------------------------------------------- /src/walker/cl-overrides.lisp: -------------------------------------------------------------------------------- 1 | ;;;; cl-overrides.lisp 2 | ;;;; 3 | ;;;; Copyright 2018-2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (defpackage :cl-environments-cl 27 | (:nicknames :cl-environments) 28 | 29 | (:use :common-lisp 30 | :alexandria 31 | 32 | :cl-environments.util 33 | :cl-environments.cltl2) 34 | 35 | (:export :variable-information 36 | :function-information 37 | :declaration-information 38 | :define-declaration 39 | 40 | :augment-environment 41 | :in-environment 42 | :augmented-macroexpand-1 43 | :augmented-macroexpand 44 | :augmented-macro-function 45 | :augmented-get-setf-expansion 46 | :augmented-compiler-macro-function 47 | :augmented-constantp 48 | 49 | :enclose 50 | :parse-macro 51 | :enclose-macro 52 | 53 | :enable-hook 54 | :disable-hook 55 | 56 | :walk-environment) 57 | 58 | (:import-from :cl-environments.cltl2 59 | :enclose-form) 60 | 61 | ;; Only import if the full code walker is used. 62 | 63 | #+cl-environments-full 64 | (:import-from :cl-environments.cltl2 65 | :augmented-environment 66 | :base-environment) 67 | 68 | (:shadow :flet 69 | :labels 70 | :let 71 | :let* 72 | :locally 73 | :macrolet 74 | :symbol-macrolet 75 | 76 | :defun 77 | :defmacro 78 | :defgeneric 79 | :defmethod 80 | 81 | :defparameter 82 | :defvar 83 | :defconstant 84 | :define-symbol-macro 85 | 86 | :declaim) 87 | 88 | 89 | ;; Shadowed functions which take ENVIRONMENT parameters. Only 90 | ;; shadow when the full code-walker is used, meaning that a 91 | ;; non-native AUGMENT-ENVIRONMENT implementation is used. 92 | 93 | #+cl-environments-full 94 | (:shadow 95 | :macroexpand 96 | :macroexpand-1 97 | :macro-function 98 | :compiler-macro-function 99 | :constantp 100 | :get-setf-expansion 101 | :typep 102 | :subtypep) 103 | 104 | (:documentation 105 | "Package exporting the CLTL2 environments API and shadowing the 106 | special forms so that it works correctly across 107 | implementations.")) 108 | 109 | (in-package :cl-environments-cl) 110 | 111 | ;;; Shadow CL special forms with macros, which simply expand into the 112 | ;;; special forms, in for them to be walked when *MACROEXPAND-HOOK* is 113 | ;;; called. 114 | 115 | (cl:defmacro add-cl-form-macros (&rest ops) 116 | "Defines shadowing macros for special forms in the CL package. Each 117 | element of OPS is a list where the first element is the symbol, for 118 | which the macro will be defined, and the remaining elements are the 119 | macro's lambda-list (only used for documentation in SLIME). The 120 | macro defined expands into the same form with the macro operator 121 | symbol replaced by the special operator symbol, which has the same 122 | SYMBOL-NAME as the macro but in the CL package." 123 | 124 | (cl:let ((whole (gensym "WHOLE"))) 125 | (cl:labels ((lambda-list-args (list) 126 | (set-difference (flatten list) lambda-list-keywords)) 127 | 128 | (shadowing-macro (sym args) 129 | (cl:let* ((name (symbol-name sym)) 130 | (op (intern name :cl))) 131 | 132 | `(cl:defmacro ,sym (&whole ,whole ,@args) 133 | (declare (ignore ,@(lambda-list-args args))) 134 | (enclose-form (cons ',op (rest ,whole))))))) 135 | 136 | `(cl:progn 137 | ,@(loop 138 | for (sym . args) in ops 139 | collect (shadowing-macro sym args)))))) 140 | 141 | 142 | (add-cl-form-macros 143 | (flet (&rest bindings) &body body) 144 | (labels (&rest bindings) &body body) 145 | (let (&rest bindings) &body body) 146 | (let* (&rest bindings) &body body) 147 | (locally &body body) 148 | (macrolet (&rest bindings) &body body) 149 | (symbol-macrolet (&rest bindings) &body body) 150 | 151 | (defun name (&rest lambda-list) &body body) 152 | (defgeneric name (&rest lambda-list) &body options) 153 | (defmethod name &rest def) 154 | 155 | (defmacro name (&rest lambda-list) &body body) 156 | (defparameter name value &rest args) 157 | (defvar name &rest args) 158 | (defconstant name value &rest args) 159 | (define-symbol-macro symbol expansion) 160 | 161 | (declaim &rest declaration-specifiers)) 162 | 163 | 164 | ;;; Only implement these functions when the full code walker is used, 165 | ;;; meaning that AUGMENT-ENVIRONMENT is not natively provided. 166 | 167 | #+cl-environments-full 168 | (progn 169 | ;; Shadow functions which take ENVIRONMENT parameter 170 | 171 | (defun macroexpand (form &optional environment) 172 | (augmented-macroexpand form environment)) 173 | 174 | (defun macroexpand-1 (form &optional environment) 175 | (augmented-macroexpand-1 form environment)) 176 | 177 | (defun macro-function (symbol &optional environment) 178 | (augmented-macro-function symbol environment)) 179 | 180 | (defun (setf macro-function) (new-fn symbol &optional (environment nil environment-p)) 181 | (declare (ignorable environment)) 182 | 183 | ;; Technically Calling (SETF MACRO-FUNCTION) with a non-NIL 184 | ;; environment parameter is undefined, but we want to preserve the 185 | ;; actual behaviour on the implementation. 186 | 187 | (if environment-p 188 | (setf (cl:macro-function symbol environment) (get-base-environment new-fn)) 189 | (setf (cl:macro-function symbol) new-fn))) 190 | 191 | (defun compiler-macro-function (symbol &optional environment) 192 | (augmented-compiler-macro-function symbol environment)) 193 | 194 | (defun (setf compiler-macro-function) (new-fn symbol &optional (environment nil environment-p)) 195 | (declare (ignorable environment environment-p)) 196 | 197 | ;; Technically Calling (SETF COMPILER-MACRO-FUNCTION) with a non-NIL 198 | ;; environment parameter is undefined, but we want to preserve the 199 | ;; actual behaviour on the implementation. 200 | 201 | #-ecl 202 | (if environment-p 203 | (setf (cl:compiler-macro-function symbol (get-base-environment environment)) new-fn) 204 | (setf (cl:compiler-macro-function symbol) new-fn)) 205 | 206 | #+ecl 207 | (setf (cl:compiler-macro-function symbol) new-fn)) 208 | 209 | (defun constantp (form &optional environment) 210 | (augmented-constantp form environment)) 211 | 212 | (defun get-setf-expansion (place &optional environment) 213 | (augmented-get-setf-expansion place environment)) 214 | 215 | (defun typep (object type-specifier &optional environment) 216 | (cl:typep object type-specifier (get-base-environment environment))) 217 | 218 | (defun subtypep (type-1 type-2 &optional environment) 219 | (cl:subtypep type-1 type-2 (get-base-environment environment))) 220 | 221 | (defun get-base-environment (environment) 222 | (typecase environment 223 | (augmented-environment 224 | (base-environment environment)) 225 | 226 | (otherwise 227 | environment)))) 228 | 229 | ;;; Re-export all symbols imported from the CL package except symbols 230 | ;;; which have been shadowed 231 | 232 | (eval-when (:compile-toplevel :load-toplevel :execute) 233 | (let ((shadowed (mapcar #'symbol-name (package-shadowing-symbols :cl-environments)))) 234 | (do-external-symbols (sym :cl) 235 | (export (if (member (symbol-name sym) shadowed :test #'string=) 236 | (find-symbol (symbol-name sym) :cl-environments) 237 | (list sym)) 238 | :cl-environments)))) 239 | -------------------------------------------------------------------------------- /src/walker/let-forms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; let-forms.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :cl-environments.cltl2) 27 | 28 | ;;;; Code-walkers for: LET, LET*, FLET, LABELS, MACROLET and 29 | ;;;; SYMBOL-MACROLET. 30 | 31 | ;;; LET forms 32 | 33 | (defwalker cl:let (args) 34 | "Walks LET binding forms, augments the environment ENV with the 35 | bindings introduced, adds the declaration information to the 36 | bindings and encloses the body of the LET form in the augmented 37 | environment." 38 | 39 | (match-form ((&rest bindings) . body) args 40 | (let* ((env (copy-environment (get-environment *env*)))) 41 | (cons (walk-let-bindings bindings env) 42 | (walk-body body env))))) 43 | 44 | (defun walk-let-bindings (bindings env) 45 | "Walks the bindings of a LET form. Adds the variable bindings to the 46 | environment ENV and encloses the init-forms of the bindings (if any) 47 | in the code walking macro. Returns the new bindings list." 48 | 49 | (flet ((enclose-binding (binding) 50 | (match binding 51 | ((list var initform) 52 | `(,var ,(enclose-form initform))) 53 | (_ binding)))) 54 | 55 | (loop 56 | for binding in bindings 57 | collect (enclose-binding binding) 58 | do 59 | (add-variable (ensure-car binding) env)))) 60 | 61 | (defun walk-body (body ext-env &optional documentation) 62 | "Walks the body of forms which create a local environment, such as 63 | LET/FLET/LOCALLY. Adds the declaration information to the bindings 64 | in the environment EXT-ENV, and encloses the body in the augmented 65 | environment. If DOCUMENTATION is true the body may contain a 66 | documentation string preceding or following the declarations." 67 | 68 | (check-list body 69 | (multiple-value-bind (forms decl docstring) 70 | (parse-body body :documentation documentation) 71 | (walk-declarations decl ext-env) 72 | `(,@(ensure-list docstring) 73 | ,@decl 74 | ,(enclose-in-env 75 | ext-env 76 | forms))))) 77 | 78 | 79 | ;;; LET* forms 80 | 81 | (defwalker cl:let* (args) 82 | "Walks LET* binding forms: encloses each init-form in an environment 83 | containing all variables in the preceding bindings. Encloses the 84 | body in an environment containing all the variable bindings 85 | introduced by the LET*." 86 | 87 | (match-form ((&rest bindings) . body) args 88 | (let* ((env (get-environment *env*)) 89 | (body-env (create-let*-env bindings env)) 90 | (body (walk-body body body-env)) 91 | (bindings (walk-let*-bindings bindings env body-env))) 92 | 93 | (cons bindings body)))) 94 | 95 | (defun create-let*-env (bindings env) 96 | "Creates the lexical environment for the body of a LET* form, by 97 | adding the BINDINGS to a copy of the environment ENV. Returns the 98 | new environment." 99 | 100 | (let ((env (copy-environment env))) 101 | (dolist (binding bindings env) 102 | (add-variable (ensure-car binding) env)))) 103 | 104 | (defun walk-let*-bindings (bindings env body-env) 105 | "Walks the bindings of a LET*. ENV is the environment containing the 106 | LET* form and BODY-ENV is the environment in which the body of the 107 | LET* form is enclosed, i.e. the environment containing all the 108 | bindings introduced by the LET*. Each init-form is enclosed in an 109 | environment which contains all the previous bindings copied from 110 | BODY-ENV." 111 | 112 | (flet ((enclose-binding (binding env) 113 | (match binding 114 | ((list var initform) 115 | `(,var ,(enclose-in-env env (list initform)))) 116 | (_ binding)))) 117 | 118 | (loop 119 | for binding in bindings 120 | collect (enclose-binding binding env) 121 | do 122 | (setf env (copy-environment env)) 123 | (let ((var (ensure-car binding))) 124 | (setf (variable-binding var env) ; Copy binding in BODY-ENV to ENV 125 | (variable-binding var body-env)))))) 126 | 127 | 128 | ;;; Lexical functions 129 | 130 | (defwalker cl:flet (args) 131 | "Walks FLET forms. The functions introduced by the FLET are added to 132 | a copy of the environment ENV, in which the body, of the FLET form, 133 | is enclosed. The body of each function is enclosed in an 134 | environment containing the variables in the function's lambda list, 135 | however it does not contain the functions themselves." 136 | 137 | (let* ((env (get-environment *env*)) 138 | (new-env (copy-environment env))) 139 | 140 | (match-form ((&rest fns) . body) args 141 | (cons (mapcar (rcurry #'walk-local-fn env new-env) fns) 142 | (walk-body body new-env))))) 143 | 144 | (defwalker cl:labels (args) 145 | "Walks LABELS forms. The functions introduced by the LABELS are 146 | added to a copy of the environment ENV, in which the body, of the 147 | LABELS form, is enclosed. The body of each function is enclosed in 148 | an environment containing: all the functions, introduced by the 149 | LABELS, and the variables in the function's lambda list. All 150 | declarations, bound to the functions introduced by the LABELS, are 151 | added to the environments of the function bodies." 152 | 153 | (let* ((env (copy-environment (get-environment *env*))) 154 | (body-env (copy-environment env))) 155 | 156 | (labels 157 | ((make-fn-env (fns) 158 | (dolist (fn fns env) 159 | (match-form (name . _) fn 160 | (setf (function-binding name env) ; Copy binding from BODY-ENV to ENV 161 | (function-binding name body-env))))) 162 | 163 | (walk-fns (fns) 164 | (loop 165 | for fn in fns 166 | with env = (make-fn-env fns) 167 | collect 168 | (match-form (name . def) fn 169 | (cons name (walk-fn-def def env t)))))) 170 | 171 | ;; Add all function-bindings to BODY-ENV 172 | (match-form ((&rest fns) . body) args 173 | (loop 174 | for fn in fns 175 | do 176 | (match-form (name . _) fn 177 | (add-function name body-env))) 178 | 179 | (let ((body (walk-body body body-env))) 180 | (cons (walk-fns fns) 181 | body)))))) 182 | 183 | 184 | (defun walk-local-fn (def fn-env new-env) 185 | "Walks a lexical function, defined using FLET or LABELS. Adds the 186 | function to the environment NEW-ENV and encloses the body of the 187 | function in a copy of the environment FN-ENV containing the 188 | variables introduced by the function's lambda list." 189 | 190 | (match-form (name . def) def 191 | (add-function name new-env) 192 | `(,name ,@(walk-fn-def def fn-env t)))) 193 | 194 | (defun walk-fn-def (def env &optional documentation) 195 | "Walks a function definition, DEF is a list where the first element 196 | is the function's lambda-list and the rest of the elements are the 197 | forms making up the function's body. The variables introduced by 198 | the lambda-list are added to a copy of the environment ENV, the 199 | body is enclosed in this environment. The new lambda-list and body 200 | are returned. This function can be used both for lexical function 201 | definitions and for global function definitions." 202 | 203 | (match-form (lambda-list . body) def 204 | (multiple-value-bind (lambda-list env) 205 | (walk-lambda-list lambda-list env) 206 | (cons lambda-list (walk-body body env documentation))))) 207 | 208 | 209 | ;;; Lexical Macros 210 | 211 | (defwalker cl:macrolet (args) 212 | "Walks MACROLET forms. Each macro is added to a copy of the 213 | environment ENV, in which the body of the MACROLET form is 214 | enclosed. The body of each macro is enclosed in an environment 215 | containing the variables introduced by the macro's lambda-list, but 216 | does not contain the macro itself." 217 | 218 | (match-form ((&rest macros) . body) args 219 | 220 | (let* ((env (get-environment *env*)) 221 | (new-env (copy-environment env))) 222 | 223 | (cons (mapcar (rcurry #'walk-local-macro env new-env) macros) 224 | (walk-body body new-env))))) 225 | 226 | (defun walk-local-macro (def mac-env new-env) 227 | "Walks a lexical macro, defined using MACROLET. Adds the macro to 228 | the environment NEW-ENV and encloses the body of the macro in a 229 | copy of the environment MAC-ENV containing the variables introduced 230 | by the macro's lambda list." 231 | 232 | (match-form (name . def) def 233 | (add-function name new-env :binding-type :macro) 234 | (cons name (walk-macro-def def mac-env)))) 235 | 236 | (defun walk-macro-def (def env) 237 | "Walks a macro definition, DEF is a list where the first element is 238 | the macro's lambda-list and the rest of the elements are the forms 239 | making up the body of the macro. The variables introduced by the 240 | lambda-list are added to a copy of the environment ENV with the 241 | body enclosed in this environment. The new lambda-list and body is 242 | returned. This function can be used both for lexical macro 243 | definitions and for global macro definitions." 244 | 245 | (match-form (lambda-list . body) def 246 | (multiple-value-bind (lambda-list env) 247 | (walk-lambda-list lambda-list env :destructure t :env t) 248 | 249 | (cons lambda-list (walk-body body env t))))) 250 | 251 | 252 | ;;; Lexical Symbol Macros 253 | 254 | (defwalker cl:symbol-macrolet (args) 255 | "Walks SYMBOL-MACROLET forms. Each symbol macro is added to a copy 256 | of the environment ENV, and the body is enclosed in this 257 | environment." 258 | 259 | (match-form ((&rest macros) . body) args 260 | (if (not (eq (caar macros) *env-sym*)) 261 | (let ((env (copy-environment (get-environment *env*)))) 262 | (mapc (compose (rcurry #'add-symbol-macro env) #'first) macros) 263 | (cons macros (walk-body body env))) 264 | args))) 265 | -------------------------------------------------------------------------------- /src/other/sbcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; sbcl.lisp 2 | ;;;; 3 | ;;;; Copyright 2018 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (eval-when (:compile-toplevel :load-toplevel :execute) 27 | (require :sb-cltl2)) 28 | 29 | (defpackage :cl-environments.cltl2 30 | (:use :common-lisp 31 | :sb-cltl2 32 | :alexandria 33 | :anaphora 34 | :iterate 35 | :optima 36 | :tcr.parse-declarations-1.0 37 | 38 | :cl-environments.util) 39 | 40 | (:shadow :define-declaration :declaration-information :augment-environment) 41 | 42 | (:export :variable-information 43 | :function-information 44 | :declaration-information 45 | :define-declaration 46 | 47 | :augment-environment 48 | :enclose 49 | :parse-macro 50 | :enclose-macro 51 | 52 | :in-environment 53 | :augmented-macroexpand-1 54 | :augmented-macroexpand 55 | :augmented-macro-function 56 | :augmented-get-setf-expansion 57 | :augmented-compiler-macro-function 58 | :augmented-constantp 59 | 60 | :enable-hook 61 | :disable-hook 62 | 63 | :walk-environment)) 64 | 65 | (defpackage :cl-environments-cl 66 | (:nicknames :cl-environments) 67 | (:use :common-lisp 68 | :cl-environments.util 69 | :cl-environments.cltl2) 70 | 71 | (:export :variable-information 72 | :function-information 73 | :declaration-information 74 | :define-declaration 75 | 76 | :augment-environment 77 | :enclose 78 | :enclose-macro 79 | 80 | :in-environment 81 | :augmented-macroexpand-1 82 | :augmented-macroexpand 83 | :augmented-macro-function 84 | :augmented-get-setf-expansion 85 | :augmented-compiler-macro-function 86 | :augmented-constantp 87 | 88 | :enable-hook 89 | :disable-hook 90 | 91 | :walk-environment)) 92 | 93 | (in-package :cl-environments.cltl2) 94 | 95 | ;; SB-INT:TRULY-DYNAMIC-EXTENT has been removed on newer versions of 96 | ;; SBCL. This form checks whether the symbol exists and if so adds a 97 | ;; feature in order to be to check for its existence using #+ 98 | 99 | (eval-when (:compile-toplevel :load-toplevel :execute) 100 | (when (find-symbol "TRULY-DYNAMIC-EXTENT" :sb-int) 101 | (pushnew :cl-environments-truly-dynamic-extent *features*))) 102 | 103 | 104 | ;; SBCL includes declaration name in arguments 105 | 106 | (defmacro define-declaration (decl-name (arg-var &optional (env-var (gensym "ENV"))) &body body) 107 | (with-gensyms (args) 108 | (multiple-value-bind (forms decl docstring) 109 | (parse-body body :documentation t) 110 | 111 | (multiple-value-bind (decl-args decl-other) 112 | (partition-declarations (list arg-var) decl) 113 | 114 | `(sb-cltl2:define-declaration ,decl-name (,args ,env-var) 115 | ,@(ensure-list docstring) 116 | (declare (ignorable ,env-var)) 117 | ,@decl-other 118 | 119 | (let ((,arg-var (rest ,args))) 120 | ,@decl-args 121 | (multiple-value-call #'wrap-declaration-result (progn ,@forms)))))))) 122 | 123 | (defun wrap-declaration-result (type value) 124 | "Wrap user-define declarations (TYPE = :DECLARE) in a list to 125 | silence errors due to SBCL bug." 126 | 127 | (values 128 | type 129 | (case type 130 | (:declare 131 | (cons (car value) (list 'user-declaration (cdr value)))) 132 | 133 | (otherwise 134 | value)))) 135 | 136 | (defun declaration-information (name &optional env) 137 | (match (sb-cltl2:declaration-information name env) 138 | ((list 'user-declaration value) 139 | value) 140 | 141 | (value value))) 142 | 143 | ;;; SBCL's AUGMENT-ENVIRONMENT errors out when augmenting an 144 | ;;; environment with type information for a variable which is not 145 | ;;; simultaneously present in the :VARIABLE argument, even if the 146 | ;;; environment being augmented does contain a binding for the 147 | ;;; variable. 148 | ;;; 149 | ;;; This wrapper function handles that case by adding variables, and 150 | ;;; functions, appearing in type declarations to the :VARIABLE and 151 | ;;; :FUNCTION lists. 152 | 153 | (defun augment-environment (env &key variable symbol-macro function macro declare) 154 | (labels ((extract-var (decl) 155 | "Extract variable names from TYPE declarations." 156 | 157 | (match decl 158 | ((list* 'type _ 159 | (guard vars 160 | (and (proper-list-p vars) 161 | (every #'symbolp vars)))) 162 | vars) 163 | 164 | ((list* (or 'ignore 'ignorable) things) 165 | (remove-if #'listp things)) 166 | 167 | ((list* 'dynamic-extent things) 168 | (remove-if #'listp things)) 169 | 170 | #+cl-environments-truly-dynamic-extent 171 | ((list* 'sb-int:truly-dynamic-extent things) 172 | (remove-if #'listp things)))) 173 | 174 | (function-name-p (name) 175 | (match name 176 | ((or (type symbol) 177 | (list 'cl:setf (type symbol))) 178 | t))) 179 | 180 | (extract-func (decl) 181 | "Extract function names from FTYPE declarations." 182 | 183 | (match decl 184 | ((list* 'ftype _ 185 | (guard fns 186 | (and (proper-list-p fns) 187 | (every #'function-name-p fns)))) 188 | fns) 189 | 190 | ((list* (or 'ignore 'ignorable) things) 191 | (remove-if #'symbolp things)) 192 | 193 | ((list* (or 'inline 'notinline) 194 | (guard fns 195 | (and (proper-list-p fns) 196 | (every #'function-name-p fns)))) 197 | fns) 198 | 199 | ((list* 'dynamic-extent things) 200 | (mapcar #'second (remove-if #'symbolp things))))) 201 | 202 | (decl-special-var (var) 203 | (when (and (not (eq :special (variable-information var))) 204 | (eq :special (variable-information var env))) 205 | `((special ,var))))) 206 | 207 | (let ((decl-vars (set-difference (mappend #'extract-var declare) 208 | symbol-macro)) 209 | (decl-fns (set-difference (mappend #'extract-func declare) 210 | macro))) 211 | 212 | (sb-cltl2:augment-environment 213 | env 214 | :variable (union decl-vars variable) 215 | 216 | :function (union decl-fns function) 217 | 218 | :symbol-macro symbol-macro 219 | :macro macro 220 | :declare (append (mappend #'decl-special-var decl-vars) 221 | declare))))) 222 | 223 | (defun enclose-macro (name lambda-list body &optional env) 224 | (enclose (parse-macro name lambda-list body env) env)) 225 | 226 | (defmacro in-environment ((env-var &optional (environment env-var)) (&rest bindings) &body forms) 227 | (flet ((make-binding (binding) 228 | (match binding 229 | ((type symbol) 230 | (list binding binding)) 231 | 232 | (_ binding)))) 233 | 234 | `(let ((,env-var ,environment) ,@(mapcar #'make-binding bindings)) 235 | ,@forms))) 236 | 237 | (defun augmented-macroexpand-1 (form &optional env) 238 | (macroexpand-1 form env)) 239 | 240 | (defun augmented-macroexpand (form &optional env) 241 | (macroexpand form env)) 242 | 243 | (defun augmented-macro-function (name &optional env) 244 | (macro-function name env)) 245 | 246 | (defun augmented-get-setf-expansion (form &optional env) 247 | (get-setf-expansion form env)) 248 | 249 | (defun augmented-compiler-macro-function (name &optional environment) 250 | (compiler-macro-function name environment)) 251 | 252 | (defun augmented-constantp (form &optional environment) 253 | (constantp form environment)) 254 | 255 | 256 | (defun enable-hook (&optional previous-hook) 257 | "Does nothing, provided for compatibility with implementations where 258 | the code walker is required." 259 | 260 | (declare (ignore previous-hook))) 261 | 262 | (defun disable-hook (&optional previous-hook) 263 | "Does nothing, provided for compatibility with implementations where 264 | the code walker is required." 265 | 266 | (declare (ignore previous-hook))) 267 | 268 | (defmacro walk-environment (&body forms) 269 | `(progn ,@forms)) 270 | 271 | (defmacro disable-walker (&body body) 272 | `(progn ,@body)) 273 | 274 | ;;; Parsing declarations 275 | 276 | ;; From Serapeum / macro-tools.lisp 277 | 278 | ;; Copyright (c) 2014 Paul M. Rodriguez 279 | 280 | ;; Permission is hereby granted, free of charge, to any person obtaining 281 | ;; a copy of this software and associated documentation files (the 282 | ;; "Software"), to deal in the Software without restriction, including 283 | ;; without limitation the rights to use, copy, modify, merge, publish, 284 | ;; distribute, sublicense, and/or sell copies of the Software, and to 285 | ;; permit persons to whom the Software is furnished to do so, subject to 286 | ;; the following conditions: 287 | 288 | ;; The above copyright notice and this permission notice shall be 289 | ;; included in all copies or substantial portions of the Software. 290 | 291 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 292 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 293 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 294 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 295 | ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 296 | ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 297 | ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 298 | 299 | (defun partition-declarations (xs declarations &optional env) 300 | "Split DECLARATIONS into those that do and do not apply to XS. 301 | Return two values, one with each set. 302 | 303 | Both sets of declarations are returned in a form that can be spliced 304 | directly into Lisp code: 305 | 306 | (locally ,@(partition-declarations vars decls) ...)" 307 | (let ((env2 (parse-declarations declarations env))) 308 | (flet ((build (env) 309 | (build-declarations 'declare env))) 310 | (if (null xs) 311 | (values nil (build env2)) 312 | (values 313 | (build (filter-declaration-env env2 :affecting xs)) 314 | (build (filter-declaration-env env2 :not-affecting xs))))))) 315 | 316 | 317 | (in-package :cl-environments-cl) 318 | 319 | (eval-when (:compile-toplevel :load-toplevel :execute) 320 | (reexport-all-symbols :cl)) 321 | -------------------------------------------------------------------------------- /src/walker/cltl2-interface.ecl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; ecl.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; ECL specific implementation of the CLTL2 API 27 | 28 | (in-package :cl-environments.cltl2) 29 | 30 | 31 | ;;; Variable Information 32 | 33 | (defun variable-information (variable &optional env) 34 | "Return information about the variable VARIABLE in the environment ENV." 35 | 36 | (let ((extra (variable-binding variable (get-environment env))) 37 | (env (or env c::*cmp-env-root*))) 38 | 39 | (multiple-value-bind (type local decl) 40 | (native-var-information variable env) 41 | 42 | (values type local (append decl extra))))) 43 | 44 | (defun native-var-information (variable env) 45 | (acond 46 | ((c::cmp-env-search-var variable env) 47 | (if (c::var-p it) 48 | (values 49 | (var-kind it) 50 | t 51 | (list 52 | (cons 'type (c::var-type it)) 53 | (cons 'ignore (var-ignorable? it)))) 54 | 55 | (values 56 | (local-var-kind variable env) 57 | t 58 | (list 59 | (cons 'type (c::variable-type-in-env variable env)))))) 60 | 61 | ((c::cmp-env-search-symbol-macro variable env) 62 | (values 63 | :symbol-macro 64 | t 65 | nil)) 66 | 67 | ((nth-value 1 (macroexpand variable env)) 68 | (values 69 | :symbol-macro 70 | nil 71 | nil)) 72 | 73 | ((constantp variable env) 74 | (global-var-info :constant variable env)) 75 | 76 | ((sys:specialp variable) 77 | (global-var-info :special variable env)) 78 | 79 | (t 80 | (values nil nil nil)))) 81 | 82 | (defun local-var-kind (var env) 83 | "Determine the kind (lexical, special, etc) of a local variable in 84 | an environment." 85 | 86 | (let ((spec (find-if 87 | (lambda (spec) 88 | (match spec 89 | ((list* (eql var) _) t))) 90 | 91 | (c::cmp-env-variables env)))) 92 | 93 | (match spec 94 | ((list* _ 'c::special _) :special) 95 | ((list* _ 'si::symbol-macro) :symbol-macro) 96 | (nil (si:specialp var)) 97 | (_ :lexical)))) 98 | 99 | (defun var-kind (var) 100 | (acase (c::var-kind var) 101 | (c::lexical :lexical) 102 | (c::special :special) 103 | (otherwise it))) 104 | 105 | (defun global-var-info (kind var env) 106 | (values 107 | kind 108 | nil 109 | (acons 'type (c::variable-type-in-env var env) nil))) 110 | 111 | ;; From HU.DWIM.WALKER 112 | (defun var-ignorable? (var) 113 | #.(cl:if (cl:< ext:+ecl-version-number+ 100701) 114 | `(< (c::var-ref var) 0) 115 | `(and (c::var-ignorable var) 116 | (< (c::var-ignorable var) 0)))) 117 | 118 | 119 | ;;; Function Information 120 | 121 | (defun function-information (function &optional env) 122 | "Return information about the function FUNCTION in the environment ENV." 123 | 124 | (let ((extra (function-binding function (get-environment env))) 125 | (env (or env c::*cmp-env-root*))) 126 | 127 | (multiple-value-bind (type local decl) 128 | (native-function-information function env) 129 | 130 | (values type local (append decl extra))))) 131 | 132 | (defun native-function-information (function env) 133 | (cond 134 | ((and (symbolp function) 135 | (special-operator-p function)) 136 | 137 | (values :special-form nil nil)) 138 | 139 | ((c::cmp-env-search-macro function env) 140 | (values :macro t nil)) 141 | 142 | ((c::cmp-env-search-function function env) 143 | (function-info function t env)) 144 | 145 | ((macro-function function env) 146 | (values :macro nil nil)) 147 | 148 | ((fboundp function) 149 | (function-info function nil env)) 150 | 151 | (t 152 | (values nil nil nil)))) 153 | 154 | (defun function-info (function local env) 155 | (values 156 | :function 157 | local 158 | 159 | (list 160 | (cons 'inline (inlinep function env)) 161 | (cons 'ftype (cons 'function (get-ftype function env)))))) 162 | 163 | (defun inlinep (function env) 164 | (cond 165 | ((c::declared-inline-p function env) 'inline) 166 | ((c::declared-notinline-p function env) 'notinline))) 167 | 168 | (defun get-ftype (function env) 169 | (multiple-value-bind (arg-types got-arg-types-p) 170 | (c::get-arg-types function env) 171 | 172 | (multiple-value-bind (return-type got-return-type-p) 173 | (c::get-return-type function env) 174 | 175 | (when (or got-arg-types-p got-return-type-p) 176 | `(,(if got-arg-types-p 177 | arg-types 178 | '*) 179 | 180 | ,(if got-return-type-p 181 | return-type 182 | '*)))))) 183 | 184 | 185 | ;;; Declaration Information 186 | 187 | (defun declaration-information (name &optional env) 188 | "Return information about the declaration DECL-NAME in the environment ENV." 189 | 190 | (case name 191 | (optimize 192 | (destructuring-bind (&optional (debug 1) (safety 1) (space 1) (speed 1) &rest others) 193 | (c::cmp-env-all-optimizations env) 194 | 195 | (declare (ignore others)) 196 | 197 | ;; 1 is always returned for COMPILATION-SPEED since ECL doesn't 198 | ;; record it. 199 | 200 | `((debug ,debug) 201 | (safety ,safety) 202 | (space ,space) 203 | (speed ,speed) 204 | (compilation-speed 1)))) 205 | 206 | (declaration 207 | si:*alien-declarations*) 208 | 209 | (otherwise 210 | (let ((ext-env (get-environment env))) 211 | (declaration-info name ext-env))))) 212 | 213 | (defmacro define-declaration (decl-name (arg-var &optional (env-var (gensym "ENV"))) &body body) 214 | "Defines a handler function for the a user-defined declaration." 215 | 216 | `(eval-when (:compile-toplevel :load-toplevel :execute) 217 | (declaim (declaration ,decl-name)) 218 | (setf (declaration-function ',decl-name) 219 | (lambda (,arg-var ,env-var) 220 | (declare (ignorable ,env-var)) 221 | ,@body)) 222 | 223 | #+ccl (ccl:define-declaration ,decl-name (,arg-var) 224 | (let (,env-var) 225 | (declare (ignorable ,env-var)) 226 | ,@body)) 227 | 228 | ',decl-name)) 229 | 230 | 231 | ;;; Augment Environment 232 | 233 | (defun augment-environment (env &key variable symbol-macro function macro declare) 234 | "Augment an environment (ENV) with new information." 235 | 236 | (let ((env (c::cmp-env-copy (or env c::*cmp-env-root*)))) 237 | (loop 238 | for name in variable 239 | for var = (c::make-var :name name :kind 'c::lexical) 240 | do 241 | (setf env (c::cmp-env-register-var var env))) 242 | 243 | (loop for (name def) in symbol-macro 244 | do 245 | (setf env (c::cmp-env-register-symbol-macro name def env))) 246 | 247 | (loop 248 | for fn in function 249 | for fun = (c::make-fun :name fn) 250 | do 251 | (setf env (c::cmp-env-register-function fun env))) 252 | 253 | (loop for (name fn) in macro 254 | do 255 | (setf env (c::cmp-env-register-macro name fn env))) 256 | 257 | (loop for (type . arguments) in declare 258 | do 259 | (setf env (augment-declaration type arguments env))) 260 | 261 | env)) 262 | 263 | (defun augment-declaration (name args env) 264 | "Augment an environment with declaration information. 265 | 266 | NAME is the declaration name. 267 | 268 | ARGS is the argument list passed to the DECLARE expression. 269 | 270 | ENV is the environment. 271 | 272 | Returns the augmented environment." 273 | 274 | (case name 275 | (optimize 276 | (c::cmp-env-add-optimizations args env)) 277 | 278 | (special 279 | (loop for name in args 280 | for var = (c::cmp-env-search-var var env) 281 | do 282 | ;; If CMP-ENV-DECLARE-SPECIAL is called, on some 283 | ;; environments, in which the variable is not a C::VAR 284 | ;; structure, an access violation is signalled. 285 | 286 | (if (c::var-p var) 287 | (setf env (c::cmp-env-declare-special var env)) 288 | (setf env (c::cmp-env-register-var 289 | (c::make-var :name name :kind 'c::special) 290 | env)))) 291 | env) 292 | 293 | (type 294 | (destructuring-bind (type &rest vars) args 295 | (loop 296 | for name in vars 297 | for var = (c::cmp-env-search-var name env) 298 | do 299 | (cond 300 | ((c::var-p var) 301 | (let ((var (c::copy-var var))) 302 | (setf (c::var-type var) type) 303 | (setf env 304 | (c::cmp-env-register-var var env)))) 305 | 306 | (var) 307 | 308 | ((si::specialp var) 309 | (let ((var (c::make-var :name name 310 | :kind 'c::special 311 | :type type))) 312 | 313 | (setf env 314 | (c::cmp-env-register-var var env)))) 315 | 316 | (t 317 | (aif (augment-symbol-macro-type name type env) 318 | (setf env it) 319 | (warn "AUGMENT-ENVIRONMENT: (TYPE ~s) declaration for unknown variable ~s." type name)))))) 320 | env) 321 | 322 | ;; ECL doesn't record DYNAMIC-EXTENT and there isn't much use for 323 | ;; augmenting an environment with IGNORE declarations hence these 324 | ;; are ignored 325 | ((dynamic-extent ignore ignorable) 326 | env) 327 | 328 | (otherwise 329 | (c::add-one-declaration env (cons name args))))) 330 | 331 | (defun augment-symbol-macro-type (name type env) 332 | "Augment a symbol-macro with type information." 333 | 334 | (when-let ((sym-macro (c::cmp-env-search-symbol-macro name env))) 335 | (let ((expression `(the ,type (funcall sym-macro name nil)))) 336 | (c::cmp-env-register-symbol-macro name expression env)))) 337 | 338 | 339 | ;;; ENCLOSE and PARSE-MACRO 340 | 341 | (defun parse-macro (name lambda-list body &optional environment) 342 | "Parse a macro definition form (as found in MACROLET or DEFMACRO). 343 | 344 | NAME is the name of the macro. The body of the macro is enclosed in 345 | a block with this name. 346 | 347 | LAMBDA-LIST is the macro lambda-list. 348 | 349 | BODY is the list of forms comprising the macro body. 350 | 351 | ENVIRONMENT is the lexical environment in which the macro 352 | definition form is to be parsed. This is used to expand macros used 353 | in the macro definition. 354 | 355 | Returns a lambda expression of two arguments which is suitable for 356 | use as a macro function." 357 | 358 | (declare (ignore environment)) 359 | 360 | (let ((env-var (gensym "ENV"))) 361 | (flet ((walk-arg (type arg) 362 | (case type 363 | (:environment 364 | (setf env-var arg) 365 | nil) 366 | 367 | ((nil) 368 | (unless (eq arg '&environment) 369 | arg)) 370 | 371 | (otherwise arg)))) 372 | 373 | (let ((lambda-list (map-lambda-list #'walk-arg lambda-list :destructure t :env t))) 374 | (with-gensyms (name-var whole-var) 375 | `(lambda (,whole-var ,env-var) 376 | (declare (ignorable ,env-var)) 377 | (block ,name 378 | (destructuring-bind (,name-var ,@lambda-list) ,whole-var 379 | (declare (ignore ,name-var)) 380 | ,@body)))))))) 381 | 382 | (defun enclose (lambda-expression &optional env) 383 | "Compile a lambda expression in a given environment ENV." 384 | 385 | (si:eval-with-env lambda-expression env nil env)) 386 | 387 | (defun enclose-macro (name lambda-list body &optional env) 388 | "Compile a local macro definition in a given environment ENV." 389 | 390 | (enclose 391 | (parse-macro name lambda-list body env) 392 | env)) 393 | 394 | 395 | ;;; CL-ENVIRONMENT Utilities 396 | 397 | (defmacro in-environment ((env-var &optional (environment env-var)) (&rest bindings) &body forms) 398 | (flet ((make-binding (binding) 399 | (match binding 400 | ((type symbol) 401 | (list binding binding)) 402 | 403 | (_ binding)))) 404 | 405 | `(let ((,env-var ,environment) ,@(mapcar #'make-binding bindings)) 406 | ,@forms))) 407 | 408 | (defun augmented-macroexpand-1 (form &optional environment) 409 | (macroexpand-1 form environment)) 410 | 411 | (defun augmented-macroexpand (form &optional environment) 412 | (macroexpand form environment)) 413 | 414 | (defun augmented-macro-function (symbol &optional environment) 415 | (macro-function symbol environment)) 416 | 417 | (defun augmented-get-setf-expansion (form &optional environment) 418 | (get-setf-expansion form environment)) 419 | 420 | (defun augmented-compiler-macro-function (name &optional environment) 421 | (compiler-macro-function name environment)) 422 | 423 | (defun augmented-constantp (form &optional environment) 424 | (constantp form environment)) 425 | -------------------------------------------------------------------------------- /src/walker/lambda.lisp: -------------------------------------------------------------------------------- 1 | ;;;; lambda.lisp 2 | ;;;; 3 | ;;;; Copyright 2017 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :cl-environments.cltl2) 27 | 28 | 29 | (define-condition malformed-lambda-list (walk-program-error) 30 | ((list-position 31 | :reader list-position 32 | :initarg :position 33 | :documentation 34 | "The CONS cell of the lambda-list element for which the condition 35 | was signaled")) 36 | 37 | (:documentation 38 | "Condition signaled when a lambda-list with incorrect structure is 39 | walked.")) 40 | 41 | (defun lambda-walk-error (list) 42 | "Signals a `MALFORMED-LAMBDA-LIST' condition for the lambda list at 43 | position LIST. A SKIP-WALK restart is established which simply 44 | returns NIL." 45 | 46 | (restart-case 47 | (error 'malformed-lambda-list :position list) 48 | (skip-walk ()))) 49 | 50 | 51 | (defun lambda-list-keyword-p (sym) 52 | "Checks wether SYM names a lambda list keyword, i.e. checks whether 53 | SYM is a member of LAMBDA-LIST-KEYWORDS." 54 | 55 | (member sym lambda-list-keywords)) 56 | 57 | (defun var-symbol-p (thing) 58 | "Returns true if THING is a symbol which can be used as a 59 | variable-name." 60 | 61 | (and thing (symbolp thing) (not (keywordp thing)) (lambda-list-keyword-p thing))) 62 | 63 | 64 | ;; TODO: Does not raise an error when there are two &allow-other-key 65 | ;; in succession, add error checking for this case. 66 | (defun map-lambda-list (fn list &key ((:destructure destructurep)) ((:env envp))) 67 | "Applies FN on each element of the lambda list LIST, the result 68 | returned by FN are accumulated into a new list, which is returned 69 | from the function. FN is called with two arguments: the type of 70 | argument and the argument itself. The type can be either: :REQUIRED 71 | for required arguments, :OPTIONAL for optional arguments, :REST for 72 | rest arguments, :KEY for keyword arguments, :AUX for auxiliary 73 | variables, :WHOLE for whole destructuring arguments, :ENVIRONMENT 74 | for environment arguments or NIL for the lambda-list keywords 75 | themselves. If FN returns NIL for a particular element, that 76 | element is not inserted into the resulting lambda 77 | list. If :DESTRUCTURE is true then lambda-list is parsed as a 78 | destructuring lambda list, if :ENV is true then &ENVIRONMENT 79 | parameters are allowed. If a syntax error is encountered in the 80 | lambda-list (incorrect position of lambda-list keywords) a 81 | `MALFORMED-LAMBDA-LIST' condition is signaled with a SKIP-WALK 82 | restart, which simply resumes processing as though the lambda list 83 | keyword appeared in the correct position. The arguments themselves 84 | are not checked for correct syntax, it is the responsibility of FN 85 | to do so." 86 | 87 | (declare (special envp)) 88 | 89 | (let* (new-list 90 | (collector (make-simple-collector-to-place new-list))) 91 | (declare (special collector)) 92 | 93 | (labels 94 | ((map-collect (state thing) 95 | (awhen (funcall fn state thing) 96 | (funcall collector it))) 97 | 98 | (collect (state &rest things) 99 | (mapc (curry #'map-collect state) things)) 100 | 101 | (guard (condition list) 102 | (unless condition 103 | (lambda-walk-error list))) 104 | 105 | (consume-arg (state list) 106 | (match list 107 | ((list* (guard arg (not (lambda-list-keyword-p arg))) rest) 108 | (collect state arg) 109 | rest) 110 | 111 | (_ 112 | (lambda-walk-error list) 113 | list)))) 114 | 115 | (match-state list 116 | (:whole 117 | (and (cons '&whole rest) list) 118 | 119 | (guard (and destructurep (eq from-state :start)) list) 120 | (collect nil '&whole) 121 | 122 | (next (consume-arg :whole rest) :from :required)) 123 | 124 | (:optional 125 | (and (cons '&optional rest) list) 126 | 127 | (guard (member from-state '(:start :required)) list) 128 | (collect nil '&optional) 129 | 130 | (next rest)) 131 | 132 | (:rest 133 | (guard 134 | (and (list* (and (or '&rest '&body) keyword) 135 | (and (type list) var-list) 136 | rest) 137 | list) 138 | destructurep) 139 | 140 | (guard (member from-state '(:start :required :optional)) list) 141 | 142 | (collect nil keyword) 143 | 144 | (let (new-list) 145 | (let ((collector (make-simple-collector-to-place new-list)) 146 | (envp nil)) 147 | (declare (special collector envp)) 148 | (next var-list :from :start)) 149 | (funcall collector new-list)) 150 | 151 | (next rest)) 152 | 153 | (:rest 154 | (and (cons (and (or '&rest '&body) keyword) rest) list) 155 | 156 | (guard (and (or (eq keyword '&rest) destructurep) 157 | (member from-state '(:start :required :optional))) list) 158 | 159 | (collect nil keyword) 160 | (next (consume-arg :rest rest))) 161 | 162 | (:key 163 | (and (cons '&key rest) list) 164 | 165 | (guard (member from-state '(:start :required :optional :rest)) list) 166 | (collect nil '&key) 167 | 168 | (next rest)) 169 | 170 | (:allow-other-keys 171 | (and (cons '&allow-other-keys rest) list) 172 | 173 | (guard (eq from-state :key) list) 174 | (collect nil '&allow-other-keys) 175 | 176 | (next rest :from :key :force t)) 177 | 178 | (:aux 179 | (cons '&aux rest) 180 | 181 | (collect nil '&aux) 182 | (next rest)) 183 | 184 | (:environment 185 | (and (cons '&environment rest) list) 186 | 187 | (guard envp list) 188 | (setf envp nil) 189 | 190 | (collect nil '&environment) 191 | (next (consume-arg :environment rest) :from from-state :force t)) 192 | 193 | ;; Argument states 194 | 195 | (:required 196 | (guard (cons (guard var-list (listp var-list)) rest) destructurep) 197 | :from (:start :required) 198 | 199 | (let (new-list) 200 | (let ((collector (make-simple-collector-to-place new-list)) 201 | (envp nil)) 202 | (declare (special collector envp)) 203 | (next var-list :from :start)) 204 | (funcall collector new-list)) 205 | 206 | (next rest)) 207 | 208 | (:required 209 | (cons var rest) 210 | :from (:start :required) 211 | 212 | (collect :required var) 213 | (next rest)) 214 | 215 | (arg 216 | (cons var rest) 217 | :from (:optional :key :aux) 218 | 219 | (collect from-state var) 220 | (next rest :from from-state)) 221 | 222 | (end-of-list nil) 223 | 224 | (dotted-list 225 | (guard var (atom var)) 226 | 227 | (guard (and destructurep (member from-state '(:required :optional))) var) 228 | 229 | (awhen (funcall fn :rest var) 230 | (nconc new-list it))) 231 | 232 | (else 233 | rest 234 | (lambda-walk-error rest) 235 | (nconc new-list rest))) 236 | 237 | new-list))) 238 | 239 | (defun walk-lambda-list (list env &key ((:destructure destructurep)) ((:env envp))) 240 | "Walks the lambda list LIST, augments the environment ENV with the 241 | bindings introduced by the lambda list, and encloses the initforms 242 | of the arguments in the environments augmented with all the 243 | bindings introduced in the lambda-list preceding it. Returns the 244 | new lambda list and the augmented environment. The keyword 245 | argument :DESTRUCTURE indicates whether the lambda list should be 246 | parsed as a destructuring lambda list, and :ENV indicates whether 247 | &ENVIRONMENT parameters are accepted." 248 | 249 | (let ((env (copy-environment env))) 250 | (labels ((walk-arg (type arg) 251 | "Walks lambda-list arguments. TYPE is a keyword 252 | identifying the type of argument, ARG is the 253 | argument." 254 | 255 | (multiple-value-bind (arg new-env) 256 | (case type 257 | (:optional (walk-optional arg)) 258 | (:key (walk-key arg)) 259 | (:aux (walk-aux arg)) 260 | (nil (values arg env)) 261 | (otherwise 262 | (add-variable arg env) 263 | (values arg env))) 264 | (setf env new-env) 265 | arg)) 266 | 267 | (walk-optional (arg) 268 | "Walks optional arguments. Encloses the init-form (if 269 | any) in the environment ENV and augments ENV with 270 | bindings for the argument and supplied-p variable (if 271 | any)." 272 | 273 | (match (ensure-list arg) 274 | ((cons var (optional (cons initform (and rest (optional (list var-sp)))))) 275 | (values 276 | `(,var ,(enclose-in-env env (list initform)) ,@rest) 277 | (aprog1 (copy-environment env) 278 | (add-variable var it) 279 | (when var-sp (add-variable var-sp it))))))) 280 | 281 | (walk-key (arg) 282 | "Walks keyword arguments. Encloses the init-form (if 283 | any) in the environment ENV and augments ENV with 284 | bindings for the argument and supplied-p variable (if 285 | any)." 286 | 287 | (match (ensure-list arg) 288 | ((cons 289 | (and (or (list _ var) var) arg) 290 | (optional (cons initform (and rest (optional (list var-sp)))))) 291 | 292 | (values 293 | `(,arg ,(enclose-in-env env (list initform)) ,@rest) 294 | (aprog1 (copy-environment env) 295 | (add-variable var it) 296 | (when var-sp (add-variable var-sp it))))))) 297 | 298 | (walk-aux (arg) 299 | "Walks auxiliary variables. Encloses the init-form (if 300 | any) in the environment ENV and augments ENV with a 301 | binding for the variable." 302 | 303 | (match (ensure-list arg) 304 | ((cons var (optional (list initform))) 305 | 306 | (values 307 | `(,var ,(enclose-in-env env (list initform))) 308 | (aprog1 (copy-environment env) 309 | (add-variable var it))))))) 310 | 311 | (handler-bind 312 | ((malformed-lambda-list #'skip-walk)) 313 | (values 314 | (map-lambda-list #'walk-arg list 315 | :destructure destructurep 316 | :env envp) 317 | env))))) 318 | 319 | (defun walk-generic-lambda-list (list env) 320 | "Walks the generic function lambda list LIST, augments the 321 | environment ENV with the bindings introduced by the lambda list, 322 | and encloses the initforms of the arguments in the environments 323 | augmented with all the bindings introduced in the lambda-list 324 | preceding it. Returns the new lambda list and the augmented 325 | environment. 326 | 327 | The augmented environment additionally contains type declarations 328 | for type specialized arguments." 329 | 330 | (let ((env (copy-environment env))) 331 | (labels ((walk-arg (type arg) 332 | "Walks lambda-list arguments. TYPE is a keyword 333 | identifying the type of argument, ARG is the 334 | argument." 335 | 336 | (multiple-value-bind (arg new-env) 337 | (case type 338 | (:required (walk-required arg)) 339 | (:optional (walk-optional arg)) 340 | (:key (walk-key arg)) 341 | (:aux (walk-aux arg)) 342 | (nil (values arg env)) 343 | (otherwise 344 | (add-variable arg env) 345 | (values arg env))) 346 | (setf env new-env) 347 | arg)) 348 | 349 | (walk-required (arg) 350 | "Walks required arguments. Augments the environment 351 | with a binding for the argument. If the argument has a 352 | type specializer, a TYPE declaration is added to the 353 | binding's information list." 354 | 355 | (match arg 356 | ((or (list var (list 'eql _)) 357 | (list var type) 358 | var) 359 | 360 | (add-variable var env) 361 | (when type 362 | (add-variable-info var 'type type env)) 363 | 364 | (values arg env)))) 365 | 366 | (walk-optional (arg) 367 | "Walks optional arguments. Encloses the init-form (if 368 | any) in the environment ENV and augments ENV with 369 | bindings for the argument and supplied-p variable (if 370 | any)." 371 | 372 | (match (ensure-list arg) 373 | ((cons var (optional (cons initform (and rest (optional (list var-sp)))))) 374 | (values 375 | `(,var ,(enclose-in-env env (list initform)) ,@rest) 376 | (aprog1 (copy-environment env) 377 | (add-variable var it) 378 | (when var-sp (add-variable var-sp it))))))) 379 | 380 | (walk-key (arg) 381 | "Walks keyword arguments. Encloses the init-form (if 382 | any) in the environment ENV and augments ENV with 383 | bindings for the argument and supplied-p variable (if 384 | any)." 385 | 386 | (match (ensure-list arg) 387 | ((cons 388 | (and (or (list _ var) var) arg) 389 | (optional (cons initform (and rest (optional (list var-sp)))))) 390 | 391 | (values 392 | `(,arg ,(enclose-in-env env (list initform)) ,@rest) 393 | (aprog1 (copy-environment env) 394 | (add-variable var it) 395 | (when var-sp (add-variable var-sp it))))))) 396 | 397 | (walk-aux (arg) 398 | "Walks auxiliary variables. Encloses the init-form (if 399 | any) in the environment ENV and augments ENV with a 400 | binding for the variable." 401 | 402 | (match (ensure-list arg) 403 | ((cons var (optional (list initform))) 404 | 405 | (values 406 | `(,var ,(enclose-in-env env (list initform))) 407 | (aprog1 (copy-environment env) 408 | (add-variable var it))))))) 409 | 410 | (handler-bind 411 | ((malformed-lambda-list #'skip-walk)) 412 | (values 413 | (map-lambda-list #'walk-arg list) 414 | env))))) 415 | -------------------------------------------------------------------------------- /src/walker/augment-environment.lisp: -------------------------------------------------------------------------------- 1 | ;;;; augment-environment.lisp 2 | ;;;; 3 | ;;;; Copyright 2021 Alexander Gutev 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person 6 | ;;;; obtaining a copy of this software and associated documentation 7 | ;;;; files (the "Software"), to deal in the Software without 8 | ;;;; restriction, including without limitation the rights to use, 9 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | ;;;; copies of the Software, and to permit persons to whom the 11 | ;;;; Software is furnished to do so, subject to the following 12 | ;;;; conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 21 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 22 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | ;;;; Implements the AUGMENT-ENVIRONMENT function and the 27 | ;;;; macro-expanding functions for augmented environments. 28 | 29 | (in-package :cl-environments.cltl2) 30 | 31 | 32 | ;;; Augmented Environment 33 | 34 | (defclass augmented-environment (environment) 35 | ((base-environment 36 | :initarg :base-environment 37 | :accessor base-environment 38 | :documentation 39 | "The base environment which this environment is augmenting.") 40 | 41 | (macro-functions 42 | :initform (make-hash-table :test #'equal) 43 | :initarg :macro-functions 44 | :accessor macro-functions 45 | :documentation 46 | "Hash table mapping macro names to the corresponding macro 47 | functions.") 48 | 49 | (symbol-macros 50 | :initform (make-hash-table :test #'eq) 51 | :initarg :symbol-macros 52 | :accessor symbol-macros 53 | :documentation 54 | "Hash table mapping symbol-macro names to the corresponding 55 | symbol-macro expansion.")) 56 | 57 | (:documentation 58 | "Extended environment with macro and symbol macro definitions added 59 | by AUGMENT-ENVIRONMENT.")) 60 | 61 | (defun copy-augmented-environment (environment) 62 | (let ((copy (copy-environment environment))) 63 | (change-class copy 'augmented-environment 64 | :base-environment (base-environment environment) 65 | :macro-functions (copy-hash-table (macro-functions environment)) 66 | :symbol-macros (copy-hash-table (symbol-macros environment))))) 67 | 68 | (defun eval-in-augmented-env (env env-var form) 69 | "Evaluate a form in a lexical environment constructed from an `AUGMENTED-ENVIRONMENT' 70 | 71 | FORM is evaluated in an environment containing the macros and 72 | symbol macros added to ENV, as well the macros and symbol-macros in 73 | the BASE-ENVIRONMENT which ENV augments. 74 | 75 | ENV is the `AUGMENTED-ENVIRONMENT' from which to construct the 76 | lexical environment in which FORM is evaluated. 77 | 78 | ENV-VAR is the name of the variable to which the lexical 79 | environment is bound. 80 | 81 | FORM if the form to evaluate in the lexical environment." 82 | 83 | (labels ((make-macros (macros) 84 | (iter (for (macro macro-fn) in-hashtable macros) 85 | (collect (make-local-macro macro macro-fn)))) 86 | 87 | (make-symbol-macros (symbol-macros) 88 | (iter (for (sym expansion) in-hashtable symbol-macros) 89 | (collect (make-symbol-macro sym expansion)))) 90 | 91 | (make-local-macro (name fn) 92 | (with-gensyms (whole rest env) 93 | `(,name (&whole ,whole &rest ,rest &environment ,env) 94 | (declare (ignore ,rest)) 95 | (funcall ,fn ,whole ,env)))) 96 | 97 | (make-symbol-macro (name expansion) 98 | `(,name ,expansion)) 99 | 100 | (make-dummy-function (name) 101 | `(,name () nil)) 102 | 103 | (macro-bindings (functions env) 104 | (iter 105 | (for (sym binding) in-hashtable functions) 106 | (when (and (local binding) (eq (binding-type binding) :macro)) 107 | (when-let (fn (macro-function sym env)) 108 | (collect (cons sym fn)))))) 109 | 110 | (function-bindings (functions) 111 | (iter 112 | (for (sym binding) in-hashtable functions) 113 | (when (and (local binding) (eq (binding-type binding) :function)) 114 | (collect sym)))) 115 | 116 | (symbol-macro-bindings (symbol-macros env) 117 | (iter 118 | (for (sym binding) in-hashtable symbol-macros) 119 | (when (and (local binding) (eq (binding-type binding) :symbol-macro)) 120 | (multiple-value-bind (expansion expanded-p) 121 | (macroexpand-1 sym env) 122 | 123 | (when expanded-p 124 | (collect (list sym expansion))))))) 125 | 126 | (variable-bindings (variables) 127 | (iter 128 | (for (sym binding) in-hashtable variables) 129 | (when (and (local binding) 130 | (member (binding-type binding) '(:lexical :special))) 131 | (collect sym))))) 132 | 133 | (with-slots (functions variables macro-functions symbol-macros base-environment) env 134 | (let ((macros (macro-bindings functions base-environment)) 135 | (symbol-macro-expansions (symbol-macro-bindings variables base-environment)) 136 | (local-fns (function-bindings functions))) 137 | 138 | (with-gensyms (expand) 139 | (values-list 140 | (eval 141 | (enclose-in-env 142 | env 143 | 144 | `((flet ,(mapcar #'make-dummy-function local-fns) 145 | (macrolet ,(mapcar 146 | (lambda (mac) (make-local-macro (car mac) (cdr mac))) 147 | macros) 148 | 149 | (let ,(variable-bindings variables) 150 | (symbol-macrolet ,symbol-macro-expansions 151 | 152 | ;; Augmented Macros and Symbol-Macros 153 | (macrolet ,(make-macros macro-functions) 154 | (symbol-macrolet ,(make-symbol-macros symbol-macros) 155 | (macrolet ((,expand (&environment ,env-var) 156 | `',(multiple-value-list ,form))) 157 | 158 | (,expand))))))))) 159 | 160 | :walk-forms nil)))))))) 161 | 162 | (defmacro with-augmented-environment (environment (env-var) &body forms) 163 | `(eval-in-augmented-env ,environment ',env-var '(progn ,@forms))) 164 | 165 | (defmacro in-environment ((env-var &optional (environment env-var)) (&rest bindings) &body forms) 166 | "Evaluate FORMS with access to a given environment. 167 | 168 | ENV-VAR is the name of the variable to which the native environment 169 | object is bound. This binding is made available to forms. 170 | 171 | If ENVIRONMENT evaluates to an augmented environment object, FORMS 172 | are evaluated in an environment in which ENV-VAR is bound to a 173 | native lexical environment object which is equivalent to the 174 | augmented environment. Otherwise ENV-VAR is bound to 175 | ENVIRONMENT. If ENVIRONMENT is not given, the variable with name 176 | given by ENV-VAR is evaluated in the current environment, to obtain 177 | the environment object, and then a binding to the native 178 | environment object is made under the same variable in the 179 | environment in which FORMS are evaluated. 180 | 181 | ENVIRONMENT is a form which evaluates to an environment object, 182 | which may be either a native environment or an augmented 183 | environment object. 184 | 185 | BINDINGS is a list of bindings which will be made available to 186 | FORMS. Each element of is a list of the form (NAME INITFORM) where 187 | NAME is the name of the variable which will be available to FORMS 188 | and INITFORM is the form to which it is bound. INITFORM is 189 | evaluated in the environment in which this macro-form is found. A 190 | binding may be a symbol by itself in which case it is a short-form 191 | for (NAME NAME). 192 | 193 | FORMS is the list of forms which are evaluated, in an implicit 194 | PROGN. The binding to the variable name given by ENV-VAR and the 195 | bindings specified in BINDINGS are available to the forms. The 196 | forms may be executed in a dynamically created environment and thus 197 | they do not have access to any lexical variable, function and macro 198 | definitions in the environment of the macro form." 199 | 200 | (flet ((make-binding (var) 201 | (ematch var 202 | ((type symbol) 203 | ``(,',var ',,var)) 204 | 205 | ((list (and (type symbol) name) initform) 206 | ``(,',name ',,initform)))) 207 | 208 | (make-let-binding (var) 209 | (ematch var 210 | ((type symbol) 211 | (list var var)) 212 | 213 | ((list (and (type symbol) name) initform) 214 | (list name initform))))) 215 | 216 | (with-gensyms (env) 217 | `(let ((,env ,environment)) 218 | (typecase ,env 219 | (augmented-environment 220 | (eval-in-augmented-env 221 | ,env 222 | ',env-var 223 | `(let ,(list ,@(mapcar #'make-binding bindings)) ,@',forms))) 224 | 225 | (otherwise 226 | (let ((,env-var ,env) ,@(mapcar #'make-let-binding bindings)) ,@forms))))))) 227 | 228 | 229 | ;;; Definition of AUGMENT-ENVIRONMENT 230 | 231 | (defun augment-environment (env &key variable symbol-macro function macro declare) 232 | "Create a new environment by augmenting an existing environment with new information. 233 | 234 | ENV is the existing environment to augment which may be an 235 | implementation specific lexical environment or an 236 | AUGMENTED-ENVIRONMENT. This environment can be used as the 237 | environment parameter to the AUGMENTED-MACROEXPAND and 238 | AUGMENTED-MACROEXPAND-1 functions. 239 | 240 | VARIABLE is a list of symbols that will be bound as variables in 241 | the new environment. 242 | 243 | SYMBOL-MACRO is a list of symbol-macro definitions, each of the 244 | form (NAME DEFINITION). 245 | 246 | FUNCTION is a list of symbols that will be bound as local functions 247 | in the environment. 248 | 249 | MACRO is a list of macro definitions, each of the form (NAME 250 | MACRO-FUNCTION), where MACRO-FUNCTION is a function of two 251 | arguments, the entire macro form and the implementation specific 252 | lexical environment in which it is expanded. 253 | 254 | DECLARE is a list of declaration specifiers, in the same format as 255 | DECLARE expressions. Information about these declarations can be 256 | retrieved using VARIABLE-INFORMATION, FUNCTION-INFORMATION and 257 | DECLARATION-INFORMATION." 258 | 259 | (let ((aug-env (make-augmented-environment env))) 260 | (with-slots (macro-functions symbol-macros) aug-env 261 | (flet ((add-macro (macro) 262 | (add-function (first macro) aug-env :binding-type :macro)) 263 | 264 | (add-variable (variable) 265 | (add-variable variable aug-env)) 266 | 267 | (add-symbol-macro (macro) 268 | (add-symbol-macro (first macro) aug-env)) 269 | 270 | (add-function (function) 271 | (add-function function aug-env)) 272 | 273 | (add-declaration (decl) 274 | (destructuring-bind (decl . args) decl 275 | (walk-declaration decl args aug-env))) 276 | 277 | (add-macro-function (macro) 278 | (destructuring-bind (name fn) macro 279 | (setf (gethash name macro-functions) fn))) 280 | 281 | (add-symbol-macro-expansion (macro) 282 | (destructuring-bind (name expansion) macro 283 | (setf (gethash name symbol-macros) expansion)))) 284 | 285 | (mapc #'add-variable variable) 286 | (mapc #'add-symbol-macro symbol-macro) 287 | (mapc #'add-function function) 288 | (mapc #'add-macro macro) 289 | (mapc #'add-declaration declare) 290 | 291 | (mapc #'add-macro-function macro) 292 | (mapc #'add-symbol-macro-expansion symbol-macro) 293 | 294 | aug-env)))) 295 | 296 | (defun make-augmented-environment (environment) 297 | "Make an `AUGMENTED-ENVIRONMENT' based on ENVIRONMENT, which may be 298 | either a lexical environment or another `AUGMENTED-ENVIRONMENT'." 299 | 300 | (typecase environment 301 | (augmented-environment 302 | (copy-augmented-environment environment)) 303 | 304 | (otherwise 305 | (let ((env (copy-environment (get-environment environment)))) 306 | (change-class env 'augmented-environment 307 | :base-environment environment))))) 308 | 309 | (defun augmented-macroexpand-1 (form &optional environment) 310 | "Expands a macro form, like CL:MACROEXPAND-1, in a given lexical or augmented environment. 311 | 312 | FORM is the form to macroexpand. 313 | 314 | ENVIRONMENT is the environment in which to expand FORM, which may 315 | be either an implementation specific lexical environment or an 316 | augmented environment returned by AUGMENT-ENVIRONMENT. If NIL 317 | defaults to the global environment." 318 | 319 | (in-environment (environment) 320 | (form) 321 | 322 | (macroexpand-1 form environment))) 323 | 324 | (defun augmented-macroexpand (form &optional environment) 325 | "Expands a macro form, like CL:MACROEXPAND, in a given lexical or augmented environment. 326 | 327 | FORM is the form to macroexpand. 328 | 329 | ENVIRONMENT is the environment in which to expand FORM, which may 330 | be either an implementation specific lexical environment or an 331 | augmented environment returned by AUGMENT-ENVIRONMENT. If NIL 332 | defaults to the global environment." 333 | 334 | (in-environment (environment) 335 | (form) 336 | 337 | (macroexpand form environment))) 338 | 339 | (defun augmented-macro-function (symbol &optional environment) 340 | "Retrieve the macro function for a symbol. 341 | 342 | SYMBOL the symbol for which the macro function is retrieved. 343 | 344 | ENVIRONMENT is the lexical environment which is searched for the 345 | macro definition. If NIL defaults to the global environment. 346 | 347 | If SYMBOL does not name a symbol in ENVIRONMENT, returns NIL." 348 | 349 | (typecase environment 350 | (augmented-environment 351 | (get-augmented-macro-function symbol environment)) 352 | 353 | (otherwise 354 | (macro-function symbol environment)))) 355 | 356 | (defun get-augmented-macro-function (symbol environment) 357 | "Retrieve the macro function for a symbol in an `AUGMENTED-ENVIRONMENT'. 358 | 359 | If SYMBOL does not name a macro added to the augmented environment, 360 | the BASE-ENVIRONMENT of the augmented environment is searched. 361 | 362 | SYMBOL is the symbol naming the macro. 363 | 364 | ENVIRONMENT is the `AUGMENTED-ENVIRONMENT' object." 365 | 366 | 367 | (with-slots (macro-functions functions base-environment) 368 | environment 369 | 370 | (when-let (binding (gethash symbol functions)) 371 | (case (binding-type binding) 372 | (:macro 373 | (gethash symbol macro-functions)) 374 | 375 | (:function nil) 376 | 377 | (otherwise 378 | (macro-function symbol base-environment)))))) 379 | 380 | (defun augmented-get-setf-expansion (place &optional environment) 381 | "Determine the SETF expansion for PLACE in ENVIRONMENT." 382 | 383 | (in-environment (environment) 384 | (place) 385 | 386 | (get-setf-expansion place environment))) 387 | 388 | (defun augmented-compiler-macro-function (name &optional environment) 389 | "Return the compiler-macro-function for function NAME in ENVIRONMENT." 390 | 391 | (in-environment (environment) 392 | (name) 393 | 394 | (compiler-macro-function name environment))) 395 | 396 | (defun augmented-constantp (form &optional environment) 397 | "Determine if FORM is a constant form in ENVIRONMENT." 398 | 399 | (in-environment (environment) 400 | (form) 401 | 402 | (constantp form environment))) 403 | 404 | 405 | ;;; Definition of ENCLOSE and ENCLOSE-MACRO 406 | 407 | (defun enclose (lambda-expression &optional environment) 408 | "Return a function object that is equivalent to what would be 409 | obtained by evaluating `(FUNCTION ,LAMBDA-EXPRESSION) in the 410 | environment ENVIRONMENT." 411 | 412 | (typecase environment 413 | (augmented-environment 414 | (with-gensyms (env-var) 415 | (eval-in-augmented-env 416 | environment 417 | env-var 418 | `(function ,lambda-expression)))) 419 | 420 | (null (compile nil lambda-expression)) 421 | 422 | (otherwise 423 | (enclose lambda-expression (augment-environment environment))))) 424 | 425 | (defun parse-macro (name lambda-list body &optional environment) 426 | "Parse a macro definition form (as found in MACROLET or DEFMACRO). 427 | 428 | NAME is the name of the macro. The body of the macro is enclosed in 429 | a block with this name. 430 | 431 | LAMBDA-LIST is the macro lambda-list. 432 | 433 | BODY is the list of forms comprising the macro body. 434 | 435 | ENVIRONMENT is the lexical environment in which the macro 436 | definition form is to be parsed. This is used to expand macros used 437 | in the macro definition. 438 | 439 | Returns a lambda expression of two arguments which is suitable for 440 | use as a macro function." 441 | 442 | (declare (ignore environment)) 443 | 444 | (let ((env-var (gensym "ENV"))) 445 | (flet ((walk-arg (type arg) 446 | (case type 447 | (:environment 448 | (setf env-var arg) 449 | nil) 450 | 451 | ((nil) 452 | (unless (eq arg '&environment) 453 | arg)) 454 | 455 | (otherwise arg)))) 456 | 457 | (let ((lambda-list (map-lambda-list #'walk-arg lambda-list :destructure t :env t))) 458 | (with-gensyms (name-var whole-var) 459 | `(lambda (,whole-var ,env-var) 460 | (declare (ignorable ,env-var)) 461 | (block ,name 462 | (destructuring-bind (,name-var ,@lambda-list) ,whole-var 463 | (declare (ignore ,name-var)) 464 | ,@body)))))))) 465 | 466 | (defun enclose-macro (name lambda-list body &optional environment) 467 | "Parse a macro definition form (as found in MACROLET or DEFMACRO) into a macro function. 468 | 469 | NAME is the name of the macro. The body of the macro is enclosed in 470 | a block with this name. 471 | 472 | LAMBDA-LIST is the macro lambda-list. 473 | 474 | BODY is the list of forms comprising the macro body. 475 | 476 | ENVIRONMENT is the lexical environment in which the macro 477 | definition form is to be parsed. This is used to expand macros used 478 | in the macro definition. 479 | 480 | Returns a function object which is suitable as a macro-function 481 | passed in the :MACRO argument of AUGMENT-ENVIRONMENT." 482 | 483 | (enclose 484 | (parse-macro name lambda-list body environment) 485 | environment)) 486 | --------------------------------------------------------------------------------