├── test ├── fe.lisp ├── fe2.lisp ├── runall.lisp ├── ecl-runall ├── ccl-runall ├── sbcl-runall ├── abcl-runall ├── cmu-runall ├── ccl-runall.lisp ├── clisp-runall ├── test-print.lisp ├── acl-runall ├── mcl-runall.lisp ├── partial-initargs.lisp ├── special-slots-1.lisp ├── special-slots-2.lisp ├── special-slots-3.lisp ├── fibonacci-test.lisp ├── grouped-layers.lisp ├── figure-editor-2.lisp ├── figure-editor.lisp ├── runall ├── dynamic-wind.lisp ├── layer-gc.lisp ├── spx.lisp ├── demo3.lisp └── dynenv.lisp ├── dynamic-wind.asd ├── LICENSE.md ├── dynamic-wind-packages.lisp ├── cx-class-in-layer.lisp ├── contextl.asd ├── cx-dynamic-environments.lisp ├── cx-singleton-class.lisp ├── cx-layered-function.lisp ├── cx-layered-class.lisp ├── cx-util.lisp ├── cx-partial-class.lisp ├── cx-threads.lisp ├── contextl-packages.lisp ├── cx-gc.lisp ├── README.md ├── cx-layer-metaclasses.lisp ├── cx-layered-function-macros.lisp ├── cx-dynascope.lisp ├── cx-dynamic-variables.lisp ├── cx-layered-access-class.lisp ├── cx-layer.lisp └── cx-special-class.lisp /test/fe.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | (compile-file "figure-editor.lisp") 3 | (load "figure-editor") 4 | (in-package :contextl-user) 5 | (run-test) 6 | -------------------------------------------------------------------------------- /test/fe2.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | (compile-file "figure-editor-2.lisp") 3 | (load "figure-editor-2") 4 | (in-package :contextl-user) 5 | (run-test-2) 6 | -------------------------------------------------------------------------------- /test/runall.lisp: -------------------------------------------------------------------------------- 1 | (load "demo3.lisp") 2 | (load "spx.lisp") 3 | (load "grouped-layers.lisp") 4 | (load "fe.lisp") 5 | (load "fe2.lisp") 6 | (load "special-slots-1.lisp") 7 | (load "special-slots-2.lisp") 8 | (load "special-slots-3.lisp") 9 | (load "layer-gc.lisp") 10 | (load "dynenv.lisp") 11 | (load "partial-initargs.lisp") 12 | -------------------------------------------------------------------------------- /test/ecl-runall: -------------------------------------------------------------------------------- 1 | ecl -debug -shell demo3.lisp 2 | ecl -debug -shell spx.lisp 3 | ecl -debug -shell grouped-layers.lisp 4 | ecl -debug -shell fe.lisp 5 | ecl -debug -shell fe2.lisp 6 | ecl -debug -shell special-slots-1.lisp 7 | ecl -debug -shell special-slots-2.lisp 8 | ecl -debug -shell special-slots-3.lisp 9 | ecl -debug -shell layer-gc.lisp 10 | ecl -debug -shell dynenv.lisp 11 | ecl -debug -shell partial-initargs.lisp 12 | -------------------------------------------------------------------------------- /test/ccl-runall: -------------------------------------------------------------------------------- 1 | ccl -l demo3.lisp -e '(quit)' 2 | ccl -l spx.lisp -e '(quit)' 3 | ccl -l grouped-layers.lisp -e '(quit)' 4 | ccl -l fe.lisp -e '(quit)' 5 | ccl -l fe2.lisp -e '(quit)' 6 | ccl -l special-slots-1.lisp -e '(quit)' 7 | ccl -l special-slots-2.lisp -e '(quit)' 8 | ccl -l special-slots-3.lisp -e '(quit)' 9 | ccl -l layer-gc.lisp -e '(quit)' 10 | ccl -l dynenv.lisp -e '(quit)' 11 | ccl -l partial-initargs.lisp -e '(quit)' 12 | -------------------------------------------------------------------------------- /test/sbcl-runall: -------------------------------------------------------------------------------- 1 | sbcl --load demo3.lisp --quit 2 | sbcl --load spx.lisp --quit 3 | sbcl --load grouped-layers.lisp --quit 4 | sbcl --load fe.lisp --quit 5 | sbcl --load fe2.lisp --quit 6 | sbcl --load special-slots-1.lisp --quit 7 | sbcl --load special-slots-2.lisp --quit 8 | sbcl --load special-slots-3.lisp --quit 9 | sbcl --load layer-gc.lisp --quit 10 | sbcl --load dynenv.lisp --quit 11 | sbcl --load partial-initargs.lisp --quit 12 | -------------------------------------------------------------------------------- /test/abcl-runall: -------------------------------------------------------------------------------- 1 | abcl --load demo3.lisp --batch 2 | abcl --load spx.lisp --batch 3 | abcl --load grouped-layers.lisp --batch 4 | abcl --load fe.lisp --batch 5 | abcl --load fe2.lisp --batch 6 | abcl --load special-slots-1.lisp --batch 7 | abcl --load special-slots-2.lisp --batch 8 | abcl --load special-slots-3.lisp --batch 9 | abcl --load layer-gc.lisp --batch 10 | abcl --load dynenv.lisp --batch 11 | abcl --load partial-initargs.lisp --batch 12 | -------------------------------------------------------------------------------- /test/cmu-runall: -------------------------------------------------------------------------------- 1 | lisp -load demo3.lisp -eval '(quit)' 2 | lisp -load spx.lisp -eval '(quit)' 3 | lisp -load grouped-layers.lisp -eval '(quit)' 4 | lisp -load fe.lisp -eval '(quit)' 5 | lisp -load fe2.lisp -eval '(quit)' 6 | lisp -load special-slots-1.lisp -eval '(quit)' 7 | lisp -load special-slots-2.lisp -eval '(quit)' 8 | lisp -load special-slots-3.lisp -eval '(quit)' 9 | lisp -load layer-gc.lisp -eval '(quit)' 10 | lisp -load dynenv.lisp -eval '(quit)' 11 | lisp -load partial-initargs.lisp -eval '(quit)' 12 | -------------------------------------------------------------------------------- /test/ccl-runall.lisp: -------------------------------------------------------------------------------- 1 | (load "/Users/costanza/lisp/closer/contextl/test/demo3") (load "/Users/costanza/lisp/closer/contextl/test/spx") (load "/Users/costanza/lisp/closer/contextl/test/grouped-layers") (load "/Users/costanza/lisp/closer/contextl/test/special-slots-1") (load "/Users/costanza/lisp/closer/contextl/test/special-slots-2") (load "/Users/costanza/lisp/closer/contextl/test/special-slots-3") (load "/Users/costanza/lisp/closer/contextl/test/layer-gc") (load "/Users/costanza/lisp/closer/contextl/test/dynenv") ;; figure-editor and figure-editor-2 -------------------------------------------------------------------------------- /test/clisp-runall: -------------------------------------------------------------------------------- 1 | clisp -i ~/.clisprc.lisp -on-error debug demo3.lisp 2 | clisp -i ~/.clisprc.lisp -on-error debug spx.lisp 3 | clisp -i ~/.clisprc.lisp -on-error debug grouped-layers.lisp 4 | clisp -i ~/.clisprc.lisp -on-error debug fe.lisp 5 | clisp -i ~/.clisprc.lisp -on-error debug fe2.lisp 6 | clisp -i ~/.clisprc.lisp -on-error debug special-slots-1.lisp 7 | clisp -i ~/.clisprc.lisp -on-error debug special-slots-2.lisp 8 | clisp -i ~/.clisprc.lisp -on-error debug special-slots-3.lisp 9 | clisp -i ~/.clisprc.lisp -on-error debug layer-gc.lisp 10 | clisp -i ~/.clisprc.lisp -on-error debug dynenv.lisp 11 | clisp -i ~/.clisprc.lisp -on-error debug partial-initargs.lisp 12 | -------------------------------------------------------------------------------- /test/test-print.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | (in-package :contextl-user) 3 | 4 | (deflayer test-layer) 5 | (print (find-layer 'test-layer)) 6 | (print (find-layer-class 'test-layer)) 7 | 8 | (define-layered-class test-class () ()) 9 | (print (find-class 'test-class)) 10 | 11 | (define-layered-function test-function (a b c)) 12 | (print (layered-function-definer 'test-function)) 13 | 14 | (define-layered-method test-function ((a integer) (b cons) c) 15 | 42) 16 | 17 | (define-layered-method test-function :in test-layer :around ((a integer) (b cons) c) 18 | 4711) 19 | 20 | (pprint (generic-function-methods (layered-function-definer 'test-function))) 21 | 22 | (print :done) 23 | -------------------------------------------------------------------------------- /test/acl-runall: -------------------------------------------------------------------------------- 1 | acl --debug-startup -L ~/.clinit.cl -L demo3.lisp --kill 2 | acl --debug-startup -L ~/.clinit.cl -L spx.lisp --kill 3 | acl --debug-startup -L ~/.clinit.cl -L grouped-layers.lisp --kill 4 | acl --debug-startup -L ~/.clinit.cl -L fe.lisp --kill 5 | acl --debug-startup -L ~/.clinit.cl -L fe2.lisp --kill 6 | acl --debug-startup -L ~/.clinit.cl -L special-slots-1.lisp --kill 7 | acl --debug-startup -L ~/.clinit.cl -L special-slots-2.lisp --kill 8 | acl --debug-startup -L ~/.clinit.cl -L special-slots-3.lisp --kill 9 | acl --debug-startup -L ~/.clinit.cl -L layer-gc.lisp --kill 10 | acl --debug-startup -L ~/.clinit.cl -L dynenv.lisp --kill 11 | acl --debug-startup -L ~/.clinit.cl -L partial-initargs.lisp --kill 12 | -------------------------------------------------------------------------------- /dynamic-wind.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:dynamic-wind 2 | :name "dynamic-wind" 3 | :description "The dynamic-wind part of ContextL as a separate independent system definition." 4 | :author "Pascal Costanza" 5 | :version "1.0.0" 6 | :licence "MIT-style license" 7 | :depends-on (#-lispworks #:lw-compat) 8 | :components ((:file "dynamic-wind-packages") 9 | (:file "cx-threads" :depends-on ("dynamic-wind-packages")) 10 | (:file "cx-dynamic-environments" :depends-on ("dynamic-wind-packages")) 11 | (:file "cx-dynamic-variables" :depends-on ("dynamic-wind-packages" "cx-dynamic-environments" "cx-threads")) 12 | (:file "cx-dynascope" :depends-on ("dynamic-wind-packages" "cx-dynamic-variables")))) 13 | -------------------------------------------------------------------------------- /test/mcl-runall.lisp: -------------------------------------------------------------------------------- 1 | (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:demo3") (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:spx") (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:grouped-layers") (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:special-slots-1") (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:special-slots-2") (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:special-slots-3") (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:layer-gc") (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:dynenv") (load "Macintosh HD:Users:costanza:lisp:develop:closer:contextl:test:partial-initargs") ;; figure-editor and figure-editor-2 -------------------------------------------------------------------------------- /test/partial-initargs.lisp: -------------------------------------------------------------------------------- 1 | (asdf:load-system :contextl) 2 | 3 | (in-package :contextl-user) 4 | 5 | (defclass serializable-class (standard-class) 6 | ((database :initarg :database))) 7 | 8 | (defclass combined-class (layered-class serializable-class) 9 | ()) 10 | 11 | (defmethod validate-superclass ((class combined-class) (superclass standard-class)) 12 | t) 13 | 14 | (defmethod partial-class-base-initargs append ((class combined-class)) 15 | '(:database)) 16 | 17 | (defclass try () 18 | () 19 | (:metaclass combined-class) 20 | (:database . "mydb")) 21 | 22 | (finalize-inheritance (find-class 'try)) 23 | 24 | (assert (string= (slot-value (find-class 'try) 'database) "mydb")) 25 | 26 | (assert (loop for class in (rest (class-precedence-list (find-class 'try))) 27 | never (slot-exists-p class 'database))) 28 | 29 | (print :done) 30 | -------------------------------------------------------------------------------- /test/special-slots-1.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | 3 | (in-package :contextl-user) 4 | 5 | (define-layered-class person1 () 6 | ((name1 :initarg :name 7 | :accessor person-name1))) 8 | 9 | (defparameter *p* 10 | (make-instance 'person1 :name "Dr. Jekyll")) 11 | 12 | (assert (equal (person-name1 *p*) "Dr. Jekyll")) 13 | 14 | (symbol-macrolet ((safe-special-symbol-progv t)) 15 | (handler-bind 16 | ((error (lambda (error) 17 | (eval '(define-layered-class person1 () 18 | ((name1 :initarg :name 19 | :special t 20 | :accessor person-name1)))) 21 | (assert (equal (person-name1 *p*) "Dr. Jekyll")) 22 | (continue error)))) 23 | (dletf (((person-name1 *p*) "Mr. Hide")) 24 | (assert (equal (person-name1 *p*) "Mr. Hide"))))) 25 | 26 | (assert (equal (person-name1 *p*) "Dr. Jekyll")) 27 | 28 | (print :done) 29 | -------------------------------------------------------------------------------- /test/special-slots-2.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | 3 | (in-package :contextl-user) 4 | 5 | (define-layered-class person2 () 6 | ((name2 :initarg :name 7 | :layered-accessor person-name2))) 8 | 9 | (defparameter *p* 10 | (make-instance 'person2 :name "Dr. Jekyll")) 11 | 12 | (assert (equal (person-name2 *p*) "Dr. Jekyll")) 13 | 14 | (symbol-macrolet ((safe-special-symbol-progv t)) 15 | (handler-bind 16 | ((error (lambda (error) 17 | (eval '(define-layered-class person2 () 18 | ((name2 :initarg :name 19 | :special t 20 | :layered-accessor person-name2)))) 21 | (assert (equal (person-name2 *p*) "Dr. Jekyll")) 22 | (continue error)))) 23 | (dletf (((person-name2 *p*) "Mr. Hide")) 24 | (assert (equal (person-name2 *p*) "Mr. Hide"))))) 25 | 26 | (assert (equal (person-name2 *p*) "Dr. Jekyll")) 27 | 28 | (print :done) 29 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2005 - 2016 Pascal Costanza 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or 8 | sell copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /test/special-slots-3.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | 3 | (in-package :contextl-user) 4 | 5 | (defclass person3 () 6 | ((name3 :initarg :name 7 | :accessor person-name3)) 8 | (:metaclass special-class)) 9 | 10 | (defparameter *p* 11 | (make-instance 'person3 :name "Dr. Jekyll")) 12 | 13 | (assert (equal (person-name3 *p*) "Dr. Jekyll")) 14 | 15 | (defparameter *error-count* 0) 16 | 17 | (symbol-macrolet ((safe-special-symbol-progv t)) 18 | (handler-bind 19 | ((error (lambda (error) 20 | (incf *error-count*) 21 | (eval '(defclass person3 () 22 | ((name3 :initarg :name 23 | :special t 24 | :accessor person-name3)) 25 | (:metaclass special-class))) 26 | (assert (equal (person-name3 *p*) "Dr. Jekyll")) 27 | (continue error)))) 28 | (dletf (((person-name3 *p*) "Mr. Hide")) 29 | (assert (equal (person-name3 *p*) "Mr. Hide"))))) 30 | 31 | (assert (eql *error-count* 1)) 32 | (assert (equal (person-name3 *p*) "Dr. Jekyll")) 33 | 34 | (print :done) 35 | -------------------------------------------------------------------------------- /test/fibonacci-test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl-user) 2 | 3 | ;; pure Common Lisp version 4 | 5 | (defvar *fib-cache*) 6 | 7 | (defun fib1 (n) 8 | (or (gethash n *fib-cache*) 9 | (setf (gethash n *fib-cache*) 10 | (if (< n 2) 11 | 1 12 | (+ (fib1 (- n 1)) 13 | (fib1 (- n 2))))))) 14 | 15 | ;; ContextL version 16 | 17 | (define-layered-function fib2 (n)) 18 | 19 | (define-layered-method fib2 (n) 20 | (if (< n 2) 21 | 1 22 | (+ (fib2 (- n 1)) 23 | (fib2 (- n 2))))) 24 | 25 | (deflayer fibonacci-cache) 26 | 27 | (define-layered-method fib2 28 | :in fibonacci-cache (n) 29 | (or (gethash n *fib-cache*) 30 | (setf (gethash n *fib-cache*) 31 | (call-next-method)))) 32 | 33 | (defconstant +runs+ 10000000) 34 | (defconstant +mod+ 1000) 35 | 36 | (defun run-fib-test () 37 | (print "Timing pure Common Lisp version.") 38 | (setf *fib-cache* (make-hash-table)) 39 | (time (loop for i below +runs+ 40 | do (fib1 (mod i +mod+)))) 41 | 42 | (print "Timing ContextL version with global context switch.") 43 | (setf *fib-cache* (make-hash-table)) 44 | (time (with-active-layers (fibonacci-cache) 45 | (loop for i below +runs+ 46 | do (fib2 (mod i +mod+))))) 47 | 48 | (print "Timing ContextL version with local context switches.") 49 | (setf *fib-cache* (make-hash-table)) 50 | (time (loop for i below +runs+ 51 | do (with-active-layers (fibonacci-cache) 52 | (fib2 (mod i +mod+))))) 53 | 54 | 'done) 55 | -------------------------------------------------------------------------------- /dynamic-wind-packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage #:contextl 4 | (:use #:common-lisp #:lispworks) 5 | (:export 6 | #:*symbol-access* 7 | #:call-with-dynamic-environment 8 | #:capture-dynamic-environment 9 | #:defdynamic 10 | #:dlet #:dlet* 11 | #:dletf #:dletf* 12 | #:drelet #:drelet* 13 | #:dreletf #:dreletf* 14 | #:dynamic 15 | #:dynamic-environment 16 | #:dynamic-let 17 | #:dynamic-let* 18 | #:dynamic-mark 19 | #:dynamic-progv 20 | #:dynamic-relet 21 | #:dynamic-relet* 22 | #:dynamic-reprogv 23 | #:dynamic-symbol 24 | #:dynamic-symbol-boundp 25 | #:dynamic-symbol-makunbound 26 | #:dynamic-symbol-p 27 | #:dynamic-symbol-value 28 | #:dynamic-wind 29 | #:make-dynamic-symbol 30 | #:make-special-symbol 31 | #:proceed 32 | #:set-dynamic 33 | #:safe-special-symbol-progv 34 | #:special-symbol-p 35 | #:special-symbol-progv 36 | #:special-symbol-reprogv 37 | #:with-dynamic-environment 38 | #:with-dynamic-mark 39 | #:with-symbol-access 40 | #:without-symbol-access)) 41 | 42 | (defpackage #:contextl-common-lisp 43 | (:nicknames #:cxcl) 44 | (:use #:common-lisp #:contextl) 45 | #.`(:export 46 | ,@(loop for sym being the external-symbols of :common-lisp 47 | collect sym) 48 | ,@(loop for sym being the external-symbols of :contextl 49 | collect sym))) 50 | 51 | (defpackage #:contextl-user 52 | (:use #:contextl-common-lisp) 53 | (:nicknames #:cx-user)) 54 | 55 | (eval-when (:compile-toplevel :load-toplevel :execute) 56 | (pushnew :dynamic-wind *features*)) 57 | -------------------------------------------------------------------------------- /test/grouped-layers.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | 3 | (in-package :contextl-user) 4 | 5 | (defclass grouped-layer (standard-layer-class) ()) 6 | 7 | (defgeneric group-root (layer)) 8 | (defgeneric default-layer (layer)) 9 | 10 | (define-layered-method adjoin-layer-using-class 11 | ((to-add grouped-layer) active-layers) 12 | (call-next-layered-method 13 | to-add 14 | (remove-layer (group-root (find-layer to-add)) active-layers))) 15 | 16 | (define-layered-method remove-layer-using-class 17 | ((to-remove grouped-layer) active-layers) 18 | (declare (ignore active-layers)) 19 | (multiple-value-bind 20 | (new-layers cacheablep) 21 | (call-next-method) 22 | (values 23 | (adjoin-layer (default-layer (find-layer to-remove)) new-layers) 24 | cacheablep))) 25 | 26 | (deflayer output () 27 | ((group-root :initform 'output :reader group-root) 28 | (default-layer :initform 'standard-output :reader default-layer))) 29 | 30 | (deflayer standard-output (output) () 31 | (:metaclass grouped-layer)) 32 | 33 | (deflayer html-output (output) () 34 | (:metaclass grouped-layer)) 35 | 36 | (deflayer xml-output (output) () 37 | (:metaclass grouped-layer)) 38 | 39 | (deflayer json-output (output) () 40 | (:metaclass grouped-layer)) 41 | 42 | (define-layered-function make-output () 43 | (:method () '(output)) 44 | (:method :in standard-output () 45 | (list* 'standard-output (call-next-method))) 46 | (:method :in html-output () 47 | (list* 'html-output (call-next-method))) 48 | (:method :in xml-output () 49 | (list* 'xml-output (call-next-method))) 50 | (:method :in json-output () 51 | (list* 'json-output (call-next-method)))) 52 | 53 | (assert (equal (make-output) '(output))) 54 | 55 | (with-active-layers (standard-output) 56 | (assert (equal (make-output) '(standard-output output))) 57 | (with-active-layers (html-output) 58 | (assert (equal (make-output) '(html-output output))) 59 | (with-active-layers (xml-output) 60 | (assert (equal (make-output) '(xml-output output))) 61 | (with-inactive-layers (xml-output) 62 | (assert (equal (make-output) '(standard-output output)))) 63 | (assert (equal (make-output) '(xml-output output)))) 64 | (assert (equal (make-output) '(html-output output)))) 65 | (assert (equal (make-output) '(standard-output output)))) 66 | 67 | (print :done) 68 | -------------------------------------------------------------------------------- /test/figure-editor-2.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl-user) 2 | 3 | (define-layered-class figure-element-2 () 4 | ()) 5 | 6 | (define-layered-function move-2 (figure-element dx dy)) 7 | 8 | (define-layered-class point-2 (figure-element-2) 9 | ((x :initarg :x :initform 0 :layered t :accessor point-x-2) 10 | (y :initarg :y :initform 0 :layered t :accessor point-y-2))) 11 | 12 | (define-layered-method move-2 ((elm point-2) (dx integer) (dy integer)) 13 | (incf (point-x-2 elm) dx) 14 | (incf (point-y-2 elm) dy)) 15 | 16 | (define-layered-class line-2 (figure-element-2) 17 | ((p1 :initarg :p1 :initform (make-instance 'point-2) :layered t :accessor line-p1-2) 18 | (p2 :initarg :p2 :initform (make-instance 'point-2) :layered t :accessor line-p2-2))) 19 | 20 | (define-layered-method move-2 ((elm line-2) (dx integer) (dy integer)) 21 | (move-2 (line-p1-2 elm) dx dy) 22 | (move-2 (line-p2-2 elm) dx dy)) 23 | 24 | (deflayer display-layer-2) 25 | 26 | (declaim (type integer *update-count-2*)) 27 | (defparameter *update-count-2* 0) 28 | 29 | (defun call-and-update-2 (thunk) 30 | (let ((result (with-inactive-layers (display-layer-2) 31 | (funcall thunk)))) 32 | (incf *update-count-2*) 33 | result)) 34 | 35 | (define-layered-method (setf slot-value-using-layer) 36 | :in display-layer-2 :around 37 | (new-value class (object figure-element-2) slot writer) 38 | (call-and-update-2 (lambda () (funcall writer new-value)))) 39 | 40 | (define-layered-method move-2 41 | :in display-layer-2 :around 42 | ((elm figure-element-2) dx dy) 43 | (call-and-update-2 #'call-next-method)) 44 | 45 | (defconstant +lines-2+ 100) 46 | 47 | (defparameter *lines-2* 48 | (loop repeat +lines-2+ 49 | collect (make-instance 50 | 'line-2 51 | :p1 (make-instance 52 | 'point-2 53 | :x (random 100) 54 | :y (random 100)) 55 | :p2 (make-instance 56 | 'point-2 57 | :x (random 100) 58 | :y (random 100))))) 59 | 60 | (defun move-lines/non-layered-2 () 61 | (loop for line in *lines-2* 62 | do (move-2 line 5 -5)) 63 | (loop for line in *lines-2* 64 | do (move-2 line -5 5))) 65 | 66 | (defun move-lines/layered-2 () 67 | (loop for line in *lines-2* 68 | do (with-active-layers (display-layer-2) 69 | (move-2 line 5 -5))) 70 | (loop for line in *lines-2* 71 | do (with-active-layers (display-layer-2) 72 | (move-2 line -5 5)))) 73 | 74 | (defconstant +runs-2+ 1000) 75 | 76 | (defun run-test-2 () 77 | (setf *update-count-2* 0) 78 | (time (loop repeat +runs-2+ do (move-lines/non-layered-2))) 79 | (assert (eql *update-count-2* 0)) 80 | (time (loop repeat +runs-2+ do (move-lines/layered-2))) 81 | (assert (eql *update-count-2* (* +lines-2+ +runs-2+ 2)))) 82 | -------------------------------------------------------------------------------- /cx-class-in-layer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defgeneric class-layer (class) 4 | (:method ((class class)) 't)) 5 | 6 | (defclass standard-class-in-layer (standard-class) 7 | ((layer :initarg :in-layer 8 | :initarg :in 9 | :initform 't 10 | :reader class-layer))) 11 | 12 | (defmethod validate-superclass 13 | ((class standard-class-in-layer) 14 | (superclass standard-class)) 15 | t) 16 | 17 | (defgeneric slot-definition-layer (slot) 18 | (:method ((slot direct-slot-definition)) 't)) 19 | 20 | (defclass standard-direct-slot-definition-in-layer (standard-direct-slot-definition) 21 | ((layer :initarg :in-layer 22 | :initarg :in 23 | :initform 't 24 | :reader slot-definition-layer))) 25 | 26 | (defmethod direct-slot-definition-class 27 | ((class standard-class-in-layer) &key &allow-other-keys) 28 | (find-class 'standard-direct-slot-definition-in-layer)) 29 | 30 | (defgeneric slot-definition-layers (slot) 31 | (:method ((slot effective-slot-definition)) '(t))) 32 | 33 | (defclass standard-effective-slot-definition-in-layers (standard-effective-slot-definition) 34 | ((layers :initform '(t) 35 | :reader slot-definition-layers))) 36 | 37 | (defmethod effective-slot-definition-class 38 | ((class standard-class-in-layer) &key &allow-other-keys) 39 | (find-class 'standard-effective-slot-definition-in-layers)) 40 | 41 | (defmethod compute-effective-slot-definition 42 | ((class standard-class-in-layer) name direct-slot-definitions) 43 | (declare (ignore name)) 44 | (let ((slot (call-next-method))) 45 | (setf (slot-value slot 'layers) 46 | (loop for direct-slot in direct-slot-definitions 47 | for layer = (slot-definition-layer direct-slot) 48 | for layer-name = (or (layer-name layer) layer) 49 | for layers = (list layer-name) then (adjoin layer-name layers :test #'eq) 50 | finally (return layers))) 51 | slot)) 52 | 53 | (defmethod initialize-instance :around 54 | ((class standard-class-in-layer) &rest initargs 55 | &key (direct-slots ()) (in-layer 't)) 56 | (apply #'call-next-method class 57 | :direct-slots 58 | (loop for direct-slot in direct-slots 59 | if (get-properties direct-slot '(:in-layer :in)) collect direct-slot 60 | else collect (list* :in-layer in-layer direct-slot)) 61 | initargs)) 62 | 63 | (defmethod reinitialize-instance :around 64 | ((class standard-class-in-layer) &rest initargs 65 | &key (direct-slots () direct-slots-p) (in-layer 't)) 66 | (if direct-slots-p 67 | (apply #'call-next-method class 68 | :direct-slots 69 | (loop for direct-slot in direct-slots 70 | if (get-properties direct-slot '(:in-layer :in)) collect direct-slot 71 | else collect (list* :in-layer in-layer direct-slot)) 72 | initargs) 73 | (call-next-method))) 74 | -------------------------------------------------------------------------------- /contextl.asd: -------------------------------------------------------------------------------- 1 | #| 2 | Configuration flags (can be added to *features* before compiling ContextL): 3 | 4 | :cx-disable-dynamic-environments disables dynamic-wind / proceed functionality 5 | (and avoids the incurred overhead) 6 | 7 | :cx-fast-special-symbol-progv avoids the added check for special symbols 8 | (not necessary for correct semantics, only for added safety during development) 9 | 10 | :cx-disable-special-class-in-layered-classes removes the metaclass special-class 11 | from the metaclass layered-class and especially avoids the overhead when 12 | initializing instances of such classes 13 | 14 | :cx-disable-layer-gc disables the garbage collector for layers 15 | (only interesting if you redefine layers and related generic functions at runtime, 16 | should not have a serious effect on runtime performance) 17 | |# 18 | 19 | ;(push :cx-disable-dynamic-environments cl:*features*) 20 | ;(push :cx-fast-special-symbol-progv cl:*features*) 21 | ;(push :cx-disable-special-class-in-layered-classes cl:*features*) 22 | ;(push :cx-disable-layer-gc cl:*features*) 23 | 24 | #+scl 25 | (eval-when (:compile-toplevel :load-toplevel :execute) 26 | (error "ContextL is currently not supported in Scieneer Common Lisp.")) 27 | 28 | (asdf:defsystem #:contextl 29 | :name "ContextL" 30 | :description "ContextL is a CLOS extension for Context-oriented Programming (COP)." 31 | :author "Pascal Costanza" 32 | :version "1.0.0" 33 | :licence "MIT-style license" 34 | :depends-on (#:closer-mop #-lispworks #:lw-compat) 35 | :components ((:file "contextl-packages") 36 | (:file "cx-threads" :depends-on ("contextl-packages")) 37 | (:file "cx-util" :depends-on ("contextl-packages" "cx-threads")) 38 | (:file "cx-dynamic-environments" :depends-on ("contextl-packages")) 39 | (:file "cx-dynamic-variables" :depends-on ("contextl-packages" "cx-dynamic-environments" "cx-threads")) 40 | (:file "cx-dynascope" :depends-on ("contextl-packages" "cx-dynamic-variables")) 41 | (:file "cx-special-class" :depends-on ("cx-dynascope")) 42 | (:file "cx-singleton-class" :depends-on ("contextl-packages" "cx-util")) 43 | (:file "cx-layered-function-macros" :depends-on ("contextl-packages" "cx-util")) 44 | (:file "cx-layer-metaclasses" :depends-on ("cx-special-class" "cx-singleton-class" "cx-threads" "cx-util")) 45 | (:file "cx-gc" :depends-on ("cx-layer-metaclasses" "cx-layered-function-macros" "cx-threads")) 46 | (:file "cx-layer" :depends-on ("cx-layer-metaclasses" "cx-layered-function-macros" "cx-gc" "cx-util" "cx-threads")) 47 | (:file "cx-partial-class" :depends-on ("cx-layer")) 48 | (:file "cx-class-in-layer" :depends-on ("cx-layer")) 49 | (:file "cx-layered-function" :depends-on ("cx-layer" "cx-util")) 50 | (:file "cx-layered-access-class" :depends-on ("cx-layered-function")) 51 | (:file "cx-layered-class" :depends-on ("cx-layered-access-class" "cx-partial-class")))) 52 | -------------------------------------------------------------------------------- /cx-dynamic-environments.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | #-cx-disable-dynamic-environments 4 | (defvar *dynamic-wind-stack* '()) 5 | 6 | (defstruct (dynamic-mark (:constructor make-dynamic-mark (name))) 7 | (name nil :read-only t)) 8 | 9 | (defmacro with-dynamic-mark ((mark-variable) &body body) 10 | (let ((mark (gensym))) 11 | `(let* ((,mark (make-dynamic-mark ',mark-variable)) 12 | #-cx-disable-dynamic-environments 13 | (*dynamic-wind-stack* (cons ,mark *dynamic-wind-stack*)) 14 | (,mark-variable ,mark)) 15 | ,@body))) 16 | 17 | (defmacro dynamic-wind (&body body) 18 | (let ((proceed-name (cond ((eq (first body) :proceed) 19 | (pop body) (pop body)) 20 | (t 'proceed)))) 21 | (assert (symbolp proceed-name) (proceed-name)) 22 | #-cx-disable-dynamic-environments 23 | (with-unique-names (dynamic-wind-thunk proceed-thunk proceed-body) 24 | `(flet ((,dynamic-wind-thunk (,proceed-thunk) 25 | (macrolet ((,proceed-name (&body ,proceed-body) 26 | `(if ,',proceed-thunk 27 | (funcall (the function ,',proceed-thunk)) 28 | (progn ,@,proceed-body)))) 29 | ,@body))) 30 | (declare (inline ,dynamic-wind-thunk)) 31 | (let ((*dynamic-wind-stack* (cons #',dynamic-wind-thunk *dynamic-wind-stack*))) 32 | (,dynamic-wind-thunk nil)))) 33 | #+cx-disable-dynamic-environments 34 | (with-unique-names (proceed-body) 35 | `(macrolet ((,proceed-name (&body ,proceed-body) 36 | `(progn ,@,proceed-body))) 37 | ,@body)))) 38 | 39 | #-cx-disable-dynamic-environments 40 | (progn 41 | (defclass dynamic-environment () 42 | ((dynamic-winds :initarg :dynamic-winds :reader dynamic-winds))) 43 | 44 | (defun capture-dynamic-environment (&optional mark) 45 | (make-instance 'dynamic-environment 46 | :dynamic-winds 47 | (loop with dynamic-winds = '() 48 | for entry in *dynamic-wind-stack* 49 | if (functionp entry) do (push entry dynamic-winds) 50 | else if (eq entry mark) return dynamic-winds 51 | finally (return dynamic-winds)))) 52 | 53 | (defgeneric call-with-dynamic-environment (environment thunk) 54 | (:method ((environment dynamic-environment) (thunk function)) 55 | (declare (optimize (speed 3) (space 3) (debug 0) (safety 0) 56 | (compilation-speed 0))) 57 | (labels ((perform-calls (environment thunk) 58 | (cond (environment 59 | (assert (consp environment)) 60 | (let ((function (first environment))) 61 | (assert (functionp function)) 62 | (let ((*dynamic-wind-stack* (cons function *dynamic-wind-stack*))) 63 | (funcall function (lambda () (perform-calls (rest environment) thunk)))))) 64 | (t (funcall thunk))))) 65 | (perform-calls (dynamic-winds environment) thunk)))) 66 | 67 | (defmacro with-dynamic-environment ((environment) &body body) 68 | `(call-with-dynamic-environment ,environment (lambda () ,@body)))) 69 | -------------------------------------------------------------------------------- /test/figure-editor.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl-user) 2 | 3 | (define-layered-class figure-element () 4 | ()) 5 | 6 | (define-layered-function move (figure-element dx dy)) 7 | 8 | (define-layered-class point (figure-element) 9 | ((x :initarg :x 10 | :initform 0 11 | :layered-accessor point-x) 12 | (y :initarg :y 13 | :initform 0 14 | :layered-accessor point-y))) 15 | 16 | (define-layered-method move ((elm point) (dx integer) (dy integer)) 17 | (incf (point-x elm) dx) 18 | (incf (point-y elm) dy)) 19 | 20 | (define-layered-class line (figure-element) 21 | ((p1 :initarg :p1 22 | :initform (make-instance 'point) 23 | :layered-accessor line-p1) 24 | (p2 :initarg :p2 25 | :initform (make-instance 'point) 26 | :layered-accessor line-p2))) 27 | 28 | (define-layered-method move ((elm line) (dx integer) (dy integer)) 29 | (move (line-p1 elm) dx dy) 30 | (move (line-p2 elm) dx dy)) 31 | 32 | (deflayer display-layer) 33 | 34 | (declaim (type integer *update-count*)) 35 | (defparameter *update-count* 0) 36 | 37 | (defmacro call-and-update (function object) 38 | (declare (ignore object)) 39 | `(let ((result (with-inactive-layers (display-layer) 40 | (,function)))) 41 | (incf *update-count*) 42 | result)) 43 | 44 | (define-layered-method (setf point-x) 45 | :in display-layer :around (new-value (object point)) 46 | (call-and-update call-next-method object)) 47 | 48 | (define-layered-method (setf point-y) 49 | :in display-layer :around (new-value (object point)) 50 | (call-and-update call-next-method object)) 51 | 52 | (define-layered-method (setf line-p1) 53 | :in display-layer :around (new-value (object point)) 54 | (call-and-update call-next-method object)) 55 | 56 | (define-layered-method (setf line-p2) 57 | :in display-layer :around (new-value (object point)) 58 | (call-and-update call-next-method object)) 59 | 60 | (define-layered-method move 61 | :in display-layer :around (object dx dy) 62 | (call-and-update call-next-method object)) 63 | 64 | (defconstant +lines+ 100) 65 | 66 | (defparameter *lines* 67 | (loop repeat +lines+ 68 | collect (make-instance 69 | 'line 70 | :p1 (make-instance 71 | 'point 72 | :x (random 100) 73 | :y (random 100)) 74 | :p2 (make-instance 75 | 'point 76 | :x (random 100) 77 | :y (random 100))))) 78 | 79 | (defun move-lines/non-layered () 80 | (loop for line in *lines* 81 | do (move line 5 -5)) 82 | (loop for line in *lines* 83 | do (move line -5 5))) 84 | 85 | (defun move-lines/layered () 86 | (loop for line in *lines* 87 | do (with-active-layers (display-layer) 88 | (move line 5 -5))) 89 | (loop for line in *lines* 90 | do (with-active-layers (display-layer) 91 | (move line -5 5)))) 92 | 93 | (defconstant +runs+ 1000) 94 | 95 | (defun run-test () 96 | (loop repeat +runs+ do (move-lines/non-layered)) 97 | (setf *update-count* 0) 98 | (time (loop repeat +runs+ do (move-lines/non-layered))) 99 | (assert (eql *update-count* 0)) 100 | (time (loop repeat +runs+ do (move-lines/layered))) 101 | (assert (eql *update-count* (* +lines+ +runs+ 2)))) 102 | -------------------------------------------------------------------------------- /test/runall: -------------------------------------------------------------------------------- 1 | abcl --load demo3.lisp --batch 2 | abcl --load spx.lisp --batch 3 | abcl --load grouped-layers.lisp --batch 4 | abcl --load fe.lisp --batch 5 | abcl --load fe2.lisp --batch 6 | abcl --load special-slots-1.lisp --batch 7 | abcl --load special-slots-2.lisp --batch 8 | abcl --load special-slots-3.lisp --batch 9 | abcl --load layer-gc.lisp --batch 10 | abcl --load dynenv.lisp --batch 11 | abcl --load partial-initargs.lisp --batch 12 | acl --debug-startup -L ~/.clinit.cl -L demo3.lisp --kill 13 | acl --debug-startup -L ~/.clinit.cl -L spx.lisp --kill 14 | acl --debug-startup -L ~/.clinit.cl -L grouped-layers.lisp --kill 15 | acl --debug-startup -L ~/.clinit.cl -L fe.lisp --kill 16 | acl --debug-startup -L ~/.clinit.cl -L fe2.lisp --kill 17 | acl --debug-startup -L ~/.clinit.cl -L special-slots-1.lisp --kill 18 | acl --debug-startup -L ~/.clinit.cl -L special-slots-2.lisp --kill 19 | acl --debug-startup -L ~/.clinit.cl -L special-slots-3.lisp --kill 20 | acl --debug-startup -L ~/.clinit.cl -L layer-gc.lisp --kill 21 | acl --debug-startup -L ~/.clinit.cl -L dynenv.lisp --kill 22 | acl --debug-startup -L ~/.clinit.cl -L partial-initargs.lisp --kill 23 | ccl -l demo3.lisp -e '(quit)' 24 | ccl -l spx.lisp -e '(quit)' 25 | ccl -l grouped-layers.lisp -e '(quit)' 26 | ccl -l fe.lisp -e '(quit)' 27 | ccl -l fe2.lisp -e '(quit)' 28 | ccl -l special-slots-1.lisp -e '(quit)' 29 | ccl -l special-slots-2.lisp -e '(quit)' 30 | ccl -l special-slots-3.lisp -e '(quit)' 31 | ccl -l layer-gc.lisp -e '(quit)' 32 | ccl -l dynenv.lisp -e '(quit)' 33 | ccl -l partial-initargs.lisp -e '(quit)' 34 | clisp -i ~/.clisprc.lisp -on-error debug demo3.lisp 35 | clisp -i ~/.clisprc.lisp -on-error debug spx.lisp 36 | clisp -i ~/.clisprc.lisp -on-error debug grouped-layers.lisp 37 | clisp -i ~/.clisprc.lisp -on-error debug fe.lisp 38 | clisp -i ~/.clisprc.lisp -on-error debug fe2.lisp 39 | clisp -i ~/.clisprc.lisp -on-error debug special-slots-1.lisp 40 | clisp -i ~/.clisprc.lisp -on-error debug special-slots-2.lisp 41 | clisp -i ~/.clisprc.lisp -on-error debug special-slots-3.lisp 42 | clisp -i ~/.clisprc.lisp -on-error debug layer-gc.lisp 43 | clisp -i ~/.clisprc.lisp -on-error debug dynenv.lisp 44 | clisp -i ~/.clisprc.lisp -on-error debug partial-initargs.lisp 45 | ecl -debug -shell demo3.lisp 46 | ecl -debug -shell spx.lisp 47 | ecl -debug -shell grouped-layers.lisp 48 | ecl -debug -shell fe.lisp 49 | ecl -debug -shell fe2.lisp 50 | ecl -debug -shell special-slots-1.lisp 51 | ecl -debug -shell special-slots-2.lisp 52 | ecl -debug -shell special-slots-3.lisp 53 | ecl -debug -shell layer-gc.lisp 54 | ecl -debug -shell dynenv.lisp 55 | ecl -debug -shell partial-initargs.lisp 56 | lisp -load demo3.lisp -eval '(quit)' 57 | lisp -load spx.lisp -eval '(quit)' 58 | lisp -load grouped-layers.lisp -eval '(quit)' 59 | lisp -load fe.lisp -eval '(quit)' 60 | lisp -load fe2.lisp -eval '(quit)' 61 | lisp -load special-slots-1.lisp -eval '(quit)' 62 | lisp -load special-slots-2.lisp -eval '(quit)' 63 | lisp -load special-slots-3.lisp -eval '(quit)' 64 | lisp -load layer-gc.lisp -eval '(quit)' 65 | lisp -load dynenv.lisp -eval '(quit)' 66 | lisp -load partial-initargs.lisp -eval '(quit)' 67 | sbcl --load demo3.lisp --quit 68 | sbcl --load spx.lisp --quit 69 | sbcl --load grouped-layers.lisp --quit 70 | sbcl --load fe.lisp --quit 71 | sbcl --load fe2.lisp --quit 72 | sbcl --load special-slots-1.lisp --quit 73 | sbcl --load special-slots-2.lisp --quit 74 | sbcl --load special-slots-3.lisp --quit 75 | sbcl --load layer-gc.lisp --quit 76 | sbcl --load dynenv.lisp --quit 77 | sbcl --load partial-initargs.lisp --quit 78 | -------------------------------------------------------------------------------- /cx-singleton-class.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defclass singleton-class (standard-class) 4 | ()) 5 | 6 | (defmethod validate-superclass 7 | ((class singleton-class) 8 | (superclass standard-class)) 9 | t) 10 | 11 | (defmethod make-instance ((class singleton-class) &rest initargs) 12 | (declare (ignore initargs)) 13 | (error "The singleton class ~S cannot be instantiated." class)) 14 | 15 | (defvar *reinitialize-singleton-class* nil) 16 | 17 | (defmethod reinitialize-instance :around 18 | ((class singleton-class) &key) 19 | (let ((*reinitialize-singleton-class* t)) 20 | (call-next-method))) 21 | 22 | (defclass singleton-direct-slot-definition (standard-direct-slot-definition) 23 | ((reinitializep :initarg :reinitialize :initform nil :accessor slot-definition-reinitializep))) 24 | 25 | (defmethod direct-slot-definition-class ((class singleton-class) &key &allow-other-keys) 26 | (find-class 'singleton-direct-slot-definition)) 27 | 28 | (defmethod initialize-instance :around 29 | ((slotd singleton-direct-slot-definition) 30 | &rest initargs &key name (allocation :class) reinitialize) 31 | #+(or abcl cmu ecl lispworks6.1 lispworks7 lispworks8) (declare (ignore reinitialize)) 32 | (restart-case 33 | (unless (eq allocation :class) 34 | (error "The allocation of the singleton class slot ~S must be :CLASS, but is defined as ~S." 35 | name allocation)) 36 | (continue () 37 | :report (lambda (stream) (format stream "Use allocation ~S anyway." allocation))) 38 | (allocation-class () 39 | :report "Use allocation :CLASS instead." 40 | (setq allocation :class))) 41 | (apply #'call-next-method slotd 42 | :allocation allocation 43 | :reinitialize 44 | #-(or abcl cmu ecl lispworks6.1 lispworks7 lispworks8) (and reinitialize *reinitialize-singleton-class*) 45 | #+(or abcl cmu ecl lispworks6.1 lispworks7 lispworks8) nil 46 | initargs)) 47 | 48 | (defmethod reinitialize-instance :before 49 | ((class singleton-class) &rest initargs) 50 | (when (getf initargs 51 | #-lispworks4 :direct-default-initargs 52 | #+lispworks4 :default-initargs) 53 | (warn "Default initialization arguments do not make sense for singleton class ~S." class))) 54 | 55 | (defmethod reinitialize-instance :after 56 | ((class singleton-class) &key) 57 | (when-let (prototype (ignore-errors (class-prototype class))) 58 | (loop for slot in (class-direct-slots class) 59 | when (slot-definition-reinitializep slot) do 60 | (setf (slot-definition-reinitializep slot) nil) 61 | (if (slot-definition-initfunction slot) 62 | (setf (slot-value prototype (slot-definition-name slot)) 63 | (funcall (slot-definition-initfunction slot))) 64 | (slot-makunbound prototype (slot-definition-name slot)))))) 65 | 66 | (defmethod finalize-inheritance :after ((class singleton-class)) 67 | (let ((prototype (class-prototype class))) 68 | (loop for slot in (class-direct-slots class) 69 | when (slot-definition-reinitializep slot) do 70 | (setf (slot-definition-reinitializep slot) nil) 71 | (if (slot-definition-initfunction slot) 72 | (setf (slot-value prototype (slot-definition-name slot)) 73 | (funcall (slot-definition-initfunction slot))) 74 | (slot-makunbound prototype (slot-definition-name slot)))))) 75 | 76 | (declaim (inline find-singleton)) 77 | 78 | (defun find-singleton (name &optional (errorp t) environment) 79 | (class-prototype (find-class name errorp environment))) 80 | -------------------------------------------------------------------------------- /cx-layered-function.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defun ensure-layered-function 4 | (name 5 | &rest initargs 6 | &key (lambda-list () lambda-list-p) 7 | (argument-precedence-order (required-args lambda-list)) 8 | (documentation nil) 9 | (generic-function-class 'layered-function) 10 | &allow-other-keys) 11 | (unless lambda-list-p 12 | (error "The layered function ~S must be initialized with a lambda list." name)) 13 | (let ((gf (let ((layer-arg (gensym "LAYER-ARG-"))) 14 | (apply #'ensure-generic-function 15 | (lf-definer-name name) 16 | :generic-function-class 17 | generic-function-class 18 | :argument-precedence-order 19 | `(,@argument-precedence-order ,layer-arg) 20 | :lambda-list 21 | `(,layer-arg ,@lambda-list) 22 | (loop for (key value) on initargs by #'cddr 23 | unless (eq key :documentation) 24 | nconc (list key value)))))) 25 | (setf (fdefinition name) 26 | (let ((lambda `(lambda (&rest rest) 27 | (declare (optimize (speed 3) (debug 0) (safety 0) 28 | (compilation-speed 0))) 29 | (apply (the function ,gf) 30 | (layer-context-prototype *active-context*) 31 | rest)))) 32 | #-ecl (compile nil lambda) 33 | #+ecl (coerce lambda 'function))) 34 | (when documentation 35 | (setf (documentation name 'function) documentation)) 36 | (bind-lf-names name) 37 | gf)) 38 | 39 | (defun ensure-layered-method 40 | (layered-function-designator 41 | lambda-expression 42 | &key 43 | #-(or allegro clisp cmu mcl) 44 | (method-class nil method-class-p) 45 | (in-layer 't) 46 | (qualifiers ()) 47 | (lambda-list (cadr lambda-expression)) 48 | (specializers (required-args lambda-list (constantly (find-class 't))))) 49 | (let ((layered-function (if (functionp layered-function-designator) 50 | layered-function-designator 51 | (fdefinition (lf-definer-name layered-function-designator)))) 52 | (layer-arg (gensym "LAYER-ARG-"))) 53 | #-(or allegro clisp cmu mcl) 54 | (unless method-class-p 55 | (setq method-class (generic-function-method-class layered-function))) 56 | (destructuring-bind 57 | (lambda (&rest args) &body body) 58 | lambda-expression 59 | (unless (eq lambda 'lambda) 60 | (error "Incorrect lambda expression: ~S." lambda-expression)) 61 | (ensure-method layered-function 62 | `(lambda (,layer-arg ,@args) ,@body) 63 | #-(or allegro clisp cmu mcl) :method-class 64 | #-(or allegro clisp cmu mcl) method-class 65 | :qualifiers qualifiers 66 | :lambda-list `(,layer-arg ,@lambda-list) 67 | :specializers (cons (find-layer-class in-layer) specializers))))) 68 | 69 | (defgeneric layered-method-layer (method) 70 | (:method ((method layered-method)) (find-layer (first (method-specializers method))))) 71 | 72 | (defmethod print-object ((object layered-method) stream) 73 | (print-unreadable-object (object stream :type t :identity t) 74 | (format stream "~A ~A ~S ~A" 75 | (when (method-generic-function object) 76 | (lf-caller-name 77 | (generic-function-name 78 | (method-generic-function object)))) 79 | (layered-method-layer object) 80 | (method-qualifiers object) 81 | (layered-method-specializers object)))) 82 | -------------------------------------------------------------------------------- /cx-layered-class.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defclass special-layered-access-class 4 | (layered-access-class 5 | #-cx-disable-special-class-in-layered-classes 6 | special-class 7 | standard-class-in-layer) 8 | ()) 9 | 10 | (defclass special-layered-direct-slot-definition 11 | (layered-direct-slot-definition 12 | #-cx-disable-special-class-in-layered-classes 13 | special-direct-slot-definition 14 | standard-direct-slot-definition-in-layer) 15 | ()) 16 | 17 | (defclass special-effective-slot-definition-in-layers 18 | (#-cx-disable-special-class-in-layered-classes 19 | special-effective-slot-definition 20 | standard-effective-slot-definition-in-layers) 21 | ()) 22 | 23 | (defclass layered-effective-slot-definition-in-layers 24 | (layered-effective-slot-definition 25 | standard-effective-slot-definition-in-layers) 26 | ()) 27 | 28 | (defclass special-layered-effective-slot-definition 29 | (layered-effective-slot-definition-in-layers 30 | special-effective-slot-definition-in-layers) 31 | ()) 32 | 33 | (defmethod direct-slot-definition-class 34 | ((class special-layered-access-class) &key &allow-other-keys) 35 | (find-class 'special-layered-direct-slot-definition)) 36 | 37 | (defvar *special-layered-effective-slot-definition-class*) 38 | 39 | (defmethod effective-slot-definition-class 40 | ((class special-layered-access-class) &key &allow-other-keys) 41 | (if *special-layered-effective-slot-definition-class* 42 | *special-layered-effective-slot-definition-class* 43 | (call-next-method))) 44 | 45 | (defmethod compute-effective-slot-definition 46 | ((class special-layered-access-class) name direct-slot-definitions) 47 | (declare (ignore name)) 48 | (let ((*special-layered-effective-slot-definition-class* 49 | (if (some #'slot-definition-layeredp direct-slot-definitions) 50 | (if (some #'slot-definition-specialp direct-slot-definitions) 51 | (find-class 'special-layered-effective-slot-definition) 52 | (find-class 'layered-effective-slot-definition-in-layers)) 53 | (when (some #'slot-definition-specialp direct-slot-definitions) 54 | (find-class 'special-effective-slot-definition-in-layers))))) 55 | (call-next-method))) 56 | 57 | (defclass layered-class (partial-class special-layered-access-class) 58 | () 59 | (:default-initargs :defining-metaclass 'special-layered-access-class)) 60 | 61 | #+sbcl 62 | (defmethod shared-initialize :after 63 | ((class layered-class) slot-names &key defining-metaclass) 64 | (declare (ignore slot-names defining-metaclass))) 65 | 66 | (defmacro define-layered-class (&whole form name &body options) 67 | (let* ((layer (if (member (car options) '(:in-layer :in) :test #'eq) 68 | (cadr options) 69 | t)) 70 | (options (cond ((member (car options) '(:in-layer :in) :test #'eq) 71 | (cddr options)) 72 | ((not (listp (car options))) 73 | (error "Illegal option ~S in ~S." 74 | (car options) form)) 75 | (t options))) 76 | (form `(defclass ,name ,(car options) 77 | ,(mapcar #'process-layered-access-slot-specification (cadr options)) 78 | ,@(cddr options) 79 | ,@(unless (assoc :metaclass options) 80 | '((:metaclass layered-class))) 81 | (:in-layer . ,layer)))) 82 | #+allegro (if (eq (find-layer layer nil) 't) form 83 | `(excl:without-redefinition-warnings ,form)) 84 | #+lispworks (if (eq (find-layer layer nil) 't) form 85 | `(let ((dspec:*redefinition-action* :quiet)) ,form)) 86 | #-(or allegro lispworks) form)) 87 | -------------------------------------------------------------------------------- /cx-util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | #| 4 | Layers are represented as CLOS classes. To avoid nameclashes with plain 5 | CLOS classes, the name of a layer is actually mapped to an internal 6 | unambiguous name which is used instead of the regular name. 7 | |# 8 | 9 | (defvar *layer-class-definer* 10 | (make-symbol-mapper 'layer-class-definer)) 11 | 12 | (defun defining-layer (name) 13 | "Takes the name of a layer and returns its internal name." 14 | (case name 15 | ((t) 't) 16 | ((nil) (error "NIL is not a valid layer name.")) 17 | (otherwise (map-symbol *layer-class-definer* name)))) 18 | 19 | #| 20 | Layered functions have two names: The name of the caller and the name of 21 | the definer. The caller is just a function that adds a representation of 22 | the active layers to the list of arguments and calls the definer. The 23 | definer is a generic function that contains all the layered methods. 24 | 25 | The caller has the name under which a user knows about a layered function. 26 | The definer has an automatically generated name that can be unambiguously 27 | determined from the caller's name. So for example, consider the following 28 | layered function definition: 29 | 30 | (define-layered-function foo (...)) 31 | 32 | The caller is named 'foo whereas the definer is named something like 33 | =layered-function-definer-for-foo=. [The details of the mapping should 34 | be considered an implementation detail, though, and not part of the 35 | "official" API of ContextL.] 36 | |# 37 | 38 | (defvar *layered-function-definer* 39 | (make-symbol-mapper 'layered-function-definer)) 40 | 41 | (defun lf-definer-name (name) 42 | "Takes the name of a layered function caller 43 | and returns the name of the corresponding definer." 44 | (cond ((plain-function-name-p name) 45 | (map-symbol *layered-function-definer* name)) 46 | ((setf-function-name-p name) 47 | `(setf ,(map-symbol *layered-function-definer* (cadr name)))) 48 | (t (error "Illegal function name: ~S." name)))) 49 | 50 | (defun bind-lf-names (name) 51 | "Takes the name of a layered function caller 52 | and ensures that it can be retrieved again 53 | from the name of a corresponding definer." 54 | (let ((plain-function-name (plain-function-name name))) 55 | (setf (get (map-symbol *layered-function-definer* plain-function-name) 56 | 'layered-function-caller) 57 | plain-function-name))) 58 | 59 | (defun lf-caller-name (name) 60 | "Takes the name of a layered function definer 61 | and returns the name of the corresponding caller." 62 | (cond ((plain-function-name-p name) 63 | (get name 'layered-function-caller)) 64 | ((setf-function-name-p name) 65 | `(setf ,(get (cadr name) 'layered-function-caller))) 66 | (t (error "Illegal function name: ~S." name)))) 67 | 68 | #| 69 | The following are utility functions to distingush between 70 | the two kinds of function names available in Common Lisp. 71 | |# 72 | 73 | (defun plain-function-name-p (name) 74 | (when (symbolp name) 75 | (when (and (keywordp name) 76 | (not (fboundp name))) 77 | (cerror "Use it as a function anyway." 78 | "~S visible from package KEYWORD is used as a function." 79 | name)) 80 | t)) 81 | 82 | (defun setf-function-name-p (name) 83 | (and (consp name) 84 | (eq (car name) 'setf) 85 | (null (cddr name)) 86 | (let ((plain-name (cadr name))) 87 | (when (symbolp plain-name) 88 | (when (and (keywordp plain-name) 89 | (not (fboundp name))) 90 | (cerror "Use it as a function anyway." 91 | "~S is used as a function, with ~S visible from package KEYWORD." 92 | name plain-name)) 93 | t)))) 94 | 95 | (defun plain-function-name (name) 96 | (cond ((plain-function-name-p name) name) 97 | ((setf-function-name-p name) (cadr name)) 98 | (t (error "Illegal function name ~S." name)))) 99 | -------------------------------------------------------------------------------- /cx-partial-class.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defclass partial-object (standard-object) 4 | () 5 | (:default-initargs :allow-other-keys t)) 6 | 7 | (defclass partial-class (standard-class) 8 | ((defining-classes :initarg defining-classes 9 | :reader partial-class-defining-classes) 10 | (defining-metaclass :initarg :defining-metaclass 11 | :reader partial-class-defining-metaclass)) 12 | (:default-initargs :defining-metaclass 'standard-class)) 13 | 14 | (defmethod validate-superclass 15 | ((class partial-class) 16 | (superclass standard-class)) 17 | t) 18 | 19 | (defmethod validate-superclass 20 | ((class standard-class) 21 | (superclass partial-class)) 22 | t) 23 | 24 | (defgeneric partial-class-base-initargs (class) 25 | (:method-combination append) 26 | (:method append ((class partial-class)) 27 | '(:name :defining-metaclass))) 28 | 29 | (defmethod initialize-instance :around 30 | ((class partial-class) &rest initargs 31 | &key name defining-metaclass 32 | (in-layer 't in-layer-p) (in 't in-p)) 33 | (assert (not (and in-layer-p in-p))) 34 | (loop for (key value) on initargs by #'cddr 35 | if (member key (partial-class-base-initargs class)) 36 | nconc (list key value) into base-initargs 37 | else nconc (list key value) into partial-initargs 38 | finally (return 39 | (let* ((in-layer (if in-layer-p in-layer in)) 40 | (in-layer-name (or (layer-name in-layer) (find-layer in-layer))) 41 | (direct-superclasses (list (find-class 'partial-object))) 42 | (defining-classes ())) 43 | (let ((defined-class 44 | (apply #'make-instance defining-metaclass partial-initargs))) 45 | (push defined-class direct-superclasses) 46 | (setf (getf defining-classes in-layer-name) defined-class)) 47 | (unless (eq in-layer-name 't) 48 | (let ((defined-class (make-instance defining-metaclass))) 49 | (push defined-class direct-superclasses) 50 | (setf (getf defining-classes 't) defined-class))) 51 | (apply #'call-next-method class 52 | :direct-superclasses direct-superclasses 53 | 'defining-classes defining-classes 54 | base-initargs))))) 55 | 56 | (defmethod reinitialize-instance :around 57 | ((class partial-class) &rest initargs 58 | &key (in-layer 't in-layer-p) (in 't in-p) 59 | (defining-metaclass (partial-class-defining-metaclass class))) 60 | (assert (not (and in-layer-p in-p))) 61 | (loop for (key value) on initargs by #'cddr 62 | if (member key (partial-class-base-initargs class)) 63 | nconc (list key value) into base-initargs 64 | else nconc (list key value) into partial-initargs 65 | finally (return 66 | (let* ((in-layer (if in-layer-p in-layer in)) 67 | (in-layer-name (or (layer-name in-layer) (find-layer in-layer)))) 68 | (let ((defined-class (getf (partial-class-defining-classes class) in-layer-name))) 69 | (if defined-class 70 | (progn 71 | (apply #'reinitialize-instance defined-class partial-initargs) 72 | (apply #'call-next-method class base-initargs)) 73 | (let ((defined-class 74 | (apply #'make-instance defining-metaclass partial-initargs))) 75 | (apply #'call-next-method class 76 | :direct-superclasses 77 | (append (remove (find-class 'partial-object) 78 | (class-direct-superclasses class)) 79 | (list defined-class) 80 | (list (find-class 'partial-object))) 81 | 'defining-classes 82 | (list* in-layer-name defined-class 83 | (partial-class-defining-classes class)) 84 | base-initargs)))))))) 85 | -------------------------------------------------------------------------------- /cx-threads.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | #+allegro 4 | (eval-when (:compile-toplevel :load-toplevel :execute) 5 | (require :process)) 6 | 7 | #+(or abcl allegro clozure (and cmu mp) (and ecl threads) lispworks mcl (and sbcl sb-thread) scl) 8 | (eval-when (:compile-toplevel :load-toplevel :execute) 9 | (pushnew :cx-threads *features*)) 10 | 11 | (declaim (inline make-lock)) 12 | 13 | (defun make-lock (&key (name "contextl lock")) 14 | #-cx-threads name 15 | #+abcl (declare (ignore name)) 16 | #+abcl (threads:make-thread-lock) 17 | #+allegro (mp:make-process-lock :name name) 18 | #+(or clozure mcl) (ccl:make-lock name) 19 | #+(and cmu mp) (mp:make-lock name) 20 | #+(and ecl threads) (mp:make-lock :name name :recursive t) 21 | #+lispworks (mp:make-lock :name name) 22 | #+(and sbcl sb-thread) (sb-thread:make-mutex :name name) 23 | #+scl (thread:make-lock name)) 24 | 25 | (define-compiler-macro make-lock (&key (name "contextl lock")) 26 | #-cx-threads name 27 | #+abcl (declare (ignore name)) 28 | #+abcl '(threads:make-thread-lock) 29 | #+allegro `(mp:make-process-lock :name ,name) 30 | #+(or clozure mcl) `(ccl:make-lock ,name) 31 | #+(and cmu mp) `(mp:make-lock ,name) 32 | #+(and ecl threads) `(mp:make-lock :name ,name :recursive t) 33 | #+lispworks `(mp:make-lock :name ,name) 34 | #+(and sbcl sb-thread) `(sb-thread:make-mutex :name ,name) 35 | #+scl `(thread:make-lock ,name)) 36 | 37 | (defmacro with-lock ((lock) &body body) 38 | #-cx-threads (declare (ignore lock)) 39 | #-cx-threads `(progn ,@body) 40 | #+abcl `(threads:with-thread-lock (,lock) ,@body) 41 | #+allegro `(mp:with-process-lock (,lock) ,@body) 42 | #+(or clozure mcl) `(ccl:with-lock-grabbed (,lock) ,@body) 43 | #+(and cmu mp) `(mp:with-lock-held (,lock) ,@body) 44 | #+(and ecl threads) `(mp:with-lock (,lock) ,@body) 45 | #+lispworks `(mp:with-lock (,lock) ,@body) 46 | #+(and sbcl sb-thread) `(sb-thread:with-recursive-lock (,lock) ,@body) 47 | #+scl `(thread:with-lock-held (,lock) ,@body)) 48 | 49 | #+cx-threads 50 | (defvar *atomic-operation-lock* (make-lock :name "contextl atomic operation lock")) 51 | 52 | (defmacro as-atomic-operation (&body body) 53 | #-cx-threads `(progn ,@body) 54 | #+cx-threads `(with-lock (*atomic-operation-lock*) ,@body)) 55 | 56 | (defstruct (symbol-mapper (:constructor make-symbol-mapper (name))) 57 | (name nil :read-only t) 58 | 59 | (map (make-hash-table 60 | :test #'eq 61 | 62 | #+allegro :weak-keys #+allegro t 63 | #+clisp :weak #+clisp :key 64 | #+(or clozure mcl) :weak #+(or clozure mcl) t 65 | #+cmu :weak-p #+cmu :key 66 | #+lispworks :weak-kind #+lispworks :key 67 | #+sbcl :weakness #+sbcl :key 68 | 69 | #+clozure :lock-free #+clozure t) 70 | 71 | :read-only t) 72 | 73 | #-(or clozure lispworks sbcl scl) 74 | (lock (make-lock :name "symbol mapper") :read-only t)) 75 | 76 | (declaim (inline atomic-ensure-symbol-mapping)) 77 | 78 | (defun atomic-ensure-symbol-mapping (symbol mapper generate) 79 | (macrolet ((locked-access (&body body) 80 | #+lispworks `(with-hash-table-locked (symbol-mapper-map mapper) ,@body) 81 | #+sbcl `(sb-ext:with-locked-hash-table ((symbol-mapper-map mapper)) ,@body) 82 | #-(or lispworks sbcl) `(with-lock ((symbol-mapper-lock mapper)) ,@body))) 83 | (or (gethash symbol (symbol-mapper-map mapper)) 84 | #+(or clozure scl (not cx-threads)) 85 | (setf (gethash symbol (symbol-mapper-map mapper)) (funcall generate)) 86 | #+(and cx-threads (not clozure) (not scl)) 87 | (locked-access 88 | (or (gethash symbol (symbol-mapper-map mapper)) 89 | (setf (gethash symbol (symbol-mapper-map mapper)) (funcall generate))))))) 90 | 91 | (defgeneric map-symbol (mapper symbol &optional generate) 92 | (:method ((mapper symbol-mapper) (symbol symbol) &optional (generate #'gensym)) 93 | (if (symbol-package symbol) 94 | (intern (with-standard-io-syntax 95 | (format nil "=~A-~A-~A=" 96 | (symbol-mapper-name mapper) 97 | :for 98 | (symbol-name symbol))) 99 | (symbol-package symbol)) 100 | (atomic-ensure-symbol-mapping symbol mapper generate)))) 101 | -------------------------------------------------------------------------------- /contextl-packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage #:contextl 4 | #+lispworks5 5 | (:import-from #:system #:with-hash-table-locked) 6 | #+(and lispworks (not (or lispworks4 lispworks5))) 7 | (:import-from #:hcl #:with-hash-table-locked) 8 | (:use #:closer-common-lisp #:lispworks) 9 | (:export 10 | #:*symbol-access* 11 | #:active-layers 12 | #:adjoin-layer 13 | #:adjoin-layer-using-class 14 | #:apply-with-layer-context 15 | #:call-next-layered-method 16 | #:call-with-dynamic-environment 17 | #:capture-dynamic-environment 18 | #:class-layer 19 | #:clear-layer-caches 20 | #:current-layer-context 21 | #:defdynamic 22 | #:define-layered-class 23 | #:define-layered-function 24 | #:define-layered-method 25 | #:deflayer 26 | #:dlet #:dlet* 27 | #:dletf #:dletf* 28 | #:drelet #:drelet* 29 | #:dreletf #:dreletf* 30 | #:dynamic 31 | #:dynamic-environment 32 | #:dynamic-let 33 | #:dynamic-let* 34 | #:dynamic-mark 35 | #:dynamic-progv 36 | #:dynamic-relet 37 | #:dynamic-relet* 38 | #:dynamic-reprogv 39 | #:dynamic-symbol 40 | #:dynamic-symbol-boundp 41 | #:dynamic-symbol-makunbound 42 | #:dynamic-symbol-p 43 | #:dynamic-symbol-value 44 | #:dynamic-wind 45 | #:ensure-active-layer 46 | #:ensure-inactive-layer 47 | #:ensure-layer 48 | #:ensure-layered-function 49 | #:ensure-layered-method 50 | #:find-layer 51 | #:find-layer-class 52 | #:find-singleton 53 | #:funcall-with-layer-context 54 | #:layer-active-p 55 | #:layer-makunbound 56 | #:layer-name 57 | #:layered-access-class 58 | #:layered-class 59 | #:layered-direct-slot-definition 60 | #:layered-effective-slot-definition 61 | #:layered-effective-slot-definition-in-layers 62 | #:layered-function 63 | #:layered-function-argument-precedence-order 64 | #:layered-function-definer 65 | #:layered-function-lambda-list 66 | #:layered-method 67 | #:layered-method-lambda-list 68 | #:layered-method-layer 69 | #:layered-method-specializers 70 | #:lfmakunbound 71 | #:make-dynamic-symbol 72 | #:make-special-symbol 73 | #:partial-class 74 | #:partial-class-base-initargs 75 | #:partial-class-defining-classes 76 | #:partial-class-defining-metaclass 77 | #:partial-object 78 | #:proceed 79 | #:remove-layer 80 | #:remove-layer-using-class 81 | #:set-dynamic 82 | #:singleton-class 83 | #:slot-definition-layer 84 | #:slot-definition-layered-readers 85 | #:slot-definition-layered-writers 86 | #:slot-definition-layeredp 87 | #:slot-definition-layers 88 | #:slot-definition-specialp 89 | #:slot-boundp-using-layer 90 | #:slot-makunbound-using-layer 91 | #:slot-value-using-layer 92 | #:safe-special-symbol-progv 93 | #:special-class 94 | #:special-direct-slot-definition 95 | #:special-effective-slot-definition 96 | #:special-effective-slot-definition-in-layers 97 | #:special-layered-access-class 98 | #:special-layered-direct-slot-definition 99 | #:special-layered-effective-slot-definition 100 | #:special-object 101 | #:special-symbol-p 102 | #:special-symbol-progv 103 | #:special-symbol-reprogv 104 | #:standard-class-in-layer 105 | #:standard-direct-slot-definition-in-layer 106 | #:standard-effective-slot-definition-in-layers 107 | #:standard-layer-class 108 | #:standard-layer-object 109 | #:with-active-layers 110 | #:with-active-layers* 111 | #:with-dynamic-environment 112 | #:with-dynamic-mark 113 | #:with-inactive-layers 114 | #:with-special-initargs 115 | #:with-special-initargs* 116 | #:with-symbol-access 117 | #:without-symbol-access)) 118 | 119 | (in-package :contextl) 120 | 121 | (defpackage #:contextl-common-lisp 122 | (:nicknames #:cxcl) 123 | (:use #:closer-common-lisp #:contextl) 124 | #.`(:export 125 | ,@(loop for sym being the external-symbols of :closer-common-lisp 126 | collect sym) 127 | ,@(loop for sym being the external-symbols of :contextl 128 | collect sym))) 129 | 130 | (defpackage #:contextl-user 131 | (:use #:contextl-common-lisp) 132 | (:nicknames #:cx-user)) 133 | 134 | (eval-when (:compile-toplevel :load-toplevel :execute) 135 | (pushnew :dynamic-wind *features*) 136 | (pushnew :contextl *features*)) 137 | -------------------------------------------------------------------------------- /cx-gc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | #-cx-disable-layer-gc 4 | (progn 5 | (defun all-layer-contexts () 6 | (let ((result '())) 7 | (labels ((collect (layer-context) 8 | (declare (type layer-context layer-context)) 9 | (when (member layer-context result :test #'eq) 10 | (return-from collect)) 11 | (push layer-context result) 12 | (loop for (nil child) on (layer-context-children/ensure-active layer-context) by #'cddr do 13 | (collect child)) 14 | (loop for (nil child) on (layer-context-children/ensure-inactive layer-context) by #'cddr do 15 | (collect child)))) 16 | (when (boundp '*root-context*) 17 | (collect (symbol-value '*root-context*)) 18 | result)))) 19 | 20 | (defun clear-layer-active-caches (test &optional (all-layer-contexts (all-layer-contexts))) 21 | (loop for layer-context in all-layer-contexts do 22 | (with-lock ((layer-context-lock layer-context)) 23 | (setf (layer-context-children/ensure-active layer-context) 24 | (loop for (key child) on (layer-context-children/ensure-active layer-context) by #'cddr 25 | unless (funcall test key) 26 | nconc (list key child)))))) 27 | 28 | (defun clear-layer-inactive-caches (test &optional (all-layer-contexts (all-layer-contexts))) 29 | (loop for layer-context in all-layer-contexts do 30 | (with-lock ((layer-context-lock layer-context)) 31 | (setf (layer-context-children/ensure-inactive layer-context) 32 | (loop for (key child) on (layer-context-children/ensure-inactive layer-context) by #'cddr 33 | unless (funcall test key) 34 | nconc (list key child)))))) 35 | 36 | (defgeneric clear-layer-context-caches (layer) 37 | (:method ((layer symbol)) (clear-layer-context-caches (find-layer-class layer))) 38 | (:method ((layer standard-layer-object)) (clear-layer-context-caches (find-layer-class layer))) 39 | (:method ((layer-class cl:class)) 40 | (let ((all-layer-contexts (all-layer-contexts)) 41 | (test (lambda (key) (subtypep (find-layer-class key) layer-class)))) 42 | (clear-layer-active-caches test all-layer-contexts) 43 | (clear-layer-inactive-caches test all-layer-contexts)))) 44 | 45 | (defun clear-layer-caches () 46 | (let ((all-layer-contexts (all-layer-contexts))) 47 | (loop for layer-context in all-layer-contexts do 48 | (with-lock ((layer-context-lock layer-context)) 49 | (setf (layer-context-children/ensure-active layer-context) '() 50 | (layer-context-children/ensure-inactive layer-context) '()))))) 51 | 52 | (defmethod reinitialize-instance :after 53 | ((class standard-layer-class) &rest initargs) 54 | (declare (ignore initargs)) 55 | (clear-layer-context-caches class)) 56 | 57 | (defgeneric clear-activation-method-caches (gf method) 58 | (:method (gf method) (declare (ignore gf method)) nil) 59 | (:method ((gf (eql (lf-definer-name 'adjoin-layer-using-class))) method) 60 | (let ((layer-specializer (first (layered-method-specializers method)))) 61 | (if (typep layer-specializer 'eql-specializer) 62 | (let ((eql-specializer-object (eql-specializer-object layer-specializer))) 63 | (clear-layer-active-caches (lambda (key) (eql (find-layer-class key) eql-specializer-object)))) 64 | (clear-layer-active-caches (lambda (key) (typep (find-layer-class key) layer-specializer)))))) 65 | (:method ((gf (eql (lf-definer-name 'remove-layer-using-class))) method) 66 | (let ((layer-specializer (first (layered-method-specializers method)))) 67 | (if (typep layer-specializer 'eql-specializer) 68 | (let ((eql-specializer-object (eql-specializer-object layer-specializer))) 69 | (clear-layer-inactive-caches (lambda (key) (eql (find-layer-class key) eql-specializer-object)))) 70 | (clear-layer-inactive-caches (lambda (key) (typep (find-layer-class key) layer-specializer))))))) 71 | 72 | (defmethod add-method :after 73 | ((gf layered-function) (method layered-method)) 74 | (clear-activation-method-caches (generic-function-name gf) method)) 75 | 76 | (defmethod remove-method :after 77 | ((gf layered-function) (method layered-method)) 78 | (clear-activation-method-caches (generic-function-name gf) method))) 79 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ContextL 2 | ContextL is a CLOS extension for Context-oriented Programming (COP), and was the first language extension that explicitly supports COP when it was originally introduced in 2005. 3 | 4 | ContextL is also provided by [Quicklisp](https://www.quicklisp.org/). 5 | 6 | Currently, there is no documentation available, but you can find some test cases in the distribution and an overview of ContextL's features in [an overview paper](http://www.p-cos.net/documents/contextl-soa.pdf "Context-oriented Programming in ContextL"). See also this [general overview article about COP](http://www.jot.fm/issues/issue_2008_03/article4/ "Context-oriented Programming") which also contains some ContextL examples. 7 | 8 | ContextL depends on [Closer to MOP](https://github.com/pcostanza/closer-mop "Closer to MOP"), and is therefore only supported by the Common Lisp implementations that are supported by that library. 9 | 10 | New in version 1.0.0: 11 | * New version number based on semantic versioning. 12 | * Since version 0.61, support for Allegro Common Lisp 8.2 & 9.0, ABCL, and LispWorks 6.1 has been added. 13 | * An option has been added to disable special slots, which may improve performance if they are not needed. 14 | * Thread safety has been improved. 15 | 16 | New in version 0.61: 17 | * Added support for LispWorks 6.0. 18 | 19 | Highlights of version 0.6: 20 | * Added support for first-class dynamic environments and DYNAMIC-WIND. Due to popular demand, these features can be used independently of the rest of ContextL, by way of using a separate system definition. (In that case, no CLOS MOP is used, so this should run in any ANSI-compliant Common Lisp implementation.) 21 | * Added support for Embeddable Common Lisp. 22 | * Resurrected support for Macintosh Common Lisp (now RMCL). 23 | * Improved extensibility of ContextL metaclasses. 24 | * Removed unnecessary redefinition warnings for layered classes in Allegro and LispWorks. 25 | * Removed dependencies on portable-threads and trivial-garbage. 26 | * Improved use of synchronization features for multithreaded CL implementations. 27 | * Switched to a uniform model for optional features. 28 | * Simplified and improved conditionalizations for Clozure Common Lisp and LispWorks, and removed mentions of OpenMCL (which was just the old name for Clozure Common Lisp). 29 | * Lots of small little bug fixes and improvements here and there. 30 | * Lots of special thanks to the following people who provided useful patches and comments: Willem Broekema, Theam Yong Chew, Alexander Gravilov, Attila Lendvai, and Tobias Rittweiler. Extra special thanks to Duane Rettig (of Franz Inc.) and Martin Simmons (of LispWorks Ld.) for helping with Allegro-specific and LispWorks-specific issues. 31 | 32 | Highlights of version 0.51: 33 | * Ensure-layered-method now accepts function designators instead of just function names, due to Drew Crampsie. 34 | 35 | Highlights of version 0.5: 36 | * ContextL is now thread-safe. 37 | * Added :in as an alternative for :in-layer in the various define-layered-xyz macros. 38 | * Added new functions active-layers and (setf current-layer-context). 39 | * Added a garbage collector for layer caches, such that redefinition of layers or certain methods in the ContextL MOP have an effect. 40 | * Simplified mapping of layer-related names to internal names, which should also make things easier to read when debugging ContextL programs. 41 | 42 | Highlights of version 0.4: 43 | * The deflayer macro doesn't take a :layer-class option anymore, but instead a :metaclass option. This reflects that layers are in fact represented as CLOS classes. 44 | * Added the function current-layer-context. This captures the set of currently active layers, which can later be reinstalled with funcall-with-layer-context and apply-with-layer-context. 45 | * Added several readers for ContextL's metaclasses. 46 | 47 | Highlights of version 0.31: 48 | * Added two versions of the figure editor example from the JMLC'06 paper to the test suite. 49 | 50 | Highlights of version 0.3: 51 | * Added metacircular layer activation through ACTIVATE-LAYER-USING-CLASS and DEACTIVATE-LAYER-USING-CLASS. 52 | * Added WITH-SPECIAL-INITARGS and WITH-SPECIAL-INITARGS\* macros for rebinding special slots based on their initargs. 53 | * WITH-ACTIVE-LAYERS and WITH-ACTIVE-LAYERS\* now process initargs for layer-specific special slots such that they can be rebound at the same time when the respective layer is activated. 54 | * Added CALL-NEXT-LAYERED-METHOD for more convenient super calls in layered methods. 55 | * Added singleton classes. Layers are singletons and internally represented as singleton classes, but the notion of a singleton class is useful in itself, so ContextL provides this as a separate feature. 56 | 57 | This project was partially funded by the Institute for the Promotion of Innovation through Science and Technology in Flanders (IWT-Vlanderen) from 2005-2008. 58 | -------------------------------------------------------------------------------- /test/dynamic-wind.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :dynamic-wind) 2 | 3 | (in-package :contextl-user) 4 | 5 | (let ((symbol (make-dynamic-symbol))) 6 | (assert (dynamic-symbol-p symbol)) 7 | #-cx-disable-dynamic-environments 8 | (assert (not (dynamic-symbol-p (gensym)))) 9 | (assert (not (special-symbol-p symbol))) 10 | (assert (not (dynamic-symbol-boundp symbol))) 11 | (setf (dynamic-symbol-value symbol) 42) 12 | (assert (dynamic-symbol-boundp symbol)) 13 | (assert (eql (dynamic-symbol-value symbol) 42)) 14 | (dynamic-symbol-makunbound symbol) 15 | (assert (not (dynamic-symbol-boundp symbol))) 16 | (assert (handler-case 17 | (progn (dynamic-symbol-value symbol) nil) 18 | (error () t)))) 19 | 20 | (let ((symbol (make-special-symbol))) 21 | (assert (dynamic-symbol-p symbol)) 22 | (assert (special-symbol-p symbol)) 23 | (assert (not (special-symbol-p (gensym)))) 24 | (assert (not (dynamic-symbol-boundp symbol))) 25 | (setf (dynamic-symbol-value symbol) 42) 26 | (assert (dynamic-symbol-boundp symbol)) 27 | (assert (eql (dynamic-symbol-value symbol) 42)) 28 | (dynamic-symbol-makunbound symbol) 29 | (assert (not (dynamic-symbol-boundp symbol))) 30 | (assert (handler-case 31 | (progn (dynamic-symbol-value symbol) nil) 32 | (error () t)))) 33 | 34 | #-cx-disable-dynamic-environments 35 | (progn 36 | (defdynamic x 0) 37 | (defdynamic y 0) 38 | (defdynamic z 0) 39 | 40 | (defdynamic env 41 | (dynamic-let ((x 1) (y 2) (z 3)) 42 | (capture-dynamic-environment))) 43 | 44 | (assert (and (zerop (dynamic x)) 45 | (zerop (dynamic y)) 46 | (zerop (dynamic z)))) 47 | 48 | (assert (equal (with-dynamic-environment ((dynamic env)) 49 | (list (dynamic x) (dynamic y) (dynamic z))) 50 | '(1 2 3))) 51 | 52 | (assert (and (zerop (dynamic x)) 53 | (zerop (dynamic y)) 54 | (zerop (dynamic z)))) 55 | 56 | (assert (equal (with-dynamic-environment ((dynamic env)) 57 | (list (incf (dynamic x)) (incf (dynamic y)) (incf (dynamic z)))) 58 | '(2 3 4))) 59 | 60 | (assert (equal (with-dynamic-environment ((dynamic env)) 61 | (list (dynamic x) (dynamic y) (dynamic z))) 62 | '(2 3 4))) 63 | 64 | (setf (dynamic env) 65 | (dynamic-let ((x 1)) 66 | (with-dynamic-mark (mark) 67 | (dynamic-let ((y 2)) 68 | (capture-dynamic-environment mark))))) 69 | 70 | (assert (with-dynamic-environment ((dynamic env)) 71 | (and (zerop (dynamic x)) 72 | (eql (dynamic y) 2)))) 73 | 74 | (defvar *mark*) 75 | 76 | (defun bam () 77 | (capture-dynamic-environment *mark*)) 78 | 79 | (defun baz () 80 | (dynamic-let ((y 4)) 81 | (bam))) 82 | 83 | (defun bar () 84 | (with-dynamic-mark (*mark*) 85 | (baz))) 86 | 87 | (defun foo () 88 | (dynamic-let ((x 3)) 89 | (bar))) 90 | 91 | (setf (dynamic env) (foo)) 92 | 93 | (assert (with-dynamic-environment ((dynamic env)) 94 | (and (zerop (dynamic x)) 95 | (eql (dynamic y) 4)))) 96 | 97 | (setf (dynamic env) 98 | (dynamic-let ((x 10)) 99 | (with-dynamic-mark (mark1) 100 | (dynamic-let ((y 11)) 101 | (with-dynamic-mark (mark2) 102 | (dynamic-let ((z 12)) 103 | (list (capture-dynamic-environment mark1) 104 | (capture-dynamic-environment mark2)))))))) 105 | 106 | (assert (with-dynamic-environment ((first (dynamic env))) 107 | (and (zerop (dynamic x)) 108 | (eql (dynamic y) 11) 109 | (eql (dynamic z) 12)))) 110 | 111 | (assert (with-dynamic-environment ((second (dynamic env))) 112 | (and (zerop (dynamic x)) 113 | (zerop (dynamic y)) 114 | (eql (dynamic z) 12)))) 115 | 116 | (setf (dynamic x) '(1 2 3)) 117 | 118 | (setf (dynamic env) 119 | (dynamic-relet ((x (list* 'a 'b 'c (dynamic x)))) 120 | (capture-dynamic-environment))) 121 | 122 | (assert (dynamic-let ((x '(d e f))) 123 | (with-dynamic-environment ((dynamic env)) 124 | (equal (dynamic x) '(a b c d e f))))) 125 | 126 | (setf (dynamic env) 127 | (dynamic-wind 128 | (handler-case 129 | (proceed (capture-dynamic-environment)) 130 | (error () (print "error caught correctly") t)))) 131 | 132 | (assert (with-dynamic-environment ((dynamic env)) 133 | (error "This is an error."))) 134 | 135 | (defdynamic xxx nil) 136 | 137 | (defparameter *y* 138 | (dlet ((xxx 1)) 139 | (capture-dynamic-environment))) 140 | 141 | (assert (eql (with-dynamic-environment (*y*) 142 | (dynamic xxx)) 143 | 1)) 144 | 145 | (defparameter *x* 146 | (with-dynamic-environment (*y*) 147 | (capture-dynamic-environment))) 148 | 149 | (assert (eql (with-dynamic-environment (*x*) 150 | (dynamic xxx)) 151 | 1))) 152 | 153 | #+cx-disable-dynamic-environments 154 | (print "Dynamic environments not supported.") 155 | -------------------------------------------------------------------------------- /cx-layer-metaclasses.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defclass standard-layer-object (special-object) 4 | ()) 5 | 6 | (defgeneric layer-name (layer) 7 | (:method ((layer symbol)) layer) 8 | (:method ((layer (eql (find-class 't)))) 't) 9 | (:method ((layer standard-layer-object)) (layer-name (class-of layer)))) 10 | 11 | (defclass standard-layer-class (special-class singleton-class) 12 | ((layer-name :initarg original-name 13 | :initform nil 14 | :reader layer-name)) 15 | (:default-initargs :direct-superclasses (list (find-class 'standard-layer-object)))) 16 | 17 | (defmethod validate-superclass 18 | ((class standard-layer-class) 19 | (superclass standard-class)) 20 | t) 21 | 22 | (defmethod print-object ((object standard-layer-object) stream) 23 | (print-unreadable-object (object stream :type nil :identity t) 24 | (format stream "LAYER ~A" (layer-name object)))) 25 | 26 | (defmethod print-object ((object standard-layer-class) stream) 27 | (print-unreadable-object (object stream :type t :identity t) 28 | (princ (layer-name object) stream))) 29 | 30 | (defmethod initialize-instance :around 31 | ((class standard-layer-class) &rest initargs &key direct-superclasses) 32 | (if (loop for direct-superclass in direct-superclasses 33 | thereis (subclassp direct-superclass 'standard-layer-object)) 34 | (call-next-method) 35 | (apply #'call-next-method 36 | class 37 | :direct-superclasses 38 | (append direct-superclasses 39 | (list (find-class 'standard-layer-object))) 40 | initargs))) 41 | 42 | (defmethod reinitialize-instance :around 43 | ((class standard-layer-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) 44 | (if (or (not direct-superclasses-p) 45 | (loop for direct-superclass in direct-superclasses 46 | thereis (subclassp direct-superclass 'standard-layer-object))) 47 | (call-next-method) 48 | (apply #'call-next-method 49 | class 50 | :direct-superclasses 51 | (append direct-superclasses 52 | (list (find-class 'standard-layer-object))) 53 | initargs))) 54 | 55 | (defclass layer-direct-slot-definition (singleton-direct-slot-definition 56 | special-direct-slot-definition) 57 | ()) 58 | 59 | (defmethod direct-slot-definition-class ((class standard-layer-class) &key) 60 | (find-class 'layer-direct-slot-definition)) 61 | 62 | (defmacro deflayer (name &optional superlayers &body options) 63 | (destructuring-bind (&optional slots &rest options) options 64 | `(defclass ,(defining-layer name) ,(mapcar #'defining-layer superlayers) 65 | ,(if slots slots '()) 66 | ,@options 67 | ,@(unless (assoc :metaclass options) 68 | '((:metaclass standard-layer-class))) 69 | (original-name . ,name)))) 70 | 71 | (defun ensure-layer (layer-name 72 | &rest initargs 73 | &key (metaclass 'standard-layer-class) 74 | &allow-other-keys) 75 | (apply #'ensure-class 76 | (defining-layer layer-name) 77 | :metaclass metaclass 78 | 'original-name layer-name 79 | initargs)) 80 | 81 | (defgeneric find-layer-class (layer &optional errorp environment) 82 | (:method ((layer (eql 't)) &optional errorp environment) 83 | (declare (ignore errorp environment)) 84 | (load-time-value (find-class 't))) 85 | (:method ((layer (eql (find-class 't))) &optional errorp environment) 86 | (declare (ignore errorp environment)) 87 | (load-time-value (find-class 't))) 88 | (:method ((layer symbol) &optional (errorp t) environment) 89 | (or (find-class (defining-layer layer) nil environment) 90 | (when errorp 91 | (cerror "Retry finding the layer." 92 | "There is no layer named ~S." layer) 93 | (find-layer-class layer errorp environment)))) 94 | (:method ((layer standard-layer-object) &optional errorp environment) 95 | (declare (ignore errorp environment)) 96 | (class-of layer)) 97 | (:method ((layer standard-layer-class) &optional errorp environment) 98 | (declare (ignore errorp environment)) 99 | layer)) 100 | 101 | (defgeneric find-layer (layer &optional errorp environment) 102 | (:method ((layer (eql 't)) &optional errorp environment) 103 | (declare (ignore errorp environment)) 104 | 't) 105 | (:method ((layer (eql (find-class 't))) &optional errorp environment) 106 | (declare (ignore errorp environment)) 107 | 't) 108 | (:method ((layer symbol) &optional (errorp t) environment) 109 | (let ((layer-class (find-layer-class layer errorp environment))) 110 | (when layer-class 111 | #-lispworks (ensure-finalized layer-class) 112 | (class-prototype layer-class)))) 113 | (:method ((layer standard-layer-object) &optional errorp environment) 114 | (declare (ignore errorp environment)) 115 | layer) 116 | (:method ((layer standard-layer-class) &optional errorp environment) 117 | (declare (ignore errorp environment)) 118 | #-lispworks (ensure-finalized layer) 119 | (class-prototype layer))) 120 | 121 | (defgeneric layer-makunbound (layer) 122 | (:method ((layer symbol)) 123 | (let* ((defining-layer (defining-layer layer)) 124 | (class (find-class defining-layer))) 125 | (setf (find-class defining-layer) nil 126 | (class-name class) nil))) 127 | (:method ((layer standard-layer-object)) 128 | (let* ((class-name (class-name (class-of layer))) 129 | (class (find-class class-name))) 130 | (setf (find-class class-name) nil 131 | (class-name class) nil))) 132 | (:method ((layer standard-layer-class)) 133 | (let* ((class-name (class-name layer)) 134 | (class (find-class class-name))) 135 | (setf (find-class class-name) nil 136 | (class-name class) nil)))) 137 | 138 | (defstruct layer-context 139 | (prototype (error "No layer-context-prototype specified.") 140 | :type standard-object 141 | :read-only t) 142 | (specializer (error "No layer-context-specializer specified.") 143 | :type standard-layer-class 144 | :read-only t) 145 | (children/ensure-active '() :type list) 146 | (children/ensure-inactive '() :type list) 147 | (lock (make-lock :name "layer context") :read-only t)) 148 | -------------------------------------------------------------------------------- /test/layer-gc.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | 3 | (in-package :contextl-user) 4 | 5 | (defvar *adjoined*) 6 | (defvar *removed*) 7 | (defvar *default-context*) 8 | (defvar *new-context*) 9 | 10 | (defclass my-layer-class (standard-layer-class) ()) 11 | 12 | #-cx-disable-layer-gc 13 | (loop repeat 2 do 14 | (clear-layer-caches) 15 | 16 | (defclass my-layer-class (standard-layer-class) ()) 17 | 18 | (define-layered-method adjoin-layer-using-class :after 19 | ((class my-layer-class) (active-context t)) 20 | (setf *adjoined* t)) 21 | 22 | (define-layered-method remove-layer-using-class :after 23 | ((class my-layer-class) (active-context t)) 24 | (setf *removed* t)) 25 | 26 | (deflayer foo () () (:metaclass my-layer-class)) 27 | (deflayer bar () () (:metaclass my-layer-class)) 28 | (deflayer baz (bar) () (:metaclass my-layer-class)) 29 | 30 | (setf *default-context* (current-layer-context)) 31 | 32 | ;;; 33 | (print 1) 34 | 35 | (adjoin-layer 'foo *default-context*) 36 | (assert *adjoined*) 37 | 38 | (setf *adjoined* nil) 39 | (adjoin-layer 'foo *default-context*) 40 | (assert (not *adjoined*)) 41 | 42 | (setf *adjoined* nil) 43 | (adjoin-layer 'foo *default-context*) 44 | (assert (not *adjoined*)) 45 | 46 | (reinitialize-instance (find-layer-class 'foo)) 47 | 48 | (makunbound '*adjoined*) 49 | (adjoin-layer 'foo *default-context*) 50 | (assert *adjoined*) 51 | 52 | (setf *adjoined* nil) 53 | (adjoin-layer 'foo *default-context*) 54 | (assert (not *adjoined*)) 55 | 56 | (setf *adjoined* nil) 57 | (adjoin-layer 'foo *default-context*) 58 | (assert (not *adjoined*)) 59 | 60 | ;;; 61 | (print 2) 62 | 63 | (remove-layer 'foo *default-context*) 64 | (assert *removed*) 65 | 66 | (setf *removed* nil) 67 | (remove-layer 'foo *default-context*) 68 | (assert (not *removed*)) 69 | 70 | (setf *removed* nil) 71 | (remove-layer 'foo *default-context*) 72 | (assert (not *removed*)) 73 | 74 | (reinitialize-instance (find-layer-class 'foo)) 75 | 76 | (makunbound '*removed*) 77 | (remove-layer 'foo *default-context*) 78 | (assert *removed*) 79 | 80 | (setf *removed* nil) 81 | (remove-layer 'foo *default-context*) 82 | (assert (not *removed*)) 83 | 84 | (setf *removed* nil) 85 | (remove-layer 'foo *default-context*) 86 | (assert (not *removed*)) 87 | 88 | ;;; 89 | (print 3) 90 | 91 | (setf *new-context* (adjoin-layer 'foo *default-context*)) 92 | 93 | (makunbound '*adjoined*) 94 | (adjoin-layer 'baz *new-context*) 95 | (assert *adjoined*) 96 | 97 | (setf *adjoined* nil) 98 | (adjoin-layer 'baz *new-context*) 99 | (assert (not *adjoined*)) 100 | 101 | (setf *adjoined* nil) 102 | (adjoin-layer 'baz *new-context*) 103 | (assert (not *adjoined*)) 104 | 105 | (reinitialize-instance (find-layer-class 'bar)) 106 | 107 | (setf *adjoined* nil) 108 | (adjoin-layer 'baz *new-context*) 109 | (assert *adjoined*) 110 | 111 | (setf *adjoined* nil) 112 | (adjoin-layer 'baz *new-context*) 113 | (assert (not *adjoined*)) 114 | 115 | (setf *adjoined* nil) 116 | (adjoin-layer 'baz *new-context*) 117 | (assert (not *adjoined*)) 118 | 119 | ;;; 120 | (print 4) 121 | 122 | (setf *new-context* (remove-layer 'foo *default-context*)) 123 | 124 | (makunbound '*removed*) 125 | (remove-layer 'baz *new-context*) 126 | (assert *removed*) 127 | 128 | (setf *removed* nil) 129 | (remove-layer 'baz *new-context*) 130 | (assert (not *removed*)) 131 | 132 | (setf *removed* nil) 133 | (remove-layer 'baz *new-context*) 134 | (assert (not *removed*)) 135 | 136 | (reinitialize-instance (find-layer-class 'bar)) 137 | 138 | (setf *removed* nil) 139 | (remove-layer 'baz *new-context*) 140 | (assert *removed*) 141 | 142 | (setf *removed* nil) 143 | (remove-layer 'baz *new-context*) 144 | (assert (not *removed*)) 145 | 146 | (setf *removed* nil) 147 | (remove-layer 'baz *new-context*) 148 | (assert (not *removed*)) 149 | 150 | ;;; 151 | (print 5) 152 | 153 | (setf *new-context* (adjoin-layer 'foo *default-context*)) 154 | 155 | (makunbound '*adjoined*) 156 | (adjoin-layer 'bar *new-context*) 157 | (assert *adjoined*) 158 | 159 | (setf *adjoined* nil) 160 | (adjoin-layer 'bar *new-context*) 161 | (assert (not *adjoined*)) 162 | 163 | (define-layered-method adjoin-layer-using-class :before 164 | ((class my-layer-class) (active-context t)) 165 | '()) 166 | 167 | (setf *adjoined* nil) 168 | (adjoin-layer 'bar *new-context*) 169 | (assert *adjoined*) 170 | 171 | (setf *adjoined* nil) 172 | (adjoin-layer 'bar *new-context*) 173 | (assert (not *adjoined*)) 174 | 175 | ;;; 176 | (print 6) 177 | 178 | (setf *new-context* (remove-layer 'foo *default-context*)) 179 | 180 | (makunbound '*removed*) 181 | (remove-layer 'bar *new-context*) 182 | (assert *removed*) 183 | 184 | (setf *removed* nil) 185 | (remove-layer 'bar *new-context*) 186 | (assert (not *removed*)) 187 | 188 | (define-layered-method remove-layer-using-class :before 189 | ((class my-layer-class) (active-context t)) 190 | '()) 191 | 192 | (setf *removed* nil) 193 | (remove-layer 'bar *new-context*) 194 | (assert *removed*) 195 | 196 | (setf *removed* nil) 197 | (remove-layer 'bar *new-context*) 198 | (assert (not *removed*)) 199 | 200 | ;;; 201 | (print 7) 202 | 203 | (setf *new-context* (adjoin-layer 'foo *default-context*)) 204 | 205 | (makunbound '*adjoined*) 206 | (adjoin-layer 'bar *new-context*) 207 | (assert *adjoined*) 208 | 209 | (setf *adjoined* nil) 210 | (adjoin-layer 'bar *new-context*) 211 | (assert (not *adjoined*)) 212 | 213 | (define-layered-method adjoin-layer-using-class :before 214 | ((class (eql (find-layer-class 'bar))) (active-context t)) 215 | '()) 216 | 217 | (setf *adjoined* nil) 218 | (adjoin-layer 'bar *new-context*) 219 | (assert *adjoined*) 220 | 221 | (setf *adjoined* nil) 222 | (adjoin-layer 'bar *new-context*) 223 | (assert (not *adjoined*)) 224 | 225 | ;;; 226 | (print 8) 227 | 228 | (clear-layer-caches) 229 | 230 | (setf *new-context* (remove-layer 'foo *default-context*)) 231 | 232 | (makunbound '*removed*) 233 | (remove-layer 'bar *new-context*) 234 | (assert *removed*) 235 | 236 | (setf *removed* nil) 237 | (remove-layer 'bar *new-context*) 238 | (assert (not *removed*)) 239 | 240 | (define-layered-method remove-layer-using-class :before 241 | ((class (eql (find-layer-class 'bar))) (active-context t)) 242 | '()) 243 | 244 | (setf *removed* nil) 245 | (remove-layer 'bar *new-context*) 246 | (assert *removed*) 247 | 248 | (setf *removed* nil) 249 | (remove-layer 'bar *new-context*) 250 | (assert (not *removed*)) 251 | 252 | (print :done)) 253 | 254 | #+cx-disable-layer-gc 255 | (print "Layer GC not supported.") 256 | -------------------------------------------------------------------------------- /cx-layered-function-macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defun parse-method-body (form body) 4 | (let* ((in-layerp (member (car body) '(:in-layer :in) :test #'eq)) 5 | (layer-spec (if in-layerp (cadr body) 't))) 6 | (when (consp layer-spec) 7 | (unless (null (cddr layer-spec)) 8 | (error "Incorrect :in-layer specification in ~S." form))) 9 | (loop with layer = (if (atom layer-spec) 10 | layer-spec 11 | (cadr layer-spec)) 12 | with layer-arg = (if (atom layer-spec) 13 | (gensym "LAYER-ARG-") 14 | (car layer-spec)) 15 | for tail = (if in-layerp (cddr body) body) then (cdr tail) 16 | until (listp (car tail)) 17 | collect (car tail) into qualifiers 18 | finally 19 | (loop for qualifier in qualifiers 20 | when (member qualifier '(:in-layer :in) :test #'eq) 21 | do (error "Incorrect occurrence of ~S in ~S. Must occur before qualifiers." qualifier form)) 22 | (return (values layer-arg layer qualifiers (car tail) (cdr tail)))))) 23 | 24 | (defun prepare-layer (layer) 25 | (if (symbolp layer) 26 | (defining-layer layer) 27 | layer)) 28 | 29 | (defun prepare-layered-method-body (name form layer-arg body) 30 | (loop for tail = body then (cdr tail) 31 | for (first . rest) = tail 32 | while tail 33 | while (or (and rest (stringp first)) 34 | (and (consp first) (eq (car first) 'declare))) 35 | count (stringp first) into nof-seen-strings 36 | collect first into declarations 37 | finally 38 | (when (> nof-seen-strings 1) 39 | (warn "Too many documentation strings in ~S." form)) 40 | (return `(,@declarations 41 | (block ,(plain-function-name name) 42 | (flet ((call-next-layered-method (&rest args) 43 | (if args 44 | (apply #'call-next-method ,layer-arg args) 45 | (call-next-method)))) 46 | (declare (inline call-next-layered-method) 47 | (ignorable (function call-next-layered-method))) 48 | ,@tail)))))) 49 | 50 | (defun parse-gf-lambda-list (lambda-list) 51 | (loop for entry in lambda-list 52 | for lambda-list-keyword = (member entry lambda-list-keywords) 53 | until lambda-list-keyword 54 | collect entry into required-parameters 55 | finally (return (values required-parameters lambda-list-keyword)))) 56 | 57 | (defclass layered-function (standard-generic-function) () 58 | (:metaclass funcallable-standard-class) 59 | (:default-initargs :method-class (find-class 'layered-method))) 60 | 61 | (defmethod print-object ((object layered-function) stream) 62 | (print-unreadable-object (object stream :type t :identity t) 63 | (princ (lf-caller-name (generic-function-name object)) stream))) 64 | 65 | (defun layered-function-definer (name) 66 | (fdefinition (lf-definer-name name))) 67 | 68 | (defgeneric layered-function-argument-precedence-order (function) 69 | (:method ((function layered-function)) (butlast (generic-function-argument-precedence-order function)))) 70 | 71 | (defgeneric layered-function-lambda-list (function) 72 | (:method ((function layered-function)) (rest (generic-function-lambda-list function)))) 73 | 74 | (defun lfmakunbound (name) 75 | (fmakunbound (lf-definer-name name)) 76 | (fmakunbound name)) 77 | 78 | (defclass layered-method (standard-method) ()) 79 | 80 | (defgeneric layered-method-lambda-list (method) 81 | (:method ((method layered-method)) (rest (method-lambda-list method)))) 82 | 83 | (defgeneric layered-method-specializers (method) 84 | (:method ((method layered-method)) (rest (method-specializers method)))) 85 | 86 | (defmacro define-layered-function (name (&rest args) &body options) 87 | (let ((definer (lf-definer-name name)) 88 | (documentation (assoc :documentation options))) 89 | (with-unique-names (layer-arg rest-arg) 90 | `(progn 91 | (defgeneric ,definer (,layer-arg ,@args) 92 | ,@(unless (member :generic-function-class options :key #'car) 93 | '((:generic-function-class layered-function))) 94 | (:argument-precedence-order 95 | ,@(let ((argument-precedence-order (assoc :argument-precedence-order options))) 96 | (if argument-precedence-order 97 | (cdr argument-precedence-order) 98 | (required-args args))) 99 | ,layer-arg) 100 | ,@(loop for option in (remove :argument-precedence-order options :key #'car) 101 | if (eq (car option) :method) 102 | collect (multiple-value-bind 103 | (layer-arg layer qualifiers args method-body) 104 | (parse-method-body option (cdr option)) 105 | `(:method ,@qualifiers ((,layer-arg ,(prepare-layer layer)) ,@args) 106 | ,@(prepare-layered-method-body name option layer-arg method-body))) 107 | else if (not (eq (car option) :documentation)) collect option)) 108 | (declaim (inline ,name)) 109 | ,(multiple-value-bind 110 | (required-parameters lambda-list-keyword) 111 | (parse-gf-lambda-list args) 112 | (if lambda-list-keyword 113 | `(defun ,name (,@required-parameters &rest ,rest-arg) 114 | (declare (optimize (speed 3) (debug 0) (safety 0) 115 | (compilation-speed 0))) 116 | ,@(when documentation (list (cadr documentation))) 117 | (apply #',definer (layer-context-prototype *active-context*) ,@required-parameters ,rest-arg)) 118 | `(defun ,name (,@required-parameters) 119 | (declare (optimize (speed 3) (debug 0) (safety 0) 120 | (compilation-speed 0))) 121 | ,@(when documentation (list (cadr documentation))) 122 | (funcall #',definer (layer-context-prototype *active-context*) ,@required-parameters)))) 123 | (eval-when (:compile-toplevel :load-toplevel :execute) 124 | (bind-lf-names ',name)) 125 | #',definer)))) 126 | 127 | (defmacro define-layered-method (&whole form name &body body) 128 | (multiple-value-bind 129 | (layer-arg layer qualifiers args method-body) 130 | (parse-method-body form body) 131 | `(defmethod ,(lf-definer-name name) 132 | ,@qualifiers ((,layer-arg ,(prepare-layer layer)) ,@args) 133 | ,@(prepare-layered-method-body name form layer-arg method-body)))) 134 | -------------------------------------------------------------------------------- /cx-dynascope.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defun make-special-symbol () 4 | "creates a fresh unique special symbol" 5 | (let ((symbol (make-dynamic-symbol "SPECIAL-SYMBOL-"))) 6 | (setf (get symbol 'specialp) t) 7 | symbol)) 8 | 9 | (declaim (inline special-symbol-p)) 10 | 11 | (defun special-symbol-p (symbol) 12 | "checks whether a symbol is special, as created by make-special-symbol" 13 | (and #-cx-fast-special-symbol-progv 14 | (dynamic-symbol-p symbol) 15 | #+cx-fast-special-symbol-progv 16 | (symbolp symbol) 17 | (get symbol 'specialp))) 18 | 19 | (defvar *symbol-access* nil 20 | "set/get a place's special symbol instead of its symbol value 21 | when this is set to a non-nil value") 22 | 23 | (defmacro with-symbol-access (&body body) 24 | "executes body in an environment with *symbol-access* set to t" 25 | `(let ((*symbol-access* t)) 26 | ,@body)) 27 | 28 | (defmacro without-symbol-access (&body body) 29 | "executes body in an environment with *symbol-access* set to nil" 30 | `(let ((*symbol-access* nil)) 31 | ,@body)) 32 | 33 | (defun prepare-binding (binding env) 34 | "ensure that a binding form is 'well-formed' to ease further processing" 35 | (when (symbolp binding) 36 | (setf binding (list binding nil))) 37 | (assert (null (cddr binding)) () 38 | "Bad initialization form: ~S." binding) 39 | `(,(macroexpand (car binding) env) ,@(cdr binding))) 40 | 41 | (define-symbol-macro safe-special-symbol-progv 42 | #-cx-fast-special-symbol-progv t 43 | #+cx-fast-special-symbol-progv nil) 44 | ;; redefine this to nil to get more efficient code, 45 | ;; either globally via define-symbol-macro, 46 | ;; or locally via symbol-macrolet 47 | 48 | (defmacro special-symbol-progv (symbols values &body body &environment env) 49 | "like dynamic-progv, only that symbols must all be special symbols" 50 | (if (macroexpand 'safe-special-symbol-progv env) 51 | (with-unique-names (symbol-list retry) 52 | `(let (,symbol-list) 53 | (tagbody 54 | ,retry (setq ,symbol-list ,symbols) 55 | (unless (every #'special-symbol-p ,symbol-list) 56 | (cerror "Retry to rebind the place(s)." 57 | "Attempt at rebinding one or more non-special places: ~S" 58 | ',symbols) 59 | (go ,retry))) 60 | (dynamic-progv ,symbol-list ,values ,@body))) 61 | `(dynamic-progv ,symbols ,values ,@body))) 62 | 63 | (defmacro special-symbol-reprogv (symbols values &body body &environment env) 64 | "like dynamic-reprogv, only that symbols must all be special symbols" 65 | (if (macroexpand 'safe-special-symbol-progv env) 66 | (with-unique-names (symbol-list retry) 67 | `(let (,symbol-list) 68 | (tagbody 69 | ,retry (setq ,symbol-list ,symbols) 70 | (unless (every #'special-symbol-p ,symbol-list) 71 | (cerror "Retry to rebind the place(s)." 72 | "Attempt at rebinding one or more non-special places: ~S" 73 | ',symbols) 74 | (go ,retry))) 75 | (dynamic-reprogv ,symbol-list ,values ,@body))) 76 | `(dynamic-reprogv ,symbols ,values ,@body))) 77 | 78 | (defmacro dletf* (bindings &body body &environment env) 79 | "sequentially bind places to new values with dynamic scope, 80 | and execute body in that new dynamic environment" 81 | (loop for form = `(progn ,@body) then (etypecase (car binding) 82 | (symbol `(dlet (,binding) ,form)) 83 | (cons `(special-symbol-progv 84 | (list (with-symbol-access ,(car binding))) 85 | (list ,(cadr binding)) 86 | ,form))) 87 | for binding in (reverse bindings) 88 | do (setf binding (prepare-binding binding env)) 89 | finally (return form))) 90 | 91 | (defmacro dreletf* (bindings &body body &environment env) 92 | "sequentially bind places to new values with dynamic scope, 93 | and execute body in that new dynamic environment" 94 | (loop for form = `(progn ,@body) then (etypecase (car binding) 95 | (symbol `(dreletf (,binding) ,form)) 96 | (cons (with-unique-names (symbol-store) 97 | `(let ((,symbol-store (list (with-symbol-access ,(car binding))))) 98 | (special-symbol-reprogv 99 | ,symbol-store 100 | (list ,(cadr binding)) 101 | ,form))))) 102 | for binding in (reverse bindings) 103 | do (setf binding (prepare-binding binding env)) 104 | finally (return form))) 105 | 106 | (defmacro dletf (bindings &body body &environment env) 107 | "bind places to new values with dynamic scope in parallel, 108 | and execute body in that new dynamic environment" 109 | (loop for binding in bindings 110 | do (setf binding (prepare-binding binding env)) 111 | collect (if (symbolp (car binding)) 112 | `',(%dynamic-symbol (car binding)) 113 | (car binding)) into symbol-forms 114 | when (symbolp (car binding)) collect (car binding) into variables 115 | collect (cadr binding) into value-forms 116 | finally (return `(special-symbol-progv 117 | (with-symbol-access 118 | (list ,@symbol-forms)) 119 | (list ,@value-forms) 120 | (locally (declare (special ,@variables)) 121 | ,@body))))) 122 | 123 | (defmacro dreletf (bindings &body body &environment env) 124 | "bind places to new values with dynamic scope in parallel, 125 | and execute body in that new dynamic environment" 126 | (loop for binding in bindings 127 | do (setf binding (prepare-binding binding env)) 128 | collect (if (symbolp (car binding)) 129 | `',(%dynamic-symbol (car binding)) 130 | (car binding)) into symbol-forms 131 | when (symbolp (car binding)) collect (car binding) into variables 132 | collect (cadr binding) into value-forms 133 | finally (return (with-unique-names (symbol-store) 134 | `(let ((,symbol-store (with-symbol-access 135 | (list ,@symbol-forms)))) 136 | (special-symbol-reprogv 137 | ,symbol-store 138 | (list ,@value-forms) 139 | (locally (declare (special ,@variables)) 140 | ,@body))))))) 141 | -------------------------------------------------------------------------------- /cx-dynamic-variables.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | #-cx-disable-dynamic-environments 4 | (progn 5 | (defvar %unbound '%unbound) 6 | 7 | (defstruct (dbox (:constructor make-dbox (value))) 8 | value) 9 | 10 | (defmethod print-object ((object dbox) stream) 11 | (print-unreadable-object (object stream :type t :identity t) 12 | (princ (dbox-value object))))) 13 | 14 | (defvar *dynamic-symbol* 15 | (make-symbol-mapper 'dynamic-symbol)) 16 | 17 | (defun make-dynamic-symbol (&optional (x "DYNAMIC-SYMBOL-")) 18 | #-cx-disable-dynamic-environments 19 | (let ((symbol (gensym x))) 20 | (setf (symbol-value symbol) 21 | (make-dbox %unbound)) 22 | symbol) 23 | #+cx-disable-dynamic-environments 24 | (gensym x)) 25 | 26 | (defun dynamic-symbol (symbol) 27 | (map-symbol *dynamic-symbol* symbol 28 | #-cx-disable-dynamic-environments 29 | #'make-dynamic-symbol)) 30 | 31 | (declaim (inline dynamic-symbol-p)) 32 | 33 | (defun dynamic-symbol-p (symbol) 34 | #-cx-disable-dynamic-environments 35 | (and (symbolp symbol) 36 | (boundp symbol) 37 | (dbox-p (symbol-value symbol))) 38 | #+cx-disable-dynamic-environments 39 | (symbolp symbol)) 40 | 41 | (declaim (inline dynamic-symbol-value (setf dynamic-symbol-value) 42 | dynamic-symbol-boundp dynamic-symbol-makunbound)) 43 | 44 | (defun dynamic-symbol-value (symbol) 45 | #-cx-disable-dynamic-environments 46 | (let ((value (dbox-value (symbol-value symbol)))) 47 | (if (eq value %unbound) 48 | (error 'unbound-variable :name symbol) 49 | value)) 50 | #+cx-disable-dynamic-environments 51 | (symbol-value symbol)) 52 | 53 | (defun (setf dynamic-symbol-value) (value symbol) 54 | #-cx-disable-dynamic-environments 55 | (setf (dbox-value (symbol-value symbol)) value) 56 | #+cx-disable-dynamic-environments 57 | (setf (symbol-value symbol) value)) 58 | 59 | (defun dynamic-symbol-boundp (symbol) 60 | #-cx-disable-dynamic-environments 61 | (not (eq (dbox-value (symbol-value symbol)) %unbound)) 62 | #+cx-disable-dynamic-environments 63 | (boundp symbol)) 64 | 65 | (defun dynamic-symbol-makunbound (symbol) 66 | #-cx-disable-dynamic-environments 67 | (setf (dbox-value (symbol-value symbol)) %unbound) 68 | #+cx-disable-dynamic-environments 69 | (makunbound symbol)) 70 | 71 | #-cx-disable-dynamic-environments 72 | (progn 73 | (declaim (inline compute-bindings)) 74 | 75 | (defun compute-bindings (symbols values) 76 | (loop for nil in symbols 77 | if values collect (make-dbox (pop values)) 78 | else collect (make-dbox %unbound)))) 79 | 80 | (defmacro dynamic-progv (symbols values &body body) 81 | #-cx-disable-dynamic-environments 82 | (with-unique-names (fixed-symbols fixed-bindings proceed) 83 | `(let* ((,fixed-symbols ,symbols) 84 | (,fixed-bindings (compute-bindings ,fixed-symbols ,values))) 85 | (dynamic-wind :proceed ,proceed 86 | (progv ,fixed-symbols ,fixed-bindings 87 | (,proceed ,@body))))) 88 | #+cx-disable-dynamic-environments 89 | `(progv ,symbols ,values ,@body)) 90 | 91 | (defmacro dynamic-reprogv (symbols values &body body) 92 | #-cx-disable-dynamic-environments 93 | (with-unique-names (computed-symbols computed-bindings proceed) 94 | `(dynamic-wind :proceed ,proceed 95 | (let* ((,computed-symbols ,symbols) 96 | (,computed-bindings (compute-bindings ,computed-symbols ,values))) 97 | (progv ,computed-symbols ,computed-bindings 98 | (,proceed ,@body))))) 99 | #+cx-disable-dynamic-environments 100 | `(progv ,symbols ,values ,@body)) 101 | 102 | (declaim (inline %dynamic-symbol)) 103 | 104 | (defun %dynamic-symbol (symbol) 105 | (map-symbol *dynamic-symbol* symbol)) 106 | 107 | (defmacro defdynamic (name &body form) 108 | (assert (and (consp form) (null (cdr form)))) 109 | `(progn 110 | (defparameter ,(%dynamic-symbol name) 111 | #-cx-disable-dynamic-environments (make-dbox ,@form) 112 | #+cx-disable-dynamic-environments ,@form) 113 | ',name)) 114 | 115 | (defmacro dynamic (var) 116 | #-cx-disable-dynamic-environments 117 | `(dbox-value ,(%dynamic-symbol var)) 118 | #+cx-disable-dynamic-environments 119 | (%dynamic-symbol var)) 120 | 121 | (defmacro set-dynamic (form var) 122 | `(setf (dynamic ,var) ,form)) 123 | 124 | (defmacro dynamic-let ((&rest bindings) &body body) 125 | (assert (and (every #'consp bindings) 126 | (notany #'cddr bindings))) 127 | #-cx-disable-dynamic-environments 128 | (loop with proceed = (gensym) 129 | for (var form) in bindings 130 | collect (copy-symbol var) into stores 131 | collect (%dynamic-symbol var) into symbols 132 | collect form into forms 133 | finally 134 | (return `(let ,(loop for store in stores 135 | for form in forms 136 | collect `(,store (make-dbox ,form))) 137 | (dynamic-wind :proceed ,proceed 138 | (let ,(loop for symbol in symbols 139 | for store in stores 140 | collect `(,symbol ,store)) 141 | (declare (special ,@symbols)) 142 | (,proceed ,@body)))))) 143 | #+cx-disable-dynamic-environments 144 | `(let ,(loop for (var form) in bindings 145 | collect `(,(%dynamic-symbol var) ,form)) 146 | ,@body)) 147 | 148 | (defmacro dlet ((&rest bindings) &body body) 149 | `(dynamic-let ,bindings ,@body)) 150 | 151 | (defmacro dynamic-let* ((&rest bindings) &body body) 152 | (if bindings 153 | `(dynamic-let (,(first bindings)) 154 | (dynamic-let* ,(rest bindings) 155 | ,@body)) 156 | `(progn ,@body))) 157 | 158 | (defmacro dlet* ((&rest bindings) &body body) 159 | `(dynamic-let* ,bindings ,@body)) 160 | 161 | (defmacro dynamic-relet ((&rest bindings) &body body) 162 | (assert (and (every #'consp bindings) 163 | (notany #'cddr bindings))) 164 | #-cx-disable-dynamic-environments 165 | (with-unique-names (proceed) 166 | (loop for (var form) in bindings 167 | for symbol = (%dynamic-symbol var) 168 | collect symbol into symbols 169 | collect `(,symbol (make-dbox ,form)) into new-bindings 170 | finally (return 171 | `(dynamic-wind :proceed ,proceed 172 | (let ,new-bindings 173 | (declare (special ,@symbols)) 174 | (,proceed ,@body)))))) 175 | #+cx-disable-dynamic-environments 176 | `(let ,(loop for (var form) in bindings 177 | collect `(,(%dynamic-symbol var) ,form)) 178 | ,@body)) 179 | 180 | (defmacro drelet ((&rest bindings) &body body) 181 | `(dynamic-relet ,bindings ,@body)) 182 | 183 | (defmacro dynamic-relet* ((&rest bindings) &body body) 184 | (if bindings 185 | `(dynamic-relet (,(first bindings)) 186 | (dynamic-relet* ,(rest bindings) 187 | ,@body)) 188 | `(progn ,@body))) 189 | 190 | (defmacro drelet* ((&rest bindings) &body body) 191 | `(dynamic-relet* ,bindings ,@body)) 192 | -------------------------------------------------------------------------------- /test/spx.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | 3 | (in-package :contextl-user) 4 | 5 | (setf (find-class 'test) nil) 6 | 7 | (defclass test () 8 | ((slot0 :initarg :slot0 :special t :reader tslot0) 9 | (slot1 :initarg :slot1 :initform 'foo :special t :allocation :class :reader tslot1)) 10 | (:metaclass special-class)) 11 | 12 | (ensure-finalized (find-class 'test)) 13 | 14 | (assert (eq (tslot1 (class-prototype (find-class 'test))) 'foo)) 15 | 16 | (assert (eq (slot-value (class-prototype (find-class 'test)) 'slot1) 'foo)) 17 | 18 | (defparameter *t* (make-instance 'test :slot0 4711 :slot1 'bar)) 19 | 20 | (assert (eql (tslot0 *t*) 4711)) 21 | 22 | (assert (eql (slot-value *t* 'slot0) 4711)) 23 | 24 | (assert (eq (tslot1 *t*) 'bar)) 25 | 26 | (assert (eq (slot-value *t* 'slot1) 'bar)) 27 | 28 | (assert (eq (tslot1 (class-prototype (find-class 'test))) 'bar)) 29 | 30 | (assert (eq (slot-value (class-prototype (find-class 'test)) 'slot1) 'bar)) 31 | 32 | (reinitialize-instance *t* :slot0 42 :slot1 'baz) 33 | 34 | (assert (eql (tslot0 *t*) 42)) 35 | 36 | (assert (eql (slot-value *t* 'slot0) 42)) 37 | 38 | (assert (eq (tslot1 *t*) 'baz)) 39 | 40 | (assert (eq (slot-value *t* 'slot1) 'baz)) 41 | 42 | (assert (eq (tslot1 (class-prototype (find-class 'test))) 'baz)) 43 | 44 | (assert (eq (slot-value (class-prototype (find-class 'test)) 'slot1) 'baz)) 45 | 46 | 47 | (deflayer test-layer () 48 | ((slot0 :initarg :slot0 :initform 'foo :reader slot0 :special t) 49 | (slot1 :initarg :slot1 :initform 'bar :reader slot1 :special t))) 50 | 51 | (assert (eq (slot0 (find-layer 'test-layer)) 'foo)) 52 | 53 | (assert (eq (slot1 (find-layer 'test-layer)) 'bar)) 54 | 55 | (with-active-layers ((test-layer :slot0 4711)) 56 | (assert (eql (slot0 (find-layer 'test-layer)) 4711)) 57 | (assert (eq (slot1 (find-layer 'test-layer)) 'bar)) 58 | (setf (slot-value (find-layer 'test-layer) 'slot0) 111) 59 | (setf (slot-value (find-layer 'test-layer) 'slot1) 222) 60 | (assert (eql (slot0 (find-layer 'test-layer)) 111)) 61 | (assert (eql (slot1 (find-layer 'test-layer)) 222))) 62 | 63 | (assert (eq (slot0 (find-layer 'test-layer)) 'foo)) 64 | (assert (eql (slot1 (find-layer 'test-layer)) 222)) 65 | 66 | (defparameter *counter* 0) 67 | (defparameter *check-counter* 0) 68 | 69 | (defclass class1 () 70 | ((some-slot :initform (incf *counter*) :reader some-slot)) 71 | (:metaclass singleton-class)) 72 | 73 | (incf *check-counter*) 74 | 75 | (ensure-finalized (find-class 'class1)) 76 | 77 | (assert (eql (some-slot (class-prototype (find-class 'class1))) *check-counter*)) 78 | 79 | (defclass class1 () 80 | ((some-slot :initform (incf *counter*) :reader some-slot)) 81 | (:metaclass singleton-class)) 82 | 83 | #+(or abcl cmu ecl) 84 | (incf *check-counter*) 85 | 86 | (assert (eql (some-slot (class-prototype (find-class 'class1))) *check-counter*)) 87 | 88 | (defclass class1 () 89 | ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t)) 90 | (:metaclass singleton-class)) 91 | 92 | #-(or lispworks6.1 lispworks7 lispworks8) 93 | (incf *check-counter*) 94 | 95 | (assert (eql (some-slot (class-prototype (find-class 'class1))) *check-counter*)) 96 | 97 | (defclass class2 () 98 | ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t)) 99 | (:metaclass singleton-class)) 100 | 101 | #-(or lispworks6.1 lispworks7 lispworks8) 102 | (incf *check-counter*) 103 | #+(or lispworks6.1 lispworks7 lispworks8) 104 | (incf *check-counter* 3) 105 | 106 | (ensure-finalized (find-class 'class2)) 107 | 108 | (assert (eql (some-slot (class-prototype (find-class 'class2))) *check-counter*)) 109 | 110 | (defclass class2 () 111 | ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t)) 112 | (:metaclass singleton-class)) 113 | 114 | #-(or lispworks6.1 lispworks7 lispworks8) 115 | (incf *check-counter*) 116 | 117 | (assert (eql (some-slot (class-prototype (find-class 'class2))) *check-counter*)) 118 | 119 | (defclass class2 () 120 | ((some-slot :initform (incf *counter*) :reader some-slot)) 121 | (:metaclass singleton-class)) 122 | 123 | #+(or abcl cmu ecl) 124 | (incf *check-counter*) 125 | 126 | (assert (eql (some-slot (class-prototype (find-class 'class2))) *check-counter*)) 127 | 128 | (defparameter *counter* 0) 129 | (defparameter *check-counter* 0) 130 | 131 | (deflayer layer1 () 132 | ((some-slot :initform (incf *counter*) :reader some-slot))) 133 | 134 | (incf *check-counter*) 135 | 136 | (assert (eql (some-slot (find-layer 'layer1)) *check-counter*)) 137 | 138 | (deflayer layer1 () 139 | ((some-slot :initform (incf *counter*) :reader some-slot))) 140 | 141 | #+(or abcl cmu ecl) 142 | (incf *check-counter*) 143 | 144 | (assert (eql (some-slot (find-layer 'layer1)) *check-counter*)) 145 | 146 | (deflayer layer1 () 147 | ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t))) 148 | 149 | #-(or lispworks6.1 lispworks7 lispworks8) 150 | (incf *check-counter*) 151 | 152 | (assert (eql (some-slot (find-layer 'layer1)) *check-counter*)) 153 | 154 | (deflayer layer2 () 155 | ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t))) 156 | 157 | #-(or lispworks6.1 lispworks7 lispworks8) 158 | (incf *check-counter*) 159 | #+(or lispworks6.1 lispworks7 lispworks8) 160 | (incf *check-counter* 3) 161 | 162 | (assert (eql (some-slot (find-layer 'layer2)) *check-counter*)) 163 | 164 | (deflayer layer2 () 165 | ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t))) 166 | 167 | #-(or lispworks6.1 lispworks7 lispworks8) 168 | (incf *check-counter*) 169 | 170 | (assert (eql (some-slot (find-layer 'layer2)) *check-counter*)) 171 | 172 | (deflayer layer2 () 173 | ((some-slot :initform (incf *counter*) :reader some-slot))) 174 | 175 | #+(or abcl cmu ecl) 176 | (incf *check-counter*) 177 | 178 | (assert (eql (some-slot (find-layer 'layer2)) *check-counter*)) 179 | 180 | (deflayer layer3 () 181 | ((some-slot :initform (incf *counter*) :reader some-slot :special t))) 182 | 183 | #-(or lispworks6.1 lispworks7 lispworks8) 184 | (incf *check-counter*) 185 | #+(or lispworks6.1 lispworks7 lispworks8) 186 | (incf *check-counter* 3) 187 | 188 | (assert (eql (some-slot (find-layer 'layer3)) *check-counter*)) 189 | 190 | #-cmu 191 | (progn 192 | (deflayer layer3 () 193 | ((some-slot :initform (incf *counter*) :reader some-slot :special t :reinitialize t))) 194 | 195 | #-(or lispworks6.1 lispworks7 lispworks8) 196 | (incf *check-counter*) 197 | 198 | ;(assert (eql (some-slot (find-layer 'layer3)) *check-counter*)) 199 | ) 200 | 201 | (dletf (((some-slot (find-layer 'layer3)) 'foo)) 202 | (assert (eql (some-slot (find-layer 'layer3)) 'foo))) 203 | 204 | (assert (eql (some-slot (find-layer 'layer3)) *check-counter*)) 205 | 206 | (deflayer layer4 () 207 | ((some-slot :initform (incf *counter*) :reader some-slot :special t))) 208 | 209 | #-(or lispworks6.1 lispworks7 lispworks8) 210 | (incf *check-counter*) 211 | #+(or lispworks6.1 lispworks7 lispworks8) 212 | (incf *check-counter* 2) 213 | 214 | (dletf (((some-slot (find-layer 'layer4)) 'bar)) 215 | (assert (eql (some-slot (find-layer 'layer4)) 'bar))) 216 | 217 | (assert (eql (some-slot (find-layer 'layer4)) *check-counter*)) 218 | 219 | (print :done) 220 | -------------------------------------------------------------------------------- /cx-layered-access-class.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defclass layered-access-class (standard-class) 4 | ()) 5 | 6 | (defmethod validate-superclass 7 | ((class layered-access-class) 8 | (superclass standard-class)) 9 | t) 10 | 11 | (defgeneric slot-definition-layeredp (slot) 12 | (:method ((slot slot-definition)) nil)) 13 | 14 | (defclass layered-direct-slot-definition (standard-direct-slot-definition) 15 | ((layeredp :initarg :layered 16 | :initform nil 17 | :reader slot-definition-layeredp) 18 | (layered-readers :initarg :layered-readers 19 | :initform () 20 | :reader slot-definition-layered-readers) 21 | (layered-writers :initarg :layered-writers 22 | :initform () 23 | :reader slot-definition-layered-writers) 24 | (layered-accessor-methods :initform () 25 | :accessor layered-accessor-methods))) 26 | 27 | (defclass layered-effective-slot-definition (standard-effective-slot-definition) 28 | ()) 29 | 30 | (defmethod slot-definition-layeredp ((slot layered-effective-slot-definition)) 31 | t) 32 | 33 | (defmethod direct-slot-definition-class 34 | ((class layered-access-class) &key &allow-other-keys) 35 | (find-class 'layered-direct-slot-definition)) 36 | 37 | (defvar *layered-effective-slot-definition-class*) 38 | 39 | (defmethod effective-slot-definition-class 40 | ((class layered-access-class) &key &allow-other-keys) 41 | (if *layered-effective-slot-definition-class* 42 | *layered-effective-slot-definition-class* 43 | (call-next-method))) 44 | 45 | (defmethod compute-effective-slot-definition 46 | ((class layered-access-class) name direct-slot-definitions) 47 | (declare (ignore name)) 48 | (let ((*layered-effective-slot-definition-class* 49 | (when (some #'slot-definition-layeredp direct-slot-definitions) 50 | (find-class 'layered-effective-slot-definition)))) 51 | (call-next-method))) 52 | 53 | (define-layered-function slot-value-using-layer (class object slot reader) 54 | (:method (class object slot reader) 55 | (declare (ignore class object slot)) 56 | (funcall reader))) 57 | 58 | (defmethod slot-value-using-class :around 59 | ((class layered-access-class) object (slot layered-effective-slot-definition)) 60 | (flet ((reader () (call-next-method))) 61 | (slot-value-using-layer class object slot #'reader))) 62 | 63 | (define-layered-function (setf slot-value-using-layer) (new-value class object slot writer) 64 | (:method (new-value class object slot writer) 65 | (declare (ignore class object slot)) 66 | (funcall writer new-value))) 67 | 68 | (defmethod (setf slot-value-using-class) :around 69 | (new-value (class layered-access-class) object (slot layered-effective-slot-definition)) 70 | (flet ((writer (new-value) (call-next-method new-value class object slot))) 71 | (setf (slot-value-using-layer class object slot #'writer) 72 | new-value))) 73 | 74 | (define-layered-function slot-boundp-using-layer (class object slot reader) 75 | (:method (class object slot reader) 76 | (declare (ignore class object slot)) 77 | (funcall reader))) 78 | 79 | (defmethod slot-boundp-using-class :around 80 | ((class layered-access-class) object (slot layered-effective-slot-definition)) 81 | (flet ((reader () (call-next-method))) 82 | (slot-boundp-using-layer class object slot #'reader))) 83 | 84 | (define-layered-function slot-makunbound-using-layer (class object slot writer) 85 | (:method (class object slot writer) 86 | (declare (ignore class object slot)) 87 | (funcall writer))) 88 | 89 | (defmethod slot-makunbound-using-class :around 90 | ((class layered-access-class) object (slot layered-effective-slot-definition)) 91 | (flet ((writer () (call-next-method))) 92 | (slot-makunbound-using-layer class object slot #'writer))) 93 | 94 | (defgeneric process-layered-access-slot-specification (slot-spec) 95 | (:method ((slot-spec symbol)) slot-spec) 96 | (:method ((slot-spec cons)) 97 | (let ((plist (cdr slot-spec))) 98 | (if (get-properties plist '(:layered-reader :layered-writer :layered-accessor)) 99 | (loop for (key value) on plist by #'cddr 100 | if (eq key :layered-reader) 101 | collect value into layered-readers 102 | else if (eq key :layered-writer) 103 | collect value into layered-writers 104 | else if (eq key :layered-accessor) 105 | collect value into layered-readers 106 | and collect `(setf ,value) into layered-writers 107 | else nconc (list key value) into other-initargs 108 | finally (return (list* (car slot-spec) 109 | :layered-readers layered-readers 110 | :layered-writers layered-writers 111 | other-initargs))) 112 | slot-spec)))) 113 | 114 | (defgeneric add-layered-accessors (class) 115 | (:method ((class layered-access-class)) 116 | (loop with reader-specializers = (list class) 117 | with writer-specializers = (list (find-class 't) class) 118 | for slot in (class-direct-slots class) 119 | for slot-name = (slot-definition-name slot) 120 | for layer = (find-layer-class (slot-definition-layer slot)) do 121 | (loop for layered-reader in (slot-definition-layered-readers slot) 122 | for gf = (ensure-layered-function layered-reader :lambda-list '(object)) 123 | for method = (ensure-layered-method 124 | layered-reader 125 | `(lambda (object) 126 | (declare (optimize (speed 3) (debug 0) (safety 0) 127 | (compilation-speed 0))) 128 | (slot-value object ',slot-name)) 129 | :in-layer layer 130 | :specializers reader-specializers) 131 | do (push (cons gf method) (layered-accessor-methods slot))) 132 | (loop for layered-writer in (slot-definition-layered-writers slot) 133 | for gf = (ensure-layered-function layered-writer 134 | :lambda-list '(new-value object) 135 | :argument-precedence-order '(object new-value)) 136 | for method = (ensure-layered-method 137 | layered-writer 138 | `(lambda (new-value object) 139 | (declare (optimize (speed 3) (debug 0) (safety 0) 140 | (compilation-speed 0))) 141 | (setf (slot-value object ',slot-name) 142 | new-value)) 143 | :in-layer layer 144 | :specializers writer-specializers) 145 | do (push (cons gf method) (layered-accessor-methods slot)))))) 146 | 147 | (defgeneric remove-layered-accessors (class) 148 | (:method ((class layered-access-class)) 149 | (loop for slot in (class-direct-slots class) 150 | do (loop for method in (layered-accessor-methods slot) 151 | do (remove-method (car method) (cdr method)))))) 152 | 153 | (defmethod initialize-instance :after 154 | ((class layered-access-class) &key) 155 | (add-layered-accessors class)) 156 | 157 | (defmethod reinitialize-instance :around 158 | ((class layered-access-class) 159 | &key (direct-slots () direct-slots-p)) 160 | (declare (ignore direct-slots)) 161 | (if direct-slots-p 162 | (progn 163 | (remove-layered-accessors class) 164 | (call-next-method) 165 | (add-layered-accessors class) 166 | class) 167 | (call-next-method))) 168 | -------------------------------------------------------------------------------- /test/demo3.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl :force t) 2 | 3 | (in-package :contextl-user) 4 | 5 | (define-layered-class person () 6 | ((name :initarg :name 7 | :layered-accessor person-name))) 8 | 9 | (define-layered-function display-object (object)) 10 | 11 | (define-layered-method display-object ((object person)) 12 | (print (list 'person :name (person-name object)))) 13 | 14 | (defparameter *pascal* 15 | (make-instance 'person :name 'pascal)) 16 | 17 | (assert (equal (display-object *pascal*) 18 | '(person :name pascal))) 19 | 20 | (deflayer employment-layer) 21 | 22 | (define-layered-class employer 23 | :in employment-layer () 24 | ((name :initarg :name 25 | :layered-accessor employer-name))) 26 | 27 | (define-layered-method display-object 28 | :in employment-layer ((object employer)) 29 | (print (list 'employer :name (employer-name object)))) 30 | 31 | (defparameter *vub* 32 | (make-instance 'employer :name 'vub)) 33 | 34 | (assert (equal (with-active-layers (employment-layer) 35 | (display-object *vub*)) 36 | '(employer :name vub))) 37 | 38 | (define-layered-class person 39 | :in employment-layer () 40 | ((employer :initarg :employer 41 | :layered-accessor person-employer))) 42 | 43 | (define-layered-method display-object 44 | :in employment-layer :around ((object person)) 45 | (append (call-next-method) 46 | (print (list :employer 47 | (display-object (person-employer object)))))) 48 | 49 | (with-active-layers (employment-layer) 50 | (setf (person-employer *pascal*) *vub*)) 51 | 52 | (assert (equal (display-object *pascal*) 53 | '(person :name pascal))) 54 | 55 | (assert (equal (with-active-layers (employment-layer) 56 | (display-object *pascal*)) 57 | '(person :name pascal 58 | :employer (employer :name vub)))) 59 | 60 | (deflayer info-layer) 61 | 62 | (define-layered-class info-mixin 63 | :in info-layer () 64 | ((city :initarg :city 65 | :layered-accessor city))) 66 | 67 | (define-layered-method display-object 68 | :in info-layer :around ((object info-mixin)) 69 | (append (call-next-method) 70 | (print (list :city (city object))))) 71 | 72 | (define-layered-class person 73 | :in info-layer (info-mixin) 74 | ()) 75 | 76 | (define-layered-class employer 77 | :in info-layer (info-mixin) 78 | ()) 79 | 80 | (defparameter *docomo* 81 | (make-instance 'employer 82 | :name 'docomo 83 | :city 'munich)) 84 | 85 | (defparameter *robert* 86 | (make-instance 'person 87 | :name 'robert 88 | :employer *docomo* 89 | :city 'ilmenau)) 90 | 91 | (assert (equal (display-object *robert*) 92 | '(person :name robert))) 93 | 94 | (assert (equal (with-active-layers (employment-layer) 95 | (display-object *robert*)) 96 | '(person :name robert :employer (employer :name docomo)))) 97 | 98 | (assert (equal (with-active-layers (employment-layer info-layer) 99 | (print (display-object *robert*))) 100 | '(person :name robert 101 | :city ilmenau 102 | :employer (employer :name docomo 103 | :city munich)))) 104 | 105 | (assert (equal (with-active-layers (info-layer employment-layer) 106 | (display-object *robert*)) 107 | '(person :name robert 108 | :city ilmenau 109 | :employer (employer :name docomo 110 | :city munich)))) 111 | 112 | (assert (equal (with-active-layers (info-layer employment-layer) 113 | (with-inactive-layers (info-layer) 114 | (display-object *robert*))) 115 | (with-active-layers (employment-layer) 116 | (display-object *robert*)))) 117 | 118 | (assert (equal (with-active-layers (info-layer employment-layer info-layer) 119 | (display-object *robert*)) 120 | (with-active-layers (employment-layer info-layer) 121 | (display-object *robert*)))) 122 | 123 | (deflayer generic-display-layer) 124 | 125 | (define-layered-class displayed-slots-mixin 126 | :in generic-display-layer () 127 | ((displayed-slots :special t 128 | :initform '() 129 | :accessor displayed-slots))) 130 | 131 | (define-layered-class person 132 | :in generic-display-layer 133 | (displayed-slots-mixin) 134 | ()) 135 | 136 | (define-layered-class employer 137 | :in generic-display-layer 138 | (displayed-slots-mixin) 139 | ()) 140 | 141 | (defgeneric generic-display (object)) 142 | 143 | (defmethod generic-display (object) object) 144 | 145 | (defmethod generic-display ((object displayed-slots-mixin)) 146 | (let ((slots (displayed-slots object))) 147 | (if slots 148 | (loop for slot in slots 149 | collect slot 150 | collect (generic-display (slot-value object slot))) 151 | (format t "No slots for display selected.~%")))) 152 | 153 | (assert (equal (with-active-layers (generic-display-layer) 154 | (dletf (((displayed-slots *robert*) '(name employer)) 155 | ((displayed-slots *docomo*) '(name city))) 156 | (generic-display *robert*))) 157 | '(name robert employer (name docomo city munich)))) 158 | 159 | (deflayer slot-access-layer) 160 | 161 | (define-layered-method slot-value-using-layer 162 | :in slot-access-layer (class (object person) slot reader) 163 | (declare (ignorable class slot reader)) 164 | (list* (call-next-method) 165 | (list :slot-access 'successful))) 166 | 167 | (define-layered-class person 168 | :in slot-access-layer () 169 | ((name :layered t))) 170 | 171 | (assert (equal (with-active-layers (generic-display-layer slot-access-layer) 172 | (dletf (((displayed-slots *robert*) '(name employer)) 173 | ((displayed-slots *docomo*) '(name city))) 174 | (print (generic-display *robert*)))) 175 | '(name (robert :slot-access successful) 176 | employer (name docomo city munich)))) 177 | 178 | (define-layered-function test ()) 179 | 180 | (define-layered-method test :in t () 181 | (list 'root-layer)) 182 | 183 | (define-layered-method test :in info-layer () 184 | (list* 'info-layer (call-next-method))) 185 | 186 | (define-layered-method test :in employment-layer () 187 | (list* 'employment-layer (call-next-method))) 188 | 189 | (assert (equal (test) '(root-layer))) 190 | 191 | (assert (equal (with-active-layers (info-layer) 192 | (test)) 193 | '(info-layer root-layer))) 194 | 195 | (assert (equal (with-active-layers (info-layer employment-layer) 196 | (test)) 197 | '(employment-layer info-layer root-layer))) 198 | 199 | (assert (equal (with-active-layers (info-layer employment-layer info-layer) 200 | (test)) 201 | '(employment-layer info-layer root-layer))) 202 | 203 | (assert (equal (with-active-layers (info-layer employment-layer) 204 | (with-inactive-layers (info-layer) 205 | (test))) 206 | '(employment-layer root-layer))) 207 | 208 | (assert (equal (with-active-layers (employment-layer employment-layer) 209 | (test)) 210 | '(employment-layer root-layer))) 211 | 212 | (assert (equal (with-active-layers (info-layer employment-layer) 213 | (with-inactive-layers (employment-layer) 214 | (test))) 215 | '(info-layer root-layer))) 216 | 217 | (multiple-value-bind 218 | (required-parameters lambda-list-keyword) 219 | (contextl::parse-gf-lambda-list '(a b c &rest r)) 220 | (assert (and (equal required-parameters '(a b c)) 221 | lambda-list-keyword))) 222 | 223 | (multiple-value-bind 224 | (required-parameters lambda-list-keyword) 225 | (contextl::parse-gf-lambda-list '(&key r)) 226 | (assert (and (null required-parameters) 227 | lambda-list-keyword))) 228 | 229 | (multiple-value-bind 230 | (required-parameters lambda-list-keyword) 231 | (contextl::parse-gf-lambda-list '(a b c)) 232 | (assert (and (equal required-parameters '(a b c)) 233 | (not lambda-list-keyword)))) 234 | 235 | (multiple-value-bind 236 | (required-parameters lambda-list-keyword) 237 | (contextl::parse-gf-lambda-list '()) 238 | (assert (and (null required-parameters) 239 | (not lambda-list-keyword)))) 240 | 241 | (print :done) 242 | -------------------------------------------------------------------------------- /cx-layer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defclass root-specializer () () 4 | (:metaclass standard-layer-class) 5 | (original-name . t)) 6 | (ensure-finalized (find-class 'root-specializer)) 7 | 8 | #-allegro 9 | (declaim (type layer-context *root-context* *active-context*)) 10 | #+allegro 11 | (eval-when (:load-toplevel :execute) 12 | (proclaim '(type layer-context *root-context* *active-context*))) 13 | 14 | (defvar *root-context* 15 | (make-layer-context 16 | :prototype (class-prototype (find-class 'root-specializer)) 17 | :specializer (find-class 'root-specializer))) 18 | 19 | (defvar *active-context* *root-context*) 20 | 21 | (declaim (inline current-layer-context)) 22 | (defun current-layer-context () *active-context*) 23 | 24 | (declaim (inline (setf current-layer-context))) 25 | (defun (setf current-layer-context) (new-layer-context) 26 | (setf *active-context* new-layer-context)) 27 | 28 | (defun layer-active-p (layer &optional (context *active-context*)) 29 | (subtypep (layer-context-specializer context) 30 | (find-layer-class layer))) 31 | 32 | (defun active-layers (&optional (context *active-context*)) 33 | (loop with result = '() 34 | for context-specializer = (layer-context-specializer context) 35 | then (second (class-direct-superclasses context-specializer)) 36 | until (eq context-specializer (load-time-value (find-class 'root-specializer))) 37 | do (push (find-layer (first (class-direct-superclasses context-specializer))) result) 38 | finally (return (nreverse (cons 't result))))) 39 | 40 | (define-layered-function adjoin-layer-using-class (layer-class active-context) 41 | (:method ((layer-class (eql (find-class 't))) active-context) 42 | (values active-context t)) 43 | (:method ((layer-class standard-layer-class) active-context) 44 | (let ((active-context-specializer (layer-context-specializer active-context))) 45 | (values 46 | (if (subtypep active-context-specializer layer-class) 47 | active-context 48 | (let ((new-specializer 49 | (as-atomic-operation 50 | (ensure-finalized 51 | (make-instance 'standard-layer-class 52 | :direct-superclasses 53 | (list layer-class active-context-specializer)))))) 54 | (make-layer-context 55 | :prototype (class-prototype new-specializer) 56 | :specializer new-specializer))) 57 | t)))) 58 | 59 | (defun safe-adjoin-layer (layer active-context) 60 | (with-lock ((layer-context-lock active-context)) 61 | (or #-cx-threads (getf (layer-context-children/ensure-active active-context) layer) 62 | #-cx-threads (getf (layer-context-children/ensure-active active-context) (layer-name layer)) 63 | (multiple-value-bind 64 | (new-layer-context cacheablep) 65 | (adjoin-layer-using-class (find-layer-class layer) active-context) 66 | (when cacheablep 67 | (setf (layer-context-children/ensure-active active-context) 68 | (list* (or (layer-name layer) layer) new-layer-context 69 | (layer-context-children/ensure-active active-context)))) 70 | new-layer-context)))) 71 | 72 | (declaim (inline adjoin-layer)) 73 | 74 | (defun adjoin-layer (layer active-context) 75 | (declare (optimize (speed 3) (debug 0) (safety 0) 76 | (compilation-speed 0))) 77 | (or (getf (layer-context-children/ensure-active active-context) layer) 78 | (getf (layer-context-children/ensure-active active-context) (layer-name layer)) 79 | (safe-adjoin-layer layer active-context))) 80 | 81 | (defun ensure-active-layer (layer-name) 82 | (setf *active-context* 83 | (locally 84 | (declare (optimize (speed 3) (debug 0) (safety 0) 85 | (compilation-speed 0))) 86 | (adjoin-layer layer-name *active-context*))) 87 | (values)) 88 | 89 | (define-layered-function remove-layer-using-class (layer-class active-context) 90 | (:method ((layer-class (eql (find-class 't))) active-context) 91 | (declare (ignore active-context)) 92 | (error "The layer T may never be removed.")) 93 | (:method ((layer-class standard-layer-class) active-context) 94 | (values 95 | (loop for context-specializer = (layer-context-specializer active-context) 96 | then (second (class-direct-superclasses context-specializer)) 97 | for active-layers = (list (first (class-direct-superclasses context-specializer))) 98 | then (cons (first (class-direct-superclasses context-specializer)) active-layers) 99 | until (eq context-specializer (load-time-value (find-class 'root-specializer))) 100 | finally 101 | (return (loop for new-layer-context = *root-context* 102 | then (if (subtypep active-layer layer-class) 103 | new-layer-context 104 | (adjoin-layer active-layer new-layer-context)) 105 | for active-layer in (cdr active-layers) 106 | finally (return new-layer-context)))) 107 | t))) 108 | 109 | (defun safe-remove-layer (layer active-context) 110 | (with-lock ((layer-context-lock active-context)) 111 | (or #-cx-threads (getf (layer-context-children/ensure-inactive active-context) layer) 112 | #-cx-threads (getf (layer-context-children/ensure-inactive active-context) (layer-name layer)) 113 | (multiple-value-bind 114 | (new-layer-context cacheablep) 115 | (remove-layer-using-class (find-layer-class layer) active-context) 116 | (when cacheablep 117 | (setf (layer-context-children/ensure-inactive active-context) 118 | (list* (or (layer-name layer) layer) new-layer-context 119 | (layer-context-children/ensure-inactive active-context)))) 120 | new-layer-context)))) 121 | 122 | (declaim (inline remove-layer)) 123 | 124 | (defun remove-layer (layer active-context) 125 | (declare (optimize (speed 3) (debug 0) (safety 0) 126 | (compilation-speed 0))) 127 | (or (getf (layer-context-children/ensure-inactive active-context) layer) 128 | (getf (layer-context-children/ensure-inactive active-context) (layer-name layer)) 129 | (safe-remove-layer layer active-context))) 130 | 131 | (defun ensure-inactive-layer (layer-name) 132 | (setf *active-context* 133 | (locally 134 | (declare (optimize (speed 3) (debug 0) (safety 0) 135 | (compilation-speed 0))) 136 | (remove-layer layer-name *active-context*))) 137 | (values)) 138 | 139 | (defmacro %with-active-layers ((&rest layer-names) &body body) 140 | `(let ((*active-context* 141 | (locally 142 | (declare (optimize (speed 3) (debug 0) (safety 0) 143 | (compilation-speed 0))) 144 | ,(loop for form = '*active-context* 145 | then `(adjoin-layer ',layer-name ,form) 146 | for layer-name in layer-names 147 | finally (return form))))) 148 | ,@body)) 149 | 150 | (defmacro with-active-layers ((&rest layer-names) &body body) 151 | (cond ((null layer-names) `(progn ,@body)) 152 | ((every #'atom layer-names) 153 | (with-unique-names (proceed) 154 | `(dynamic-wind :proceed ,proceed 155 | (%with-active-layers ,layer-names (,proceed ,@body))))) 156 | (t `(with-active-layers ,(loop for layer-spec in layer-names 157 | if (atom layer-spec) 158 | collect layer-spec 159 | else collect (car layer-spec)) 160 | (with-special-initargs 161 | ,(loop for layer-spec in layer-names 162 | when (consp layer-spec) 163 | collect `((find-layer ',(car layer-spec)) ,@(cdr layer-spec))) 164 | ,@body))))) 165 | 166 | (defmacro with-active-layers* ((&rest layer-names) &body body) 167 | (cond ((null layer-names) `(progn ,@body)) 168 | ((every #'atom layer-names) 169 | (with-unique-names (proceed) 170 | `(dynamic-wind :proceed ,proceed 171 | (%with-active-layers ,layer-names (,proceed ,@body))))) 172 | (t `(with-active-layers ,(loop for layer-spec in layer-names 173 | if (atom layer-spec) 174 | collect layer-spec 175 | else collect (car layer-spec)) 176 | (with-special-initargs* 177 | ,(loop for layer-spec in layer-names 178 | when (consp layer-spec) 179 | collect `((find-layer ',(car layer-spec)) ,@(cdr layer-spec))) 180 | ,@body))))) 181 | 182 | (defmacro %with-inactive-layers ((&rest layer-names) &body body) 183 | `(let ((*active-context* 184 | (locally 185 | (declare (optimize (speed 3) (debug 0) (safety 0) 186 | (compilation-speed 0))) 187 | ,(loop for form = '*active-context* 188 | then `(remove-layer ',layer-name ,form) 189 | for layer-name in layer-names 190 | finally (return form))))) 191 | ,@body)) 192 | 193 | (defmacro with-inactive-layers ((&rest layer-names) &body body) 194 | (if layer-names 195 | (with-unique-names (proceed) 196 | `(dynamic-wind :proceed ,proceed 197 | (%with-inactive-layers ,layer-names (,proceed ,@body)))) 198 | `(progn ,@body))) 199 | 200 | (defun funcall-with-layer-context (layer-context function &rest args) 201 | (dynamic-wind 202 | (let ((*active-context* layer-context)) 203 | (proceed (apply function args))))) 204 | 205 | (defun apply-with-layer-context (layer-context function &rest args) 206 | (dynamic-wind 207 | (let ((*active-context* layer-context)) 208 | (proceed (apply #'apply function args))))) 209 | -------------------------------------------------------------------------------- /test/dynenv.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :contextl) 2 | 3 | (in-package :contextl-user) 4 | 5 | (let ((symbol (make-dynamic-symbol))) 6 | (assert (dynamic-symbol-p symbol)) 7 | #-cx-disable-dynamic-environments 8 | (assert (not (dynamic-symbol-p (gensym)))) 9 | (assert (not (special-symbol-p symbol))) 10 | (assert (not (dynamic-symbol-boundp symbol))) 11 | (setf (dynamic-symbol-value symbol) 42) 12 | (assert (dynamic-symbol-boundp symbol)) 13 | (assert (eql (dynamic-symbol-value symbol) 42)) 14 | (dynamic-symbol-makunbound symbol) 15 | (assert (not (dynamic-symbol-boundp symbol))) 16 | (assert (handler-case 17 | (progn (dynamic-symbol-value symbol) nil) 18 | (error () t)))) 19 | 20 | (let ((symbol (make-special-symbol))) 21 | (assert (dynamic-symbol-p symbol)) 22 | (assert (special-symbol-p symbol)) 23 | (assert (not (special-symbol-p (gensym)))) 24 | (assert (not (dynamic-symbol-boundp symbol))) 25 | (setf (dynamic-symbol-value symbol) 42) 26 | (assert (dynamic-symbol-boundp symbol)) 27 | (assert (eql (dynamic-symbol-value symbol) 42)) 28 | (dynamic-symbol-makunbound symbol) 29 | (assert (not (dynamic-symbol-boundp symbol))) 30 | (assert (handler-case 31 | (progn (dynamic-symbol-value symbol) nil) 32 | (error () t)))) 33 | 34 | #-cx-disable-dynamic-environments 35 | (progn 36 | (defdynamic x 0) 37 | (defdynamic y 0) 38 | (defdynamic z 0) 39 | 40 | (defdynamic env 41 | (dynamic-let ((x 1) (y 2) (z 3)) 42 | (capture-dynamic-environment))) 43 | 44 | (assert (and (zerop (dynamic x)) 45 | (zerop (dynamic y)) 46 | (zerop (dynamic z)))) 47 | 48 | (assert (equal (with-dynamic-environment ((dynamic env)) 49 | (list (dynamic x) (dynamic y) (dynamic z))) 50 | '(1 2 3))) 51 | 52 | (assert (and (zerop (dynamic x)) 53 | (zerop (dynamic y)) 54 | (zerop (dynamic z)))) 55 | 56 | (assert (equal (with-dynamic-environment ((dynamic env)) 57 | (list (incf (dynamic x)) (incf (dynamic y)) (incf (dynamic z)))) 58 | '(2 3 4))) 59 | 60 | (assert (equal (with-dynamic-environment ((dynamic env)) 61 | (list (dynamic x) (dynamic y) (dynamic z))) 62 | '(2 3 4))) 63 | 64 | (setf (dynamic env) 65 | (dynamic-let ((x 1)) 66 | (with-dynamic-mark (mark) 67 | (dynamic-let ((y 2)) 68 | (capture-dynamic-environment mark))))) 69 | 70 | (assert (with-dynamic-environment ((dynamic env)) 71 | (and (zerop (dynamic x)) 72 | (eql (dynamic y) 2)))) 73 | 74 | (defvar *mark*) 75 | 76 | (defun bam () 77 | (capture-dynamic-environment *mark*)) 78 | 79 | (defun baz () 80 | (dynamic-let ((y 4)) 81 | (bam))) 82 | 83 | (defun bar () 84 | (with-dynamic-mark (*mark*) 85 | (baz))) 86 | 87 | (defun foo () 88 | (dynamic-let ((x 3)) 89 | (bar))) 90 | 91 | (setf (dynamic env) (foo)) 92 | 93 | (assert (with-dynamic-environment ((dynamic env)) 94 | (and (zerop (dynamic x)) 95 | (eql (dynamic y) 4)))) 96 | 97 | (setf (dynamic env) 98 | (dynamic-let ((x 10)) 99 | (with-dynamic-mark (mark1) 100 | (dynamic-let ((y 11)) 101 | (with-dynamic-mark (mark2) 102 | (dynamic-let ((z 12)) 103 | (list (capture-dynamic-environment mark1) 104 | (capture-dynamic-environment mark2)))))))) 105 | 106 | (assert (with-dynamic-environment ((first (dynamic env))) 107 | (and (zerop (dynamic x)) 108 | (eql (dynamic y) 11) 109 | (eql (dynamic z) 12)))) 110 | 111 | (assert (with-dynamic-environment ((second (dynamic env))) 112 | (and (zerop (dynamic x)) 113 | (zerop (dynamic y)) 114 | (eql (dynamic z) 12)))) 115 | 116 | (setf (dynamic x) '(1 2 3)) 117 | 118 | (setf (dynamic env) 119 | (dynamic-relet ((x (list* 'a 'b 'c (dynamic x)))) 120 | (capture-dynamic-environment))) 121 | 122 | (assert (dynamic-let ((x '(d e f))) 123 | (with-dynamic-environment ((dynamic env)) 124 | (equal (dynamic x) '(a b c d e f))))) 125 | 126 | (defclass dummy () 127 | ((x :special t :accessor x) 128 | (y :special t :accessor y) 129 | (z :special t :accessor z)) 130 | (:metaclass special-class)) 131 | 132 | (defparameter obj (make-instance 'dummy)) 133 | 134 | (setf (dynamic env) 135 | (dletf (((x obj) 1) 136 | ((y obj) 2) 137 | ((z obj) 3)) 138 | (capture-dynamic-environment))) 139 | 140 | (assert (not (or (slot-boundp obj 'x) 141 | (slot-boundp obj 'y) 142 | (slot-boundp obj 'z)))) 143 | 144 | (assert (equal (with-dynamic-environment ((dynamic env)) 145 | (list (x obj) (y obj) (z obj))) 146 | '(1 2 3))) 147 | 148 | (assert (not (or (slot-boundp obj 'x) 149 | (slot-boundp obj 'y) 150 | (slot-boundp obj 'z)))) 151 | 152 | (assert (equal (with-dynamic-environment ((dynamic env)) 153 | (list (incf (x obj)) (incf (y obj)) (incf (z obj)))) 154 | '(2 3 4))) 155 | 156 | (assert (equal (with-dynamic-environment ((dynamic env)) 157 | (list (x obj) (y obj) (z obj))) 158 | '(2 3 4))) 159 | 160 | (setf (dynamic env) 161 | (dletf (((x obj) 1)) 162 | (with-dynamic-mark (mark) 163 | (dletf (((y obj) 2)) 164 | (capture-dynamic-environment mark))))) 165 | 166 | (assert (with-dynamic-environment ((dynamic env)) 167 | (and (not (slot-boundp obj 'x)) 168 | (eql (y obj) 2)))) 169 | 170 | (defun bam1 () 171 | (capture-dynamic-environment *mark*)) 172 | 173 | (defun baz1 () 174 | (dletf (((y obj) 4)) 175 | (bam1))) 176 | 177 | (defun bar1 () 178 | (with-dynamic-mark (*mark*) 179 | (baz1))) 180 | 181 | (defun foo1 () 182 | (dletf (((x obj) 3)) 183 | (bar1))) 184 | 185 | (setf (dynamic env) (foo1)) 186 | 187 | (assert (with-dynamic-environment ((dynamic env)) 188 | (and (not (slot-boundp obj 'x)) 189 | (eql (y obj) 4)))) 190 | 191 | (setf (dynamic env) 192 | (dletf (((x obj) 10)) 193 | (with-dynamic-mark (mark1) 194 | (dletf (((y obj) 11)) 195 | (with-dynamic-mark (mark2) 196 | (dletf (((z obj) 12)) 197 | (list (capture-dynamic-environment mark1) 198 | (capture-dynamic-environment mark2)))))))) 199 | 200 | (assert (with-dynamic-environment ((first (dynamic env))) 201 | (and (not (slot-boundp obj 'x)) 202 | (eql (y obj) 11) 203 | (eql (z obj) 12)))) 204 | 205 | (assert (with-dynamic-environment ((second (dynamic env))) 206 | (and (not (slot-boundp obj 'x)) 207 | (not (slot-boundp obj 'y)) 208 | (eql (z obj) 12)))) 209 | 210 | (setf (dynamic env) 211 | (dletf* (((x obj) 1) 212 | ((y obj) (+ (x obj) (x obj))) 213 | ((z obj) (+ (y obj) (y obj)))) 214 | (capture-dynamic-environment))) 215 | 216 | (assert (equal (with-dynamic-environment ((dynamic env)) 217 | (list (x obj) (y obj) (z obj))) 218 | '(1 2 4))) 219 | 220 | (setf (x obj) '(1 2 3)) 221 | 222 | (setf (dynamic env) 223 | (dreletf (((x obj) (list* 'a 'b 'c (x obj)))) 224 | (capture-dynamic-environment))) 225 | 226 | (assert (dreletf (((x obj) '(d e f))) 227 | (with-dynamic-environment ((dynamic env)) 228 | (equal (x obj) '(a b c d e f))))) 229 | 230 | (deflayer l1) 231 | (deflayer l2) 232 | (deflayer l3) 233 | 234 | (setf (dynamic env) 235 | (with-active-layers (l1 l2 l3) 236 | (assert (equal (mapcar #'layer-name (active-layers)) '(l3 l2 l1 t))) 237 | (capture-dynamic-environment))) 238 | 239 | (assert (equal (with-dynamic-environment ((dynamic env)) 240 | (mapcar #'layer-name (active-layers))) 241 | '(l3 l2 l1 t))) 242 | 243 | (setf (dynamic env) 244 | (with-active-layers (l1 l2 l3) 245 | (with-dynamic-mark (mark) 246 | (with-inactive-layers (l1 l3) 247 | (list (capture-dynamic-environment) 248 | (capture-dynamic-environment mark)))))) 249 | 250 | (assert (equal (with-dynamic-environment ((first (dynamic env))) 251 | (mapcar #'layer-name (active-layers))) 252 | '(l2 t))) 253 | 254 | (assert (equal (with-dynamic-environment ((second (dynamic env))) 255 | (mapcar #'layer-name (active-layers))) 256 | '(t))) 257 | 258 | (assert (equal (with-active-layers (l3 l2 l1) 259 | (with-dynamic-environment ((second (dynamic env))) 260 | (mapcar #'layer-name (active-layers)))) 261 | '(l2 t))) 262 | 263 | (assert (equal (with-active-layers (l1 l2 l3 t) 264 | (with-dynamic-environment ((second (dynamic env))) 265 | (with-active-layers (l1) 266 | (mapcar #'layer-name (active-layers))))) 267 | '(l1 l2 t))) 268 | 269 | (setf (dynamic env) 270 | (dynamic-wind 271 | (handler-case 272 | (proceed (capture-dynamic-environment)) 273 | (error () (print "error caught correctly") t)))) 274 | 275 | (assert (with-dynamic-environment ((dynamic env)) 276 | (error "This is an error."))) 277 | 278 | (defdynamic xxx nil) 279 | 280 | (defparameter *y* 281 | (dlet ((xxx 1)) 282 | (capture-dynamic-environment))) 283 | 284 | (assert (eql (with-dynamic-environment (*y*) 285 | (dynamic xxx)) 286 | 1)) 287 | 288 | (defparameter *x* 289 | (with-dynamic-environment (*y*) 290 | (capture-dynamic-environment))) 291 | 292 | (assert (eql (with-dynamic-environment (*x*) 293 | (dynamic xxx)) 294 | 1)) 295 | 296 | #+lispworks5 297 | (print "This part of the test suite currently doesn't run on LispWorks 5.x.") 298 | 299 | #-lispworks5 300 | (progn 301 | (deflayer l5 () 302 | ((x :initarg :x :accessor x) 303 | (y :initarg :y :accessor y))) 304 | 305 | (setf (dynamic env) 306 | (with-active-layers ((l5 :x 5 :y 8)) 307 | (capture-dynamic-environment))) 308 | 309 | (assert (equal (with-dynamic-environment ((dynamic env)) 310 | (list (mapcar #'layer-name (active-layers)) 311 | (x (find-layer 'l5)) 312 | (y (find-layer 'l5)))) 313 | '((l5 t) 5 8))) 314 | 315 | (setf (dynamic env) (with-active-layers* ((l5 :x 5) (l5 :y (* 2 (x (find-layer 'l5))))) 316 | (capture-dynamic-environment))) 317 | 318 | (assert (equal (with-dynamic-environment ((dynamic env)) 319 | (list (mapcar #'layer-name (active-layers)) 320 | (x (find-layer 'l5)) 321 | (y (find-layer 'l5)))) 322 | '((l5 t) 5 10))))) 323 | 324 | #+cx-disable-dynamic-environments 325 | (print "Dynamic environments not supported.") 326 | -------------------------------------------------------------------------------- /cx-special-class.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | (defclass special-object (standard-object) 4 | ()) 5 | 6 | (defclass special-class (standard-class) 7 | (old-slot-definitions 8 | #+cx-threads 9 | (lock :initform (make-lock :name "special class lock") :reader special-class-lock)) 10 | (:default-initargs :direct-superclasses (list (find-class 'special-object)))) 11 | 12 | (defmethod validate-superclass 13 | ((class special-class) 14 | (superclass standard-class)) 15 | t) 16 | 17 | (defmethod initialize-instance :around 18 | ((class special-class) &rest initargs 19 | &key direct-superclasses) 20 | (if (loop for superclass in direct-superclasses 21 | thereis (subclassp superclass 'special-object)) 22 | (call-next-method) 23 | (apply #'call-next-method class 24 | :direct-superclasses 25 | (append direct-superclasses 26 | (list (find-class 'special-object))) 27 | initargs))) 28 | 29 | (defmethod reinitialize-instance :around 30 | ((class special-class) &rest initargs 31 | &key (direct-superclasses () direct-superclasses-p)) 32 | (if direct-superclasses-p 33 | (if (loop for superclass in direct-superclasses 34 | thereis (subclassp superclass 'special-object)) 35 | (call-next-method) 36 | (apply #'call-next-method class 37 | :direct-superclasses 38 | (append direct-superclasses 39 | (list (find-class 'special-object))) 40 | initargs)) 41 | (call-next-method))) 42 | 43 | (defgeneric slot-definition-specialp (slot) 44 | (:method ((slot slot-definition)) nil)) 45 | 46 | (defclass special-direct-slot-definition (standard-direct-slot-definition) 47 | ((specialp :initarg :special 48 | :initform nil 49 | :reader slot-definition-specialp))) 50 | 51 | (defclass special-effective-slot-definition (standard-effective-slot-definition) 52 | ()) 53 | 54 | (defmethod slot-definition-specialp ((slot special-effective-slot-definition)) 55 | t) 56 | 57 | (defmethod direct-slot-definition-class 58 | ((class special-class) &key &allow-other-keys) 59 | (find-class 'special-direct-slot-definition)) 60 | 61 | (defvar *special-effective-slot-definition-class*) 62 | 63 | (defmethod effective-slot-definition-class 64 | ((class special-class) &key &allow-other-keys) 65 | (if *special-effective-slot-definition-class* 66 | *special-effective-slot-definition-class* 67 | (call-next-method))) 68 | 69 | (defmethod compute-effective-slot-definition 70 | ((class special-class) name direct-slot-definitions) 71 | (declare (ignore name)) 72 | (let ((*special-effective-slot-definition-class* 73 | (when (some #'slot-definition-specialp direct-slot-definitions) 74 | (find-class 'special-effective-slot-definition)))) 75 | (call-next-method))) 76 | 77 | (defun shift-slot (object slot-name) 78 | (with-symbol-access 79 | (let ((slot-value (slot-value object slot-name))) 80 | (unless (special-symbol-p slot-value) 81 | (slot-makunbound object slot-name) 82 | (without-symbol-access 83 | (setf (slot-value object slot-name) slot-value)))))) 84 | 85 | #| 86 | Note on thread safety: All special slots are initialized in shared-initialize. 87 | This means that outside of object initialization, slot-value and slot-boundp 88 | don't have any side effects, only potentially during object (re)initialization. 89 | |# 90 | 91 | (defmethod shared-initialize ((object special-object) slot-names &rest all-keys) 92 | (without-symbol-access 93 | (let ((class-slots (class-slots (class-of object)))) 94 | (loop for slot in class-slots do 95 | (when (and (typep slot 'special-effective-slot-definition) 96 | (not (eq (slot-definition-allocation slot) :class))) 97 | (shift-slot object (slot-definition-name slot))) 98 | (when-let (slot-initargs (slot-definition-initargs slot)) 99 | (multiple-value-bind 100 | (indicator value) 101 | (get-properties all-keys slot-initargs) 102 | (when indicator 103 | (setf (slot-value object (slot-definition-name slot)) value))))) 104 | (if (eq slot-names 't) 105 | (loop for slot in class-slots 106 | for slot-name = (slot-definition-name slot) 107 | unless (slot-boundp object slot-name) do 108 | (when-let (slot-initfunction (slot-definition-initfunction slot)) 109 | (setf (slot-value object slot-name) (funcall slot-initfunction)))) 110 | (loop for slot-name in slot-names 111 | unless (slot-boundp object slot-name) do 112 | (let ((slot (find slot-name class-slots :key #'slot-definition-name))) 113 | (when-let (slot-initfunction (slot-definition-initfunction slot)) 114 | (setf (slot-value object slot-name) (funcall slot-initfunction)))))))) 115 | object) 116 | 117 | (defmethod slot-unbound ((class special-class) object slot-name) 118 | (declare (optimize (speed 3) (debug 0) (safety 0) 119 | (compilation-speed 0))) 120 | (if *symbol-access* 121 | (let ((slot (find slot-name (the list (class-slots class)) 122 | :test #'eq 123 | :key #'slot-definition-name))) 124 | (if (typep slot 'special-effective-slot-definition) 125 | (setf (slot-value-using-class class object slot) 126 | (make-special-symbol)) 127 | (call-next-method))) 128 | (call-next-method))) 129 | 130 | (defmethod slot-value-using-class 131 | ((class special-class) object (slot special-effective-slot-definition)) 132 | (declare (optimize (speed 3) (debug 0) (safety 0) 133 | (compilation-speed 0))) 134 | (if *symbol-access* (call-next-method) 135 | (let ((slot-symbol (with-symbol-access (call-next-method)))) 136 | (declare (type symbol slot-symbol)) 137 | (if (dynamic-symbol-boundp slot-symbol) 138 | (dynamic-symbol-value slot-symbol) 139 | (slot-unbound class object (slot-definition-name slot)))))) 140 | 141 | (defmethod (setf slot-value-using-class) 142 | (new-value (class special-class) object (slot special-effective-slot-definition)) 143 | (declare (optimize (speed 3) (debug 0) (safety 0) 144 | (compilation-speed 0))) 145 | (if *symbol-access* (call-next-method) 146 | (let ((slot-symbol (with-symbol-access (slot-value-using-class class object slot)))) 147 | (setf (dynamic-symbol-value (the symbol slot-symbol)) new-value)))) 148 | 149 | (defmethod slot-boundp-using-class 150 | ((class special-class) object (slot special-effective-slot-definition)) 151 | (declare (optimize (speed 3) (debug 0) (safety 0) 152 | (compilation-speed 0))) 153 | (if *symbol-access* (call-next-method) 154 | (let ((slot-symbol (with-symbol-access (slot-value-using-class class object slot)))) 155 | (dynamic-symbol-boundp (the symbol slot-symbol))))) 156 | 157 | (defmethod slot-makunbound-using-class 158 | ((class special-class) object (slot special-effective-slot-definition)) 159 | (declare (optimize (speed 3) (debug 0) (safety 0) 160 | (compilation-speed 0))) 161 | (if *symbol-access* (call-next-method) 162 | (let ((slot-symbol (with-symbol-access (slot-value-using-class class object slot)))) 163 | (dynamic-symbol-makunbound (the symbol slot-symbol)) 164 | object))) 165 | 166 | #+(or allegro lispworks) 167 | (defmethod make-instances-obsolete :after ((class special-class)) 168 | (mapc #'make-instances-obsolete (class-direct-subclasses class))) 169 | 170 | #+cx-threads 171 | (defmethod finalize-inheritance :around ((class special-class)) 172 | (with-lock ((special-class-lock class)) (call-next-method))) 173 | 174 | (defmethod compute-slots :before ((class special-class)) 175 | (when (class-finalized-p class) 176 | (unless (slot-boundp class 'old-slot-definitions) 177 | (setf (slot-value class 'old-slot-definitions) 178 | (class-slots class))))) 179 | 180 | #+cmu 181 | (defmethod reinitialize-instance :after 182 | ((class special-class) &key) 183 | (finalize-inheritance class)) 184 | 185 | (defmethod finalize-inheritance :after 186 | ((class special-class)) 187 | "ensure that special slots remain special after class redefinition 188 | (there is no protocol for collapsing multiple values in different 189 | dynamic scopes for the same special slot); make instances obsolete 190 | when non-special slots have been turned into special slots" 191 | (when (slot-boundp class 'old-slot-definitions) 192 | (assert (loop for old-slot in (slot-value class 'old-slot-definitions) 193 | for new-slot = (find (slot-definition-name old-slot) 194 | (class-slots class) 195 | :test #'eq 196 | :key #'slot-definition-name) 197 | always 198 | #+(and allegro (not (version>= 7 0))) 199 | (cond ((null new-slot) t) 200 | (t (eql (typep old-slot 'special-effective-slot-definition) 201 | (typep new-slot 'special-effective-slot-definition)))) 202 | #-(and allegro (not (version>= 7 0))) 203 | (cond ((null new-slot) t) 204 | ((typep old-slot 'special-effective-slot-definition) 205 | (typep new-slot 'special-effective-slot-definition)) 206 | (t (when (typep new-slot 'special-effective-slot-definition) 207 | (make-instances-obsolete class)) 208 | t))) 209 | () 210 | #+(and allegro (not (version>= 7 0))) 211 | "The (non-)special slots in class ~S must remain (non-)special." 212 | #-(and allegro (not (version>= 7 0))) 213 | "The special slots in class ~S must remain special." 214 | (class-name class)) 215 | (slot-makunbound class 'old-slot-definitions)) 216 | 217 | (loop with prototype = (class-prototype class) 218 | for slot in (class-slots class) 219 | when (and (typep slot 'special-effective-slot-definition) 220 | (eq (slot-definition-allocation slot) :class)) 221 | do (shift-slot prototype (slot-definition-name slot)))) 222 | 223 | (defun funcall-with-special-initargs (bindings thunk) 224 | (special-symbol-progv 225 | (loop for (object . initargs) in bindings 226 | for initarg-keys = (loop for key in initargs by #'cddr collect key) 227 | nconc (loop for slot in (class-slots (class-of object)) 228 | when (and (slot-definition-specialp slot) 229 | (intersection initarg-keys (slot-definition-initargs slot))) 230 | collect (with-symbol-access 231 | (slot-value object (slot-definition-name slot))))) 232 | '() 233 | (loop for (object . initargs) in bindings 234 | do (apply #'shared-initialize object nil :allow-other-keys t initargs)) 235 | (funcall thunk))) 236 | 237 | (defmacro with-special-initargs ((&rest bindings) &body body) 238 | `(funcall-with-special-initargs 239 | (list ,@(loop for binding in bindings 240 | collect `(list ,@binding))) 241 | (lambda () ,@body))) 242 | 243 | (defmacro with-special-initargs* ((&rest bindings) &body body) 244 | (if bindings 245 | `(with-special-initargs (,(car bindings)) 246 | (with-special-initargs* (,@(cdr bindings)) 247 | ,@body)) 248 | `(progn ,@body))) 249 | --------------------------------------------------------------------------------