contextl_0.61/000755 000765 000765 00000000000 11325601122 015232 5ustar00costanza_costanza000000 000000 contextl_0.61/contextl-packages.lisp000644 000765 000765 00000007013 11325601122 021540 0ustar00costanza_costanza000000 000000 (in-package :cl-user) (defpackage #:contextl #+lispworks5 (:import-from #:system #:with-hash-table-locked) #+lispworks6 (:import-from #:hcl #:with-hash-table-locked) (:use #:closer-common-lisp #:lispworks) (:export #:*symbol-access* #:active-layers #:adjoin-layer #:adjoin-layer-using-class #:apply-with-layer-context #:call-next-layered-method #:call-with-dynamic-environment #:capture-dynamic-environment #:class-layer #:clear-layer-caches #:current-layer-context #:defdynamic #:define-layered-class #:define-layered-function #:define-layered-method #:deflayer #:dlet #:dlet* #:dletf #:dletf* #:drelet #:drelet* #:dreletf #:dreletf* #:dynamic #:dynamic-environment #:dynamic-let #:dynamic-let* #:dynamic-mark #:dynamic-progv #:dynamic-relet #:dynamic-relet* #:dynamic-reprogv #:dynamic-symbol #:dynamic-symbol-boundp #:dynamic-symbol-makunbound #:dynamic-symbol-p #:dynamic-symbol-value #:dynamic-wind #:ensure-active-layer #:ensure-inactive-layer #:ensure-layer #:ensure-layered-function #:ensure-layered-method #:find-layer #:find-layer-class #:find-singleton #:funcall-with-layer-context #:layer-active-p #:layer-makunbound #:layer-name #:layered-access-class #:layered-class #:layered-direct-slot-definition #:layered-effective-slot-definition #:layered-effective-slot-definition-in-layers #:layered-function #:layered-function-argument-precedence-order #:layered-function-definer #:layered-function-lambda-list #:layered-method #:layered-method-lambda-list #:layered-method-layer #:layered-method-specializers #:lfmakunbound #:make-dynamic-symbol #:make-special-symbol #:partial-class #:partial-class-defining-classes #:partial-class-defining-metaclass #:partial-object #:proceed #:remove-layer #:remove-layer-using-class #:set-dynamic #:singleton-class #:slot-definition-layer #:slot-definition-layered-readers #:slot-definition-layered-writers #:slot-definition-layeredp #:slot-definition-layers #:slot-definition-specialp #:slot-boundp-using-layer #:slot-makunbound-using-layer #:slot-value-using-layer #:safe-special-symbol-progv #:special-class #:special-direct-slot-definition #:special-effective-slot-definition #:special-effective-slot-definition-in-layers #:special-layered-access-class #:special-layered-direct-slot-definition #:special-layered-effective-slot-definition #:special-object #:special-symbol-p #:special-symbol-progv #:special-symbol-reprogv #:standard-class-in-layer #:standard-direct-slot-definition-in-layer #:standard-effective-slot-definition-in-layers #:standard-layer-class #:standard-layer-object #:with-active-layers #:with-active-layers* #:with-dynamic-environment #:with-dynamic-mark #:with-inactive-layers #:with-special-initargs #:with-special-initargs* #:with-symbol-access #:without-symbol-access)) (defpackage #:contextl-common-lisp (:nicknames #:cxcl) (:use #:closer-common-lisp #:contextl) #.`(:export ,@(loop for sym being the external-symbols of :closer-common-lisp collect sym) ,@(loop for sym being the external-symbols of :contextl collect sym))) (defpackage #:contextl-user (:use #:contextl-common-lisp) (:nicknames #:cx-user)) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :dynamic-wind *features*) (pushnew :contextl *features*)) contextl_0.61/contextl.asd000644 000765 000765 00000007002 11325601122 017562 0ustar00costanza_costanza000000 000000 #| Configuration flags (can be added to *features* before compiling ContextL): :cx-disable-dynamic-environments disables dynamic-wind / proceed functionality (and avoids the incurred overhead) :cx-fast-special-symbol-progv avoids the added check for special symbols (not necessary for correct semantics, only for added safety during development) :cx-disable-layer-gc disables the garbage collector for layers (only interesting if you redefine layers and related generic functions at runtime, should not have a serious effect on runtime performance) |# ;(push :cx-disable-dynamic-environments cl:*features*) ;(push :cx-fast-special-symbol-progv cl:*features*) ;(push :cx-disable-layer-gc cl:*features*) #+scl (eval-when (:compile-toplevel :load-toplevel :execute) (error "ContextL is currently not supported in Scieneer Common Lisp.")) (asdf:defsystem #:contextl :name "ContextL" :author "Pascal Costanza" :version "0.61" :licence " Copyright (c) 2005 - 2010 Pascal Costanza Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the \"Software\"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. " :depends-on (#:closer-mop #-lispworks #:lw-compat) :components ((:file "contextl-packages") (:file "cx-threads" :depends-on ("contextl-packages")) (:file "cx-util" :depends-on ("contextl-packages" "cx-threads")) (:file "cx-dynamic-environments" :depends-on ("contextl-packages")) (:file "cx-dynamic-variables" :depends-on ("contextl-packages" "cx-dynamic-environments" "cx-threads")) (:file "cx-dynascope" :depends-on ("contextl-packages" "cx-dynamic-variables")) (:file "cx-special-class" :depends-on ("cx-dynascope")) (:file "cx-singleton-class" :depends-on ("contextl-packages" "cx-util")) (:file "cx-layered-function-macros" :depends-on ("contextl-packages" "cx-util")) (:file "cx-layer-metaclasses" :depends-on ("cx-special-class" "cx-singleton-class" "cx-threads" "cx-util")) (:file "cx-gc" :depends-on ("cx-layer-metaclasses" "cx-layered-function-macros" "cx-threads")) (:file "cx-layer" :depends-on ("cx-layer-metaclasses" "cx-layered-function-macros" "cx-gc" "cx-util" "cx-threads")) (:file "cx-partial-class" :depends-on ("cx-layer")) (:file "cx-class-in-layer" :depends-on ("cx-layer")) (:file "cx-layered-function" :depends-on ("cx-layer" "cx-util")) (:file "cx-layered-access-class" :depends-on ("cx-layered-function")) (:file "cx-layered-class" :depends-on ("cx-layered-access-class" "cx-partial-class")))) contextl_0.61/cx-class-in-layer.lisp000644 000765 000765 00000005327 11325601122 021365 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defgeneric class-layer (class) (:method ((class class)) 't)) (defclass standard-class-in-layer (standard-class) ((layer :initarg :in-layer :initarg :in :initform 't :reader class-layer))) (defmethod validate-superclass ((class standard-class-in-layer) (superclass standard-class)) t) (defgeneric slot-definition-layer (slot) (:method ((slot direct-slot-definition)) 't)) (defclass standard-direct-slot-definition-in-layer (standard-direct-slot-definition) ((layer :initarg :in-layer :initarg :in :initform 't :reader slot-definition-layer))) (defmethod direct-slot-definition-class ((class standard-class-in-layer) &key &allow-other-keys) (find-class 'standard-direct-slot-definition-in-layer)) (defgeneric slot-definition-layers (slot) (:method ((slot effective-slot-definition)) '(t))) (defclass standard-effective-slot-definition-in-layers (standard-effective-slot-definition) ((layers :initform '(t) :reader slot-definition-layers))) (defmethod effective-slot-definition-class ((class standard-class-in-layer) &key &allow-other-keys) (find-class 'standard-effective-slot-definition-in-layers)) (defmethod compute-effective-slot-definition ((class standard-class-in-layer) name direct-slot-definitions) (declare (ignore name)) (let ((slot (call-next-method))) (setf (slot-value slot 'layers) (loop for direct-slot in direct-slot-definitions for layer = (slot-definition-layer direct-slot) for layer-name = (or (layer-name layer) layer) for layers = (list layer-name) then (adjoin layer-name layers :test #'eq) finally (return layers))) slot)) (defmethod initialize-instance :around ((class standard-class-in-layer) &rest initargs &key (direct-slots ()) (in-layer 't)) (declare (dynamic-extent initargs)) (apply #'call-next-method class :direct-slots (loop for direct-slot in direct-slots if (get-properties direct-slot '(:in-layer :in)) collect direct-slot else collect (list* :in-layer in-layer direct-slot)) initargs)) (defmethod reinitialize-instance :around ((class standard-class-in-layer) &rest initargs &key (direct-slots () direct-slots-p) (in-layer 't)) (declare (dynamic-extent initargs)) (if direct-slots-p (apply #'call-next-method class :direct-slots (loop for direct-slot in direct-slots if (get-properties direct-slot '(:in-layer :in)) collect direct-slot else collect (list* :in-layer in-layer direct-slot)) initargs) (call-next-method))) contextl_0.61/cx-dynamic-environments.lisp000644 000765 000765 00000005771 11325601122 022716 0ustar00costanza_costanza000000 000000 (in-package :contextl) #-cx-disable-dynamic-environments (defvar *dynamic-wind-stack* '()) (defstruct (dynamic-mark (:constructor make-dynamic-mark (name))) (name nil :read-only t)) (defmacro with-dynamic-mark ((mark-variable) &body body) (let ((mark (gensym))) `(let* ((,mark (make-dynamic-mark ',mark-variable)) #-cx-disable-dynamic-environments (*dynamic-wind-stack* (cons ,mark *dynamic-wind-stack*)) (,mark-variable ,mark)) ,@body))) (defmacro dynamic-wind (&body body) (let ((proceed-name (cond ((eq (first body) :proceed) (pop body) (pop body)) (t 'proceed)))) (assert (symbolp proceed-name) (proceed-name)) #-cx-disable-dynamic-environments (with-unique-names (dynamic-wind-thunk proceed-thunk proceed-body) `(flet ((,dynamic-wind-thunk (,proceed-thunk) (macrolet ((,proceed-name (&body ,proceed-body) `(if ,',proceed-thunk (funcall (the function ,',proceed-thunk)) (progn ,@,proceed-body)))) ,@body))) (declare (inline ,dynamic-wind-thunk)) (let ((*dynamic-wind-stack* (cons #',dynamic-wind-thunk *dynamic-wind-stack*))) (,dynamic-wind-thunk nil)))) #+cx-disable-dynamic-environments (with-unique-names (proceed-body) `(macrolet ((,proceed-name (&body ,proceed-body) `(progn ,@,proceed-body))) ,@body)))) #-cx-disable-dynamic-environments (progn (defclass dynamic-environment () ((dynamic-winds :initarg :dynamic-winds :reader dynamic-winds))) (defun capture-dynamic-environment (&optional mark) (make-instance 'dynamic-environment :dynamic-winds (loop with dynamic-winds = '() for entry in *dynamic-wind-stack* if (functionp entry) do (push entry dynamic-winds) else if (eq entry mark) return dynamic-winds finally (return dynamic-winds)))) (defgeneric call-with-dynamic-environment (environment thunk) (:method ((environment dynamic-environment) (thunk function)) (declare (optimize (speed 3) (space 3) (debug 0) (safety 0) (compilation-speed 0))) (labels ((perform-calls (environment thunk) (cond (environment (assert (consp environment)) (let ((function (first environment))) (assert (functionp function)) (let ((*dynamic-wind-stack* (cons function *dynamic-wind-stack*))) (funcall function (lambda () (perform-calls (rest environment) thunk)))))) (t (funcall thunk))))) (perform-calls (dynamic-winds environment) thunk)))) (defmacro with-dynamic-environment ((environment) &body body) `(call-with-dynamic-environment ,environment (lambda () ,@body)))) contextl_0.61/cx-dynamic-variables.lisp000644 000765 000765 00000014227 11325601122 022133 0ustar00costanza_costanza000000 000000 (in-package :contextl) #-cx-disable-dynamic-environments (progn (defvar %unbound '%unbound) (defstruct (dbox (:constructor make-dbox (value))) value) (defmethod print-object ((object dbox) stream) (print-unreadable-object (object stream :type t :identity t) (princ (dbox-value object))))) (defvar *dynamic-symbol* (make-symbol-mapper 'dynamic-symbol)) (defun make-dynamic-symbol (&optional (x "DYNAMIC-SYMBOL-")) #-cx-disable-dynamic-environments (let ((symbol (gensym x))) (setf (symbol-value symbol) (make-dbox %unbound)) symbol) #+cx-disable-dynamic-environments (gensym x)) (defun dynamic-symbol (symbol) (map-symbol *dynamic-symbol* symbol #-cx-disable-dynamic-environments #'make-dynamic-symbol)) (declaim (inline dynamic-symbol-p)) (defun dynamic-symbol-p (symbol) #-cx-disable-dynamic-environments (and (symbolp symbol) (boundp symbol) (dbox-p (symbol-value symbol))) #+cx-disable-dynamic-environments (symbolp symbol)) (declaim (inline dynamic-symbol-value (setf dynamic-symbol-value) dynamic-symbol-boundp dynamic-symbol-makunbound)) (defun dynamic-symbol-value (symbol) #-cx-disable-dynamic-environments (let ((value (dbox-value (symbol-value symbol)))) (if (eq value %unbound) (error 'unbound-variable :name symbol) value)) #+cx-disable-dynamic-environments (symbol-value symbol)) (defun (setf dynamic-symbol-value) (value symbol) #-cx-disable-dynamic-environments (setf (dbox-value (symbol-value symbol)) value) #+cx-disable-dynamic-environments (setf (symbol-value symbol) value)) (defun dynamic-symbol-boundp (symbol) #-cx-disable-dynamic-environments (not (eq (dbox-value (symbol-value symbol)) %unbound)) #+cx-disable-dynamic-environments (boundp symbol)) (defun dynamic-symbol-makunbound (symbol) #-cx-disable-dynamic-environments (setf (dbox-value (symbol-value symbol)) %unbound) #+cx-disable-dynamic-environments (makunbound symbol)) #-cx-disable-dynamic-environments (progn (declaim (inline compute-bindings)) (defun compute-bindings (symbols values) (loop for nil in symbols if values collect (make-dbox (pop values)) else collect (make-dbox %unbound)))) (defmacro dynamic-progv (symbols values &body body) #-cx-disable-dynamic-environments (with-unique-names (fixed-symbols fixed-bindings proceed) `(let* ((,fixed-symbols ,symbols) (,fixed-bindings (compute-bindings ,fixed-symbols ,values))) (dynamic-wind :proceed ,proceed (progv ,fixed-symbols ,fixed-bindings (,proceed ,@body))))) #+cx-disable-dynamic-environments `(progv ,symbols ,values ,@body)) (defmacro dynamic-reprogv (symbols values &body body) #-cx-disable-dynamic-environments (with-unique-names (computed-symbols computed-bindings proceed) `(dynamic-wind :proceed ,proceed (let* ((,computed-symbols ,symbols) (,computed-bindings (compute-bindings ,computed-symbols ,values))) (progv ,computed-symbols ,computed-bindings (,proceed ,@body))))) #+cx-disable-dynamic-environments `(progv ,symbols ,values ,@body)) (declaim (inline %dynamic-symbol)) (defun %dynamic-symbol (symbol) (map-symbol *dynamic-symbol* symbol)) (defmacro defdynamic (name &body form) (assert (and (consp form) (null (cdr form)))) `(progn (defparameter ,(%dynamic-symbol name) #-cx-disable-dynamic-environments (make-dbox ,@form) #+cx-disable-dynamic-environments ,@form) ',name)) (defmacro dynamic (var) #-cx-disable-dynamic-environments `(dbox-value ,(%dynamic-symbol var)) #+cx-disable-dynamic-environments (%dynamic-symbol var)) (defmacro set-dynamic (form var) `(setf (dynamic ,var) ,form)) (defmacro dynamic-let ((&rest bindings) &body body) (assert (and (every #'consp bindings) (notany #'cddr bindings))) #-cx-disable-dynamic-environments (loop with proceed = (gensym) for (var form) in bindings collect (copy-symbol var) into stores collect (%dynamic-symbol var) into symbols collect form into forms finally (return `(let ,(loop for store in stores for form in forms collect `(,store (make-dbox ,form))) (dynamic-wind :proceed ,proceed (let ,(loop for symbol in symbols for store in stores collect `(,symbol ,store)) (declare (special ,@symbols)) (,proceed ,@body)))))) #+cx-disable-dynamic-environments `(let ,(loop for (var form) in bindings collect `(,(%dynamic-symbol var) ,form)) ,@body)) (defmacro dlet ((&rest bindings) &body body) `(dynamic-let ,bindings ,@body)) (defmacro dynamic-let* ((&rest bindings) &body body) (if bindings `(dynamic-let (,(first bindings)) (dynamic-let* ,(rest bindings) ,@body)) `(progn ,@body))) (defmacro dlet* ((&rest bindings) &body body) `(dynamic-let* ,bindings ,@body)) (defmacro dynamic-relet ((&rest bindings) &body body) (assert (and (every #'consp bindings) (notany #'cddr bindings))) #-cx-disable-dynamic-environments (with-unique-names (proceed) (loop for (var form) in bindings for symbol = (%dynamic-symbol var) collect symbol into symbols collect `(,symbol (make-dbox ,form)) into new-bindings finally (return `(dynamic-wind :proceed ,proceed (let ,new-bindings (declare (special ,@symbols)) (,proceed ,@body)))))) #+cx-disable-dynamic-environments `(let ,(loop for (var form) in bindings collect `(,(%dynamic-symbol var) ,form)) ,@body)) (defmacro drelet ((&rest bindings) &body body) `(dynamic-relet ,bindings ,@body)) (defmacro dynamic-relet* ((&rest bindings) &body body) (if bindings `(dynamic-relet (,(first bindings)) (dynamic-relet* ,(rest bindings) ,@body)) `(progn ,@body))) (defmacro drelet* ((&rest bindings) &body body) `(dynamic-relet* ,bindings ,@body)) contextl_0.61/cx-dynascope.lisp000644 000765 000765 00000014421 11325601122 020522 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defun make-special-symbol () "creates a fresh unique special symbol" (let ((symbol (make-dynamic-symbol "SPECIAL-SYMBOL-"))) (setf (get symbol 'specialp) t) symbol)) (declaim (inline special-symbol-p)) (defun special-symbol-p (symbol) "checks whether a symbol is special, as created by make-special-symbol" (and #-cx-fast-special-symbol-progv (dynamic-symbol-p symbol) #+cx-fast-special-symbol-progv (symbolp symbol) (get symbol 'specialp))) (defvar *symbol-access* nil "set/get a place's special symbol instead of its symbol value when this is set to a non-nil value") (defmacro with-symbol-access (&body body) "executes body in an environment with *symbol-access* set to t" `(let ((*symbol-access* t)) ,@body)) (defmacro without-symbol-access (&body body) "executes body in an environment with *symbol-access* set to nil" `(let ((*symbol-access* nil)) ,@body)) (defun prepare-binding (binding env) "ensure that a binding form is 'well-formed' to ease further processing" (when (symbolp binding) (setf binding (list binding nil))) (assert (null (cddr binding)) () "Bad initialization form: ~S." binding) `(,(macroexpand (car binding) env) ,@(cdr binding))) (define-symbol-macro safe-special-symbol-progv #-cx-fast-special-symbol-progv t #+cx-fast-special-symbol-progv nil) ;; redefine this to nil to get more efficient code, ;; either globally via define-symbol-macro, ;; or locally via symbol-macrolet (defmacro special-symbol-progv (symbols values &body body &environment env) "like dynamic-progv, only that symbols must all be special symbols" (if (macroexpand 'safe-special-symbol-progv env) (with-unique-names (symbol-list retry) `(let (,symbol-list) (tagbody ,retry (setq ,symbol-list ,symbols) (unless (every #'special-symbol-p ,symbol-list) (cerror "Retry to rebind the place(s)." "Attempt at rebinding one or more non-special places: ~S" ',symbols) (go ,retry))) (dynamic-progv ,symbol-list ,values ,@body))) `(dynamic-progv ,symbols ,values ,@body))) (defmacro special-symbol-reprogv (symbols values &body body &environment env) "like dynamic-reprogv, only that symbols must all be special symbols" (if (macroexpand 'safe-special-symbol-progv env) (with-unique-names (symbol-list retry) `(let (,symbol-list) (tagbody ,retry (setq ,symbol-list ,symbols) (unless (every #'special-symbol-p ,symbol-list) (cerror "Retry to rebind the place(s)." "Attempt at rebinding one or more non-special places: ~S" ',symbols) (go ,retry))) (dynamic-reprogv ,symbol-list ,values ,@body))) `(dynamic-reprogv ,symbols ,values ,@body))) (defmacro dletf* (bindings &body body &environment env) "sequentially bind places to new values with dynamic scope, and execute body in that new dynamic environment" (loop for form = `(progn ,@body) then (etypecase (car binding) (symbol `(dlet (,binding) ,form)) (cons `(special-symbol-progv (list (with-symbol-access ,(car binding))) (list ,(cadr binding)) ,form))) for binding in (reverse bindings) do (setf binding (prepare-binding binding env)) finally (return form))) (defmacro dreletf* (bindings &body body &environment env) "sequentially bind places to new values with dynamic scope, and execute body in that new dynamic environment" (loop for form = `(progn ,@body) then (etypecase (car binding) (symbol `(dreletf (,binding) ,form)) (cons (with-unique-names (symbol-store) `(let ((,symbol-store (list (with-symbol-access ,(car binding))))) (special-symbol-reprogv ,symbol-store (list ,(cadr binding)) ,form))))) for binding in (reverse bindings) do (setf binding (prepare-binding binding env)) finally (return form))) (defmacro dletf (bindings &body body &environment env) "bind places to new values with dynamic scope in parallel, and execute body in that new dynamic environment" (loop for binding in bindings do (setf binding (prepare-binding binding env)) collect (if (symbolp (car binding)) `',(%dynamic-symbol (car binding)) (car binding)) into symbol-forms when (symbolp (car binding)) collect (car binding) into variables collect (cadr binding) into value-forms finally (return `(special-symbol-progv (with-symbol-access (list ,@symbol-forms)) (list ,@value-forms) (locally (declare (special ,@variables)) ,@body))))) (defmacro dreletf (bindings &body body &environment env) "bind places to new values with dynamic scope in parallel, and execute body in that new dynamic environment" (loop for binding in bindings do (setf binding (prepare-binding binding env)) collect (if (symbolp (car binding)) `',(%dynamic-symbol (car binding)) (car binding)) into symbol-forms when (symbolp (car binding)) collect (car binding) into variables collect (cadr binding) into value-forms finally (return (with-unique-names (symbol-store) `(let ((,symbol-store (with-symbol-access (list ,@symbol-forms)))) (special-symbol-reprogv ,symbol-store (list ,@value-forms) (locally (declare (special ,@variables)) ,@body))))))) contextl_0.61/cx-gc.lisp000644 000765 000765 00000010227 11325601122 017126 0ustar00costanza_costanza000000 000000 (in-package :contextl) #-cx-disable-layer-gc (progn (defun all-layer-contexts () (let ((result '())) (labels ((collect (layer-context) (declare (type layer-context layer-context)) (when (member layer-context result :test #'eq) (return-from collect)) (push layer-context result) (loop for (nil child) on (layer-context-children/ensure-active layer-context) by #'cddr do (collect child)) (loop for (nil child) on (layer-context-children/ensure-inactive layer-context) by #'cddr do (collect child)))) (when (boundp '*root-context*) (collect (symbol-value '*root-context*)) result)))) (defun clear-layer-active-caches (test &optional (all-layer-contexts (all-layer-contexts))) (loop for layer-context in all-layer-contexts do (with-lock ((layer-context-lock layer-context)) (setf (layer-context-children/ensure-active layer-context) (loop for (key child) on (layer-context-children/ensure-active layer-context) by #'cddr unless (funcall test key) nconc (list key child)))))) (defun clear-layer-inactive-caches (test &optional (all-layer-contexts (all-layer-contexts))) (loop for layer-context in all-layer-contexts do (with-lock ((layer-context-lock layer-context)) (setf (layer-context-children/ensure-inactive layer-context) (loop for (key child) on (layer-context-children/ensure-inactive layer-context) by #'cddr unless (funcall test key) nconc (list key child)))))) (defgeneric clear-layer-context-caches (layer) (:method ((layer symbol)) (clear-layer-context-caches (find-layer-class layer))) (:method ((layer standard-layer-object)) (clear-layer-context-caches (find-layer-class layer))) (:method ((layer-class cl:class)) (let ((all-layer-contexts (all-layer-contexts)) (test (lambda (key) (subtypep (find-layer-class key) layer-class)))) (clear-layer-active-caches test all-layer-contexts) (clear-layer-inactive-caches test all-layer-contexts)))) (defun clear-layer-caches () (let ((all-layer-contexts (all-layer-contexts))) (loop for layer-context in all-layer-contexts do (with-lock ((layer-context-lock layer-context)) (setf (layer-context-children/ensure-active layer-context) '() (layer-context-children/ensure-inactive layer-context) '()))))) (defmethod reinitialize-instance :after ((class standard-layer-class) &rest initargs) (declare (ignore initargs)) (clear-layer-context-caches class)) (defgeneric clear-activation-method-caches (gf method) (:method (gf method) (declare (ignore gf method)) nil) (:method ((gf (eql (lf-definer-name 'adjoin-layer-using-class))) method) (let ((layer-specializer (first (layered-method-specializers method)))) (if (typep layer-specializer 'eql-specializer) (let ((eql-specializer-object (eql-specializer-object layer-specializer))) (clear-layer-active-caches (lambda (key) (eql (find-layer-class key) eql-specializer-object)))) (clear-layer-active-caches (lambda (key) (typep (find-layer-class key) layer-specializer)))))) (:method ((gf (eql (lf-definer-name 'remove-layer-using-class))) method) (let ((layer-specializer (first (layered-method-specializers method)))) (if (typep layer-specializer 'eql-specializer) (let ((eql-specializer-object (eql-specializer-object layer-specializer))) (clear-layer-inactive-caches (lambda (key) (eql (find-layer-class key) eql-specializer-object)))) (clear-layer-inactive-caches (lambda (key) (typep (find-layer-class key) layer-specializer))))))) (defmethod add-method :after ((gf layered-function) (method layered-method)) (clear-activation-method-caches (generic-function-name gf) method)) (defmethod remove-method :after ((gf layered-function) (method layered-method)) (clear-activation-method-caches (generic-function-name gf) method))) contextl_0.61/cx-layer-metaclasses.lisp000644 000765 000765 00000013441 11325601122 022154 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defclass standard-layer-object (special-object) ()) (defgeneric layer-name (layer) (:method ((layer symbol)) layer) (:method ((layer (eql (find-class 't)))) 't) (:method ((layer standard-layer-object)) (layer-name (class-of layer)))) (defclass standard-layer-class (special-class singleton-class) ((layer-name :initarg original-name :initform nil :reader layer-name)) (:default-initargs :direct-superclasses (list (find-class 'standard-layer-object)))) (defmethod validate-superclass ((class standard-layer-class) (superclass standard-class)) t) (defmethod print-object ((object standard-layer-object) stream) (print-unreadable-object (object stream :type nil :identity t) (format stream "LAYER ~A" (layer-name object)))) (defmethod print-object ((object standard-layer-class) stream) (print-unreadable-object (object stream :type t :identity t) (princ (layer-name object) stream))) (defmethod initialize-instance :around ((class standard-layer-class) &rest initargs &key direct-superclasses) (declare (dynamic-extent initargs)) (if (loop for direct-superclass in direct-superclasses thereis (subclassp direct-superclass 'standard-layer-object)) (call-next-method) (apply #'call-next-method class :direct-superclasses (append direct-superclasses (list (find-class 'standard-layer-object))) initargs))) (defmethod reinitialize-instance :around ((class standard-layer-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) (declare (dynamic-extent initargs)) (if (or (not direct-superclasses-p) (loop for direct-superclass in direct-superclasses thereis (subclassp direct-superclass 'standard-layer-object))) (call-next-method) (apply #'call-next-method class :direct-superclasses (append direct-superclasses (list (find-class 'standard-layer-object))) initargs))) (defclass layer-direct-slot-definition (singleton-direct-slot-definition special-direct-slot-definition) ()) (defmethod direct-slot-definition-class ((class standard-layer-class) &key) (find-class 'layer-direct-slot-definition)) (defmacro deflayer (name &optional superlayers &body options) (destructuring-bind (&optional slots &rest options) options `(defclass ,(defining-layer name) ,(mapcar #'defining-layer superlayers) ,(if slots slots '()) ,@options ,@(unless (assoc :metaclass options) '((:metaclass standard-layer-class))) (original-name . ,name)))) (defun ensure-layer (layer-name &rest initargs &key (metaclass 'standard-layer-class) &allow-other-keys) (declare (dynamic-extent initargs)) (apply #'ensure-class (defining-layer layer-name) :metaclass metaclass 'original-name layer-name initargs)) (defgeneric find-layer-class (layer &optional errorp environment) (:method ((layer (eql 't)) &optional errorp environment) (declare (ignore errorp environment)) (load-time-value (find-class 't))) (:method ((layer (eql (find-class 't))) &optional errorp environment) (declare (ignore errorp environment)) (load-time-value (find-class 't))) (:method ((layer symbol) &optional (errorp t) environment) (or (find-class (defining-layer layer) nil environment) (when errorp (cerror "Retry finding the layer." "There is no layer named ~S." layer) (find-layer-class layer errorp environment)))) (:method ((layer standard-layer-object) &optional errorp environment) (declare (ignore errorp environment)) (class-of layer)) (:method ((layer standard-layer-class) &optional errorp environment) (declare (ignore errorp environment)) layer)) (defgeneric find-layer (layer &optional errorp environment) (:method ((layer (eql 't)) &optional errorp environment) (declare (ignore errorp environment)) 't) (:method ((layer (eql (find-class 't))) &optional errorp environment) (declare (ignore errorp environment)) 't) (:method ((layer symbol) &optional (errorp t) environment) (let ((layer-class (find-layer-class layer errorp environment))) (when layer-class #-lispworks (ensure-finalized layer-class) (class-prototype layer-class)))) (:method ((layer standard-layer-object) &optional errorp environment) (declare (ignore errorp environment)) layer) (:method ((layer standard-layer-class) &optional errorp environment) (declare (ignore errorp environment)) #-lispworks (ensure-finalized layer) (class-prototype layer))) (defgeneric layer-makunbound (layer) (:method ((layer symbol)) (let* ((defining-layer (defining-layer layer)) (class (find-class defining-layer))) (setf (find-class defining-layer) nil (class-name class) nil))) (:method ((layer standard-layer-object)) (let* ((class-name (class-name (class-of layer))) (class (find-class class-name))) (setf (find-class class-name) nil (class-name class) nil))) (:method ((layer standard-layer-class)) (let* ((class-name (class-name layer)) (class (find-class class-name))) (setf (find-class class-name) nil (class-name class) nil)))) (defstruct layer-context (prototype (error "No layer-context-prototype specified.") :type standard-object :read-only t) (specializer (error "No layer-context-specializer specified.") :type standard-layer-class :read-only t) (children/ensure-active '() :type list) (children/ensure-inactive '() :type list) (lock (make-lock :name "layer context") :read-only t)) contextl_0.61/cx-layer.lisp000644 000765 000765 00000022165 11325601122 017655 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defclass root-specializer () () (:metaclass standard-layer-class) (original-name . t)) (ensure-finalized (find-class 'root-specializer)) #-allegro (declaim (type layer-context *root-context* *active-context*)) #+allegro (eval-when (:load-toplevel :execute) (proclaim '(type layer-context *root-context* *active-context*))) (defvar *root-context* (make-layer-context :prototype (class-prototype (find-class 'root-specializer)) :specializer (find-class 'root-specializer))) (defvar *active-context* *root-context*) (declaim (inline current-layer-context)) (defun current-layer-context () *active-context*) (declaim (inline (setf current-layer-context))) (defun (setf current-layer-context) (new-layer-context) (setf *active-context* new-layer-context)) (defun layer-active-p (layer &optional (context *active-context*)) (subtypep (layer-context-specializer context) (find-layer-class layer))) (defun active-layers (&optional (context *active-context*)) (loop with result = '() for context-specializer = (layer-context-specializer context) then (second (class-direct-superclasses context-specializer)) until (eq context-specializer (load-time-value (find-class 'root-specializer))) do (push (find-layer (first (class-direct-superclasses context-specializer))) result) finally (return (nreverse (cons 't result))))) (define-layered-function adjoin-layer-using-class (layer-class active-context) (:method ((layer-class (eql (find-class 't))) active-context) (values active-context t)) (:method ((layer-class standard-layer-class) active-context) (let ((active-context-specializer (layer-context-specializer active-context))) (values (if (subtypep active-context-specializer layer-class) active-context (let ((new-specializer (as-atomic-operation (ensure-finalized (make-instance 'standard-layer-class :direct-superclasses (list layer-class active-context-specializer)))))) (make-layer-context :prototype (class-prototype new-specializer) :specializer new-specializer))) t)))) (defun safe-adjoin-layer (layer active-context) (with-lock ((layer-context-lock active-context)) (or #-cx-threads (getf (layer-context-children/ensure-active active-context) layer) #-cx-threads (getf (layer-context-children/ensure-active active-context) (layer-name layer)) (multiple-value-bind (new-layer-context cacheablep) (adjoin-layer-using-class (find-layer-class layer) active-context) (when cacheablep (setf (layer-context-children/ensure-active active-context) (list* (or (layer-name layer) layer) new-layer-context (layer-context-children/ensure-active active-context)))) new-layer-context)))) (declaim (inline adjoin-layer)) (defun adjoin-layer (layer active-context) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (or (getf (layer-context-children/ensure-active active-context) layer) (getf (layer-context-children/ensure-active active-context) (layer-name layer)) (safe-adjoin-layer layer active-context))) (defun ensure-active-layer (layer-name) (setf *active-context* (locally (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (adjoin-layer layer-name *active-context*))) (values)) (define-layered-function remove-layer-using-class (layer-class active-context) (:method ((layer-class (eql (find-class 't))) active-context) (declare (ignore active-context)) (error "The layer T may never be removed.")) (:method ((layer-class standard-layer-class) active-context) (values (loop for context-specializer = (layer-context-specializer active-context) then (second (class-direct-superclasses context-specializer)) for active-layers = (list (first (class-direct-superclasses context-specializer))) then (cons (first (class-direct-superclasses context-specializer)) active-layers) until (eq context-specializer (load-time-value (find-class 'root-specializer))) finally (return (loop for new-layer-context = *root-context* then (if (subtypep active-layer layer-class) new-layer-context (adjoin-layer active-layer new-layer-context)) for active-layer in (cdr active-layers) finally (return new-layer-context)))) t))) (defun safe-remove-layer (layer active-context) (with-lock ((layer-context-lock active-context)) (or #-cx-threads (getf (layer-context-children/ensure-inactive active-context) layer) #-cx-threads (getf (layer-context-children/ensure-inactive active-context) (layer-name layer)) (multiple-value-bind (new-layer-context cacheablep) (remove-layer-using-class (find-layer-class layer) active-context) (when cacheablep (setf (layer-context-children/ensure-inactive active-context) (list* (or (layer-name layer) layer) new-layer-context (layer-context-children/ensure-inactive active-context)))) new-layer-context)))) (declaim (inline remove-layer)) (defun remove-layer (layer active-context) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (or (getf (layer-context-children/ensure-inactive active-context) layer) (getf (layer-context-children/ensure-inactive active-context) (layer-name layer)) (safe-remove-layer layer active-context))) (defun ensure-inactive-layer (layer-name) (setf *active-context* (locally (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (remove-layer layer-name *active-context*))) (values)) (defmacro %with-active-layers ((&rest layer-names) &body body) `(let ((*active-context* (locally (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) ,(loop for form = '*active-context* then `(adjoin-layer ',layer-name ,form) for layer-name in layer-names finally (return form))))) ,@body)) (defmacro with-active-layers ((&rest layer-names) &body body) (cond ((null layer-names) `(progn ,@body)) ((every #'atom layer-names) (with-unique-names (proceed) `(dynamic-wind :proceed ,proceed (%with-active-layers ,layer-names (,proceed ,@body))))) (t `(with-active-layers ,(loop for layer-spec in layer-names if (atom layer-spec) collect layer-spec else collect (car layer-spec)) (with-special-initargs ,(loop for layer-spec in layer-names when (consp layer-spec) collect `((find-layer ',(car layer-spec)) ,@(cdr layer-spec))) ,@body))))) (defmacro with-active-layers* ((&rest layer-names) &body body) (cond ((null layer-names) `(progn ,@body)) ((every #'atom layer-names) (with-unique-names (proceed) `(dynamic-wind :proceed ,proceed (%with-active-layers ,layer-names (,proceed ,@body))))) (t `(with-active-layers ,(loop for layer-spec in layer-names if (atom layer-spec) collect layer-spec else collect (car layer-spec)) (with-special-initargs* ,(loop for layer-spec in layer-names when (consp layer-spec) collect `((find-layer ',(car layer-spec)) ,@(cdr layer-spec))) ,@body))))) (defmacro %with-inactive-layers ((&rest layer-names) &body body) `(let ((*active-context* (locally (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) ,(loop for form = '*active-context* then `(remove-layer ',layer-name ,form) for layer-name in layer-names finally (return form))))) ,@body)) (defmacro with-inactive-layers ((&rest layer-names) &body body) (if layer-names (with-unique-names (proceed) `(dynamic-wind :proceed ,proceed (%with-inactive-layers ,layer-names (,proceed ,@body)))) `(progn ,@body))) (defun funcall-with-layer-context (layer-context function &rest args) (declare (dynamic-extent args)) (dynamic-wind (let ((*active-context* layer-context)) (proceed (apply function args))))) (defun apply-with-layer-context (layer-context function &rest args) (declare (dynamic-extent args)) (dynamic-wind (let ((*active-context* layer-context)) (proceed (apply #'apply function args))))) contextl_0.61/cx-layered-access-class.lisp000644 000765 000765 00000016104 11325601122 022524 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defclass layered-access-class (standard-class) ()) (defmethod validate-superclass ((class layered-access-class) (superclass standard-class)) t) (defgeneric slot-definition-layeredp (slot) (:method ((slot slot-definition)) nil)) (defclass layered-direct-slot-definition (standard-direct-slot-definition) ((layeredp :initarg :layered :initform nil :reader slot-definition-layeredp) (layered-readers :initarg :layered-readers :initform () :reader slot-definition-layered-readers) (layered-writers :initarg :layered-writers :initform () :reader slot-definition-layered-writers) (layered-accessor-methods :initform () :accessor layered-accessor-methods))) (defclass layered-effective-slot-definition (standard-effective-slot-definition) ()) (defmethod slot-definition-layeredp ((slot layered-effective-slot-definition)) t) (defmethod direct-slot-definition-class ((class layered-access-class) &key &allow-other-keys) (find-class 'layered-direct-slot-definition)) (defvar *layered-effective-slot-definition-class*) (defmethod effective-slot-definition-class ((class layered-access-class) &key &allow-other-keys) (if *layered-effective-slot-definition-class* *layered-effective-slot-definition-class* (call-next-method))) (defmethod compute-effective-slot-definition ((class layered-access-class) name direct-slot-definitions) (declare (ignore name)) (let ((*layered-effective-slot-definition-class* (when (some #'slot-definition-layeredp direct-slot-definitions) (find-class 'layered-effective-slot-definition)))) (call-next-method))) (define-layered-function slot-value-using-layer (class object slot reader) (:method (class object slot reader) (declare (ignore class object slot)) (funcall reader))) (defmethod slot-value-using-class :around ((class layered-access-class) object (slot layered-effective-slot-definition)) (flet ((reader () (call-next-method))) (slot-value-using-layer class object slot #'reader))) (define-layered-function (setf slot-value-using-layer) (new-value class object slot writer) (:method (new-value class object slot writer) (declare (ignore class object slot)) (funcall writer new-value))) (defmethod (setf slot-value-using-class) :around (new-value (class layered-access-class) object (slot layered-effective-slot-definition)) (flet ((writer (new-value) (call-next-method new-value class object slot))) (setf (slot-value-using-layer class object slot #'writer) new-value))) (define-layered-function slot-boundp-using-layer (class object slot reader) (:method (class object slot reader) (declare (ignore class object slot)) (funcall reader))) (defmethod slot-boundp-using-class :around ((class layered-access-class) object (slot layered-effective-slot-definition)) (flet ((reader () (call-next-method))) (slot-boundp-using-layer class object slot #'reader))) (define-layered-function slot-makunbound-using-layer (class object slot writer) (:method (class object slot writer) (declare (ignore class object slot)) (funcall writer))) (defmethod slot-makunbound-using-class :around ((class layered-access-class) object (slot layered-effective-slot-definition)) (flet ((writer () (call-next-method))) (slot-makunbound-using-layer class object slot #'writer))) (defgeneric process-layered-access-slot-specification (slot-spec) (:method ((slot-spec symbol)) slot-spec) (:method ((slot-spec cons)) (let ((plist (cdr slot-spec))) (if (get-properties plist '(:layered-reader :layered-writer :layered-accessor)) (loop for (key value) on plist by #'cddr if (eq key :layered-reader) collect value into layered-readers else if (eq key :layered-writer) collect value into layered-writers else if (eq key :layered-accessor) collect value into layered-readers and collect `(setf ,value) into layered-writers else nconc (list key value) into other-initargs finally (return (list* (car slot-spec) :layered-readers layered-readers :layered-writers layered-writers other-initargs))) slot-spec)))) (defgeneric add-layered-accessors (class) (:method ((class layered-access-class)) (loop with reader-specializers = (list class) with writer-specializers = (list (find-class 't) class) for slot in (class-direct-slots class) for slot-name = (slot-definition-name slot) for layer = (find-layer-class (slot-definition-layer slot)) do (loop for layered-reader in (slot-definition-layered-readers slot) for gf = (ensure-layered-function layered-reader :lambda-list '(object)) for method = (ensure-layered-method layered-reader `(lambda (object) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (slot-value object ',slot-name)) :in-layer layer :specializers reader-specializers) do (push (cons gf method) (layered-accessor-methods slot))) (loop for layered-writer in (slot-definition-layered-writers slot) for gf = (ensure-layered-function layered-writer :lambda-list '(new-value object) :argument-precedence-order '(object new-value)) for method = (ensure-layered-method layered-writer `(lambda (new-value object) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (setf (slot-value object ',slot-name) new-value)) :in-layer layer :specializers writer-specializers) do (push (cons gf method) (layered-accessor-methods slot)))))) (defgeneric remove-layered-accessors (class) (:method ((class layered-access-class)) (loop for slot in (class-direct-slots class) do (loop for method in (layered-accessor-methods slot) do (remove-method (car method) (cdr method)))))) (defmethod initialize-instance :after ((class layered-access-class) &key) (add-layered-accessors class)) (defmethod reinitialize-instance :around ((class layered-access-class) &key (direct-slots () direct-slots-p)) (declare (ignore direct-slots)) (if direct-slots-p (progn (remove-layered-accessors class) (call-next-method) (add-layered-accessors class) class) (call-next-method))) contextl_0.61/cx-layered-class.lisp000644 000765 000765 00000006502 11325601122 021266 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defclass special-layered-access-class (layered-access-class special-class standard-class-in-layer) ()) (defclass special-layered-direct-slot-definition (layered-direct-slot-definition special-direct-slot-definition standard-direct-slot-definition-in-layer) ()) (defclass special-effective-slot-definition-in-layers (special-effective-slot-definition standard-effective-slot-definition-in-layers) ()) (defclass layered-effective-slot-definition-in-layers (layered-effective-slot-definition standard-effective-slot-definition-in-layers) ()) (defclass special-layered-effective-slot-definition (layered-effective-slot-definition-in-layers special-effective-slot-definition-in-layers) ()) (defmethod direct-slot-definition-class ((class special-layered-access-class) &key &allow-other-keys) (find-class 'special-layered-direct-slot-definition)) (defvar *special-layered-effective-slot-definition-class*) (defmethod effective-slot-definition-class ((class special-layered-access-class) &key &allow-other-keys) (if *special-layered-effective-slot-definition-class* *special-layered-effective-slot-definition-class* (call-next-method))) (defmethod compute-effective-slot-definition ((class special-layered-access-class) name direct-slot-definitions) (declare (ignore name)) (let ((*special-layered-effective-slot-definition-class* (if (some #'slot-definition-layeredp direct-slot-definitions) (if (some #'slot-definition-specialp direct-slot-definitions) (find-class 'special-layered-effective-slot-definition) (find-class 'layered-effective-slot-definition-in-layers)) (when (some #'slot-definition-specialp direct-slot-definitions) (find-class 'special-effective-slot-definition-in-layers))))) (call-next-method))) (defclass layered-class (partial-class special-layered-access-class) () (:default-initargs :defining-metaclass 'special-layered-access-class)) #+sbcl (defmethod shared-initialize :after ((class layered-class) slot-names &key defining-metaclass) (declare (ignore slot-names defining-metaclass))) (defmacro define-layered-class (&whole form name &body options) (let* ((layer (if (member (car options) '(:in-layer :in) :test #'eq) (cadr options) t)) (options (cond ((member (car options) '(:in-layer :in) :test #'eq) (cddr options)) ((not (listp (car options))) (error "Illegal option ~S in ~S." (car options) form)) (t options))) (form `(defclass ,name ,(car options) ,(mapcar #'process-layered-access-slot-specification (cadr options)) ,@(cddr options) ,@(unless (assoc :metaclass options) '((:metaclass layered-class))) (:in-layer . ,layer)))) #+allegro (if (eq (find-layer layer nil) 't) form `(excl:without-redefinition-warnings ,form)) #+lispworks (if (eq (find-layer layer nil) 't) form `(let ((dspec:*redefinition-action* :quiet)) ,form)) #-(or allegro lispworks) form)) contextl_0.61/cx-layered-function-macros.lisp000644 000765 000765 00000014105 11325601122 023266 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defun parse-method-body (form body) (let* ((in-layerp (member (car body) '(:in-layer :in) :test #'eq)) (layer-spec (if in-layerp (cadr body) 't))) (when (consp layer-spec) (unless (null (cddr layer-spec)) (error "Incorrect :in-layer specification in ~S." form))) (loop with layer = (if (atom layer-spec) layer-spec (cadr layer-spec)) with layer-arg = (if (atom layer-spec) (gensym "LAYER-ARG-") (car layer-spec)) for tail = (if in-layerp (cddr body) body) then (cdr tail) until (listp (car tail)) collect (car tail) into qualifiers finally (loop for qualifier in qualifiers when (member qualifier '(:in-layer :in) :test #'eq) do (error "Incorrect occurrence of ~S in ~S. Must occur before qualifiers." qualifier form)) (return (values layer-arg layer qualifiers (car tail) (cdr tail)))))) (defun prepare-layer (layer) (if (symbolp layer) (defining-layer layer) layer)) (defun prepare-layered-method-body (name form layer-arg body) (loop for tail = body then (cdr tail) for (first . rest) = tail while tail while (or (and rest (stringp first)) (and (consp first) (eq (car first) 'declare))) count (stringp first) into nof-seen-strings collect first into declarations finally (when (> nof-seen-strings 1) (warn "Too many documentation strings in ~S." form)) (return `(,@declarations (block ,(plain-function-name name) (flet ((call-next-layered-method (&rest args) (declare (dynamic-extent args)) (if args (apply #'call-next-method ,layer-arg args) (call-next-method)))) #-lispworks (declare (inline call-next-layered-method) (ignorable (function call-next-layered-method))) ,@tail)))))) (defun parse-gf-lambda-list (lambda-list) (loop for entry in lambda-list for lambda-list-keyword = (member entry lambda-list-keywords) until lambda-list-keyword collect entry into required-parameters finally (return (values required-parameters lambda-list-keyword)))) (defclass layered-function (standard-generic-function) () (:metaclass funcallable-standard-class) (:default-initargs :method-class (find-class 'layered-method))) (defmethod print-object ((object layered-function) stream) (print-unreadable-object (object stream :type t :identity t) (princ (lf-caller-name (generic-function-name object)) stream))) (defun layered-function-definer (name) (fdefinition (lf-definer-name name))) (defgeneric layered-function-argument-precedence-order (function) (:method ((function layered-function)) (butlast (generic-function-argument-precedence-order function)))) (defgeneric layered-function-lambda-list (function) (:method ((function layered-function)) (rest (generic-function-lambda-list function)))) (defun lfmakunbound (name) (fmakunbound (lf-definer-name name)) (fmakunbound name)) (defclass layered-method (standard-method) ()) (defgeneric layered-method-lambda-list (method) (:method ((method layered-method)) (rest (method-lambda-list method)))) (defgeneric layered-method-specializers (method) (:method ((method layered-method)) (rest (method-specializers method)))) (defmacro define-layered-function (name (&rest args) &body options) (let ((definer (lf-definer-name name))) (with-unique-names (layer-arg rest-arg) `(progn (defgeneric ,definer (,layer-arg ,@args) ,@(unless (member :generic-function-class options :key #'car) '((:generic-function-class layered-function))) (:argument-precedence-order ,@(let ((argument-precedence-order (assoc :argument-precedence-order options))) (if argument-precedence-order (cdr argument-precedence-order) (required-args args))) ,layer-arg) ,@(loop for option in (remove :argument-precedence-order options :key #'car) if (eq (car option) :method) collect (multiple-value-bind (layer-arg layer qualifiers args method-body) (parse-method-body option (cdr option)) `(:method ,@qualifiers ((,layer-arg ,(prepare-layer layer)) ,@args) ,@(prepare-layered-method-body name option layer-arg method-body))) else collect option)) (declaim (inline ,name)) ,(multiple-value-bind (required-parameters lambda-list-keyword) (parse-gf-lambda-list args) (if lambda-list-keyword `(defun ,name (,@required-parameters &rest ,rest-arg) (declare #-clozure (dynamic-extent ,rest-arg) (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (apply #',definer (layer-context-prototype *active-context*) ,@required-parameters ,rest-arg)) `(defun ,name (,@required-parameters) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (funcall #',definer (layer-context-prototype *active-context*) ,@required-parameters)))) (eval-when (:compile-toplevel :load-toplevel :execute) (bind-lf-names ',name)) #',definer)))) (defmacro define-layered-method (&whole form name &body body) (multiple-value-bind (layer-arg layer qualifiers args method-body) (parse-method-body form body) `(defmethod ,(lf-definer-name name) ,@qualifiers ((,layer-arg ,(prepare-layer layer)) ,@args) ,@(prepare-layered-method-body name form layer-arg method-body)))) contextl_0.61/cx-layered-function.lisp000644 000765 000765 00000006505 11325601122 022011 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defun ensure-layered-function (name &rest initargs &key (lambda-list () lambda-list-p) (argument-precedence-order (required-args lambda-list)) (generic-function-class 'layered-function) &allow-other-keys) (declare (dynamic-extent initargs)) (unless lambda-list-p (error "The layered function ~S must be initialized with a lambda list." name)) (let ((gf (let ((layer-arg (gensym "LAYER-ARG-"))) (apply #'ensure-generic-function (lf-definer-name name) :generic-function-class generic-function-class :argument-precedence-order `(,@argument-precedence-order ,layer-arg) :lambda-list `(,layer-arg ,@lambda-list) initargs)))) (setf (fdefinition name) (let ((lambda `(lambda (&rest rest) (declare (dynamic-extent rest) (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (apply (the function ,gf) (layer-context-prototype *active-context*) rest)))) #-ecl (compile nil lambda) #+ecl (coerce lambda 'function))) (bind-lf-names name) gf)) (defun ensure-layered-method (layered-function-designator lambda-expression &key #-(or allegro clisp cmu mcl) (method-class nil method-class-p) (in-layer 't) (qualifiers ()) (lambda-list (cadr lambda-expression)) (specializers (required-args lambda-list (constantly (find-class 't))))) (let ((layered-function (if (functionp layered-function-designator) layered-function-designator (fdefinition (lf-definer-name layered-function-designator)))) (layer-arg (gensym "LAYER-ARG-"))) #-(or allegro clisp cmu mcl) (unless method-class-p (setq method-class (generic-function-method-class layered-function))) (destructuring-bind (lambda (&rest args) &body body) lambda-expression (unless (eq lambda 'lambda) (error "Incorrect lambda expression: ~S." lambda-expression)) (ensure-method layered-function `(lambda (,layer-arg ,@args) ,@body) #-(or allegro clisp cmu mcl) :method-class #-(or allegro clisp cmu mcl) method-class :qualifiers qualifiers :lambda-list `(,layer-arg ,@lambda-list) :specializers (cons (find-layer-class in-layer) specializers))))) (defgeneric layered-method-layer (method) (:method ((method layered-method)) (find-layer (first (method-specializers method))))) (defmethod print-object ((object layered-method) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~A ~A ~S ~A" (when (method-generic-function object) (lf-caller-name (generic-function-name (method-generic-function object)))) (layered-method-layer object) (method-qualifiers object) (layered-method-specializers object)))) contextl_0.61/cx-partial-class.lisp000644 000765 000765 00000007226 11325601122 021301 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defclass partial-object (standard-object) () (:default-initargs :allow-other-keys t)) (defclass partial-class (standard-class) ((defining-classes :initarg defining-classes :reader partial-class-defining-classes) (defining-metaclass :initarg :defining-metaclass :reader partial-class-defining-metaclass))) (defmethod validate-superclass ((class partial-class) (superclass standard-class)) t) (defmethod validate-superclass ((class standard-class) (superclass partial-class)) t) #+allegro (defmethod finalize-inheritance :after ((class partial-class)) (mapc #'finalize-inheritance (rest (class-precedence-list class)))) (defmethod initialize-instance :around ((class partial-class) &rest initargs &key name (in-layer 't in-layer-p) (in 't in-p) (defining-metaclass 'standard-class)) (declare (dynamic-extent initargs)) (assert (not (and in-layer-p in-p))) (let* ((in-layer (if in-layer-p in-layer in)) (in-layer-name (or (layer-name in-layer) (find-layer in-layer))) (direct-superclasses (list (find-class 'partial-object))) (defining-classes ())) (let ((defined-class (apply #'make-instance defining-metaclass (loop for (key value) on initargs by #'cddr unless (member key '(:name :defining-metaclass)) nconc (list key value))))) (push defined-class direct-superclasses) (setf (getf defining-classes in-layer-name) defined-class)) (unless (eq in-layer-name 't) (let ((defined-class (make-instance defining-metaclass))) (push defined-class direct-superclasses) (setf (getf defining-classes 't) defined-class))) (call-next-method class :name name :direct-superclasses direct-superclasses 'defining-classes defining-classes :defining-metaclass defining-metaclass))) (defmethod reinitialize-instance :around ((class partial-class) &rest initargs &key (in-layer 't in-layer-p) (in 't in-p) (defining-metaclass (partial-class-defining-metaclass class) defining-metaclass-p)) (declare (dynamic-extent initargs)) (assert (not (and in-layer-p in-p))) (let* ((in-layer (if in-layer-p in-layer in)) (in-layer-name (or (layer-name in-layer) (find-layer in-layer)))) (let ((defined-class (getf (partial-class-defining-classes class) in-layer-name))) (if defined-class (progn (apply #'reinitialize-instance defined-class (loop for (key value) on initargs by #'cddr unless (member key '(:name :defining-metaclass)) nconc (list key value))) (call-next-method class)) (let ((defined-class (apply #'make-instance defining-metaclass (loop for (key value) on initargs by #'cddr unless (member key '(:name :defining-metaclass)) nconc (list key value))))) (apply #'call-next-method class :direct-superclasses (append (remove (find-class 'partial-object) (class-direct-superclasses class)) (list defined-class) (list (find-class 'partial-object))) 'defining-classes (list* in-layer-name defined-class (partial-class-defining-classes class)) (when defining-metaclass-p (list :defining-metaclass defining-metaclass)))))))) contextl_0.61/cx-singleton-class.lisp000644 000765 000765 00000006233 11325601122 021644 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defclass singleton-class (standard-class) ()) (defmethod validate-superclass ((class singleton-class) (superclass standard-class)) t) (defmethod make-instance ((class singleton-class) &rest initargs) (declare (ignore initargs)) (error "The singleton class ~S cannot be instantiated." class)) (defvar *reinitialize-singleton-class* nil) (defmethod reinitialize-instance :around ((class singleton-class) &key) (let ((*reinitialize-singleton-class* t)) (call-next-method))) (defclass singleton-direct-slot-definition (standard-direct-slot-definition) ((reinitializep :initarg :reinitialize :initform nil :accessor slot-definition-reinitializep))) (defmethod direct-slot-definition-class ((class singleton-class) &key &allow-other-keys) (find-class 'singleton-direct-slot-definition)) (defmethod initialize-instance :around ((slotd singleton-direct-slot-definition) &rest initargs &key name (allocation :class) reinitialize) (declare (dynamic-extent initargs) #+(or cmu ecl) (ignore reinitialize)) (restart-case (unless (eq allocation :class) (error "The allocation of the singleton class slot ~S must be :CLASS, but is defined as ~S." name allocation)) (continue () :report (lambda (stream) (format stream "Use allocation ~S anyway." allocation))) (allocation-class () :report "Use allocation :CLASS instead." (setq allocation :class))) (apply #'call-next-method slotd :allocation allocation :reinitialize #-(or cmu ecl) (and reinitialize *reinitialize-singleton-class*) #+(or cmu ecl) nil initargs)) (defmethod reinitialize-instance :before ((class singleton-class) &rest initargs) (when (getf initargs #-lispworks4 :direct-default-initargs #+lispworks4 :default-initargs) (warn "Default initialization arguments do not make sense for singleton class ~S." class))) (defmethod reinitialize-instance :after ((class singleton-class) &key) (when-let (prototype (ignore-errors (class-prototype class))) (loop for slot in (class-direct-slots class) when (slot-definition-reinitializep slot) do (setf (slot-definition-reinitializep slot) nil) (if (slot-definition-initfunction slot) (setf (slot-value prototype (slot-definition-name slot)) (funcall (slot-definition-initfunction slot))) (slot-makunbound prototype (slot-definition-name slot)))))) (defmethod finalize-inheritance :after ((class singleton-class)) (let ((prototype (class-prototype class))) (loop for slot in (class-direct-slots class) when (slot-definition-reinitializep slot) do (setf (slot-definition-reinitializep slot) nil) (if (slot-definition-initfunction slot) (setf (slot-value prototype (slot-definition-name slot)) (funcall (slot-definition-initfunction slot))) (slot-makunbound prototype (slot-definition-name slot)))))) (declaim (inline find-singleton)) (defun find-singleton (name &optional (errorp t) environment) (class-prototype (find-class name errorp environment))) contextl_0.61/cx-special-class.lisp000644 000765 000765 00000024475 11325601122 021272 0ustar00costanza_costanza000000 000000 (in-package :contextl) (defclass special-object (standard-object) ()) (defclass special-class (standard-class) (old-slot-definitions) (:default-initargs :direct-superclasses (list (find-class 'special-object)))) (defmethod validate-superclass ((class special-class) (superclass standard-class)) t) (defmethod initialize-instance :around ((class special-class) &rest initargs &key direct-superclasses) (declare (dynamic-extent initargs)) (if (loop for superclass in direct-superclasses thereis (subclassp superclass 'special-object)) (call-next-method) (apply #'call-next-method class :direct-superclasses (append direct-superclasses (list (find-class 'special-object))) initargs))) (defmethod reinitialize-instance :around ((class special-class) &rest initargs &key (direct-superclasses () direct-superclasses-p)) (declare (dynamic-extent initargs)) (if direct-superclasses-p (if (loop for superclass in direct-superclasses thereis (subclassp superclass 'special-object)) (call-next-method) (apply #'call-next-method class :direct-superclasses (append direct-superclasses (list (find-class 'special-object))) initargs)) (call-next-method))) (defgeneric slot-definition-specialp (slot) (:method ((slot slot-definition)) nil)) (defclass special-direct-slot-definition (standard-direct-slot-definition) ((specialp :initarg :special :initform nil :reader slot-definition-specialp))) (defclass special-effective-slot-definition (standard-effective-slot-definition) ()) (defmethod slot-definition-specialp ((slot special-effective-slot-definition)) t) (defmethod direct-slot-definition-class ((class special-class) &key &allow-other-keys) (find-class 'special-direct-slot-definition)) (defvar *special-effective-slot-definition-class*) (defmethod effective-slot-definition-class ((class special-class) &key &allow-other-keys) (if *special-effective-slot-definition-class* *special-effective-slot-definition-class* (call-next-method))) (defmethod compute-effective-slot-definition ((class special-class) name direct-slot-definitions) (declare (ignore name)) (let ((*special-effective-slot-definition-class* (when (some #'slot-definition-specialp direct-slot-definitions) (find-class 'special-effective-slot-definition)))) (call-next-method))) (defun shift-slot (object slot-name) (with-symbol-access (let ((slot-value (slot-value object slot-name))) (unless (special-symbol-p slot-value) (slot-makunbound object slot-name) (without-symbol-access (setf (slot-value object slot-name) slot-value)))))) #| Note on thread safety: All special slots are initialized in shared-initialize. This means that outside of object initialization, slot-value and slot-boundp don't have any side effects, only potentially during object (re)initialization. |# (defmethod shared-initialize ((object special-object) slot-names &rest all-keys) (declare (dynamic-extent all-keys)) (let ((class-slots (class-slots (class-of object)))) (loop for slot in class-slots do (when (and (typep slot 'special-effective-slot-definition) (not (eq (slot-definition-allocation slot) :class))) (shift-slot object (slot-definition-name slot))) (when-let (slot-initargs (slot-definition-initargs slot)) (multiple-value-bind (indicator value) (get-properties all-keys slot-initargs) (when indicator (setf (slot-value object (slot-definition-name slot)) value))))) (if (eq slot-names 't) (loop for slot in class-slots for slot-name = (slot-definition-name slot) unless (slot-boundp object slot-name) do (let ((slot-initfunction (slot-definition-initfunction slot))) (when slot-initfunction (setf (slot-value object slot-name) (funcall slot-initfunction))))) (loop for slot-name in slot-names for slot = (find slot-name class-slots :key #'slot-definition-name) unless (slot-boundp object slot-name) do (let ((slot-initfunction (slot-definition-initfunction slot))) (when slot-initfunction (setf (slot-value object slot-name) (funcall slot-initfunction))))))) object) (defmethod slot-unbound ((class special-class) object slot-name) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (if *symbol-access* (let ((slot (find slot-name (the list (class-slots class)) :test #'eq :key #'slot-definition-name))) (if (typep slot 'special-effective-slot-definition) (setf (slot-value-using-class class object slot) (make-special-symbol)) (call-next-method))) (call-next-method))) (defmethod slot-value-using-class ((class special-class) object (slot special-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (if *symbol-access* (call-next-method) (let ((slot-symbol (with-symbol-access (call-next-method)))) (declare (type symbol slot-symbol)) (if (dynamic-symbol-boundp slot-symbol) (dynamic-symbol-value slot-symbol) (slot-unbound class object (slot-definition-name slot)))))) (defmethod (setf slot-value-using-class) (new-value (class special-class) object (slot special-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (if *symbol-access* (call-next-method) (let ((slot-symbol (with-symbol-access (slot-value-using-class class object slot)))) (setf (dynamic-symbol-value (the symbol slot-symbol)) new-value)))) (defmethod slot-boundp-using-class ((class special-class) object (slot special-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (if *symbol-access* (call-next-method) (let ((slot-symbol (with-symbol-access (slot-value-using-class class object slot)))) (dynamic-symbol-boundp (the symbol slot-symbol))))) (defmethod slot-makunbound-using-class ((class special-class) object (slot special-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (if *symbol-access* (call-next-method) (let ((slot-symbol (with-symbol-access (slot-value-using-class class object slot)))) (dynamic-symbol-makunbound (the symbol slot-symbol)) object))) #+(or allegro lispworks) (defmethod make-instances-obsolete :after ((class special-class)) (mapc #'make-instances-obsolete (class-direct-subclasses class))) (defmethod reinitialize-instance :before ((class special-class) &key) (when (class-finalized-p class) (setf (slot-value class 'old-slot-definitions) (class-slots class)))) #+cmu (defmethod reinitialize-instance :after ((class special-class) &key) (finalize-inheritance class)) (defmethod finalize-inheritance :after ((class special-class)) "ensure that special slots remain special after class redefinition (there is no protocol for collapsing multiple values in different dynamic scopes for the same special slot); make instances obsolete when non-special slots have been turned into special slots" (when (slot-boundp class 'old-slot-definitions) (assert (loop for old-slot in (slot-value class 'old-slot-definitions) for new-slot = (find (slot-definition-name old-slot) (class-slots class) :test #'eq :key #'slot-definition-name) always #+(and allegro (not (version>= 7 0))) (cond ((null new-slot) t) (t (eql (typep old-slot 'special-effective-slot-definition) (typep new-slot 'special-effective-slot-definition)))) #-(and allegro (not (version>= 7 0))) (cond ((null new-slot) t) ((typep old-slot 'special-effective-slot-definition) (typep new-slot 'special-effective-slot-definition)) (t (when (typep new-slot 'special-effective-slot-definition) (make-instances-obsolete class)) t))) () #+(and allegro (not (version>= 7 0))) "The (non-)special slots in class ~S must remain (non-)special." #-(and allegro (not (version>= 7 0))) "The special slots in class ~S must remain special." (class-name class)) (slot-makunbound class 'old-slot-definitions)) (loop with prototype = (class-prototype class) for slot in (class-slots class) when (and (typep slot 'special-effective-slot-definition) (eq (slot-definition-allocation slot) :class)) do (shift-slot prototype (slot-definition-name slot)))) (defun funcall-with-special-initargs (bindings thunk) (special-symbol-progv (loop for (object . initargs) in bindings for initarg-keys = (loop for key in initargs by #'cddr collect key) nconc (loop for slot in (class-slots (class-of object)) when (and (slot-definition-specialp slot) (intersection initarg-keys (slot-definition-initargs slot))) collect (with-symbol-access (slot-value object (slot-definition-name slot))))) '() (loop for (object . initargs) in bindings do (apply #'shared-initialize object nil :allow-other-keys t initargs)) (funcall thunk))) (defmacro with-special-initargs ((&rest bindings) &body body) `(funcall-with-special-initargs (list ,@(loop for binding in bindings collect `(list ,@binding))) (lambda () ,@body))) (defmacro with-special-initargs* ((&rest bindings) &body body) (if bindings `(with-special-initargs (,(car bindings)) (with-special-initargs* (,@(cdr bindings)) ,@body)) `(progn ,@body))) contextl_0.61/cx-threads.lisp000644 000765 000765 00000007037 11325601122 020174 0ustar00costanza_costanza000000 000000 (in-package :contextl) #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (require :process)) #+(or allegro clozure (and cmu mp) (and ecl threads) lispworks mcl (and sbcl sb-thread) scl) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :cx-threads *features*)) (declaim (inline make-lock)) (defun make-lock (&key (name "contextl lock")) #-cx-threads name #+allegro (mp:make-process-lock :name name) #+(or clozure mcl) (ccl:make-lock name) #+(and cmu mp) (mp:make-lock name) #+(and ecl threads) (mp:make-lock :name name) #+lispworks (mp:make-lock :name name) #+(and sbcl sb-thread) (sb-thread:make-mutex :name name) #+scl (thread:make-lock name)) (define-compiler-macro make-lock (&key (name "contextl lock")) #-cx-threads name #+allegro `(mp:make-process-lock :name ,name) #+(or clozure mcl) `(ccl:make-lock ,name) #+(and cmu mp) `(mp:make-lock ,name) #+(and ecl threads) `(mp:make-lock :name ,name) #+lispworks `(mp:make-lock :name ,name) #+(and sbcl sb-thread) `(sb-thread:make-mutex :name ,name) #+scl `(thread:make-lock ,name)) (defmacro with-lock ((lock) &body body) #-cx-threads (declare (ignore lock)) #-cx-threads `(progn ,@body) #+allegro `(mp:with-process-lock (,lock) ,@body) #+(or clozure mcl) `(ccl:with-lock-grabbed (,lock) ,@body) #+(and cmu mp) `(mp:with-lock-held (,lock) ,@body) #+(and ecl threads) `(mp:with-lock (,lock) ,@body) #+lispworks `(mp:with-lock (,lock) ,@body) #+(and sbcl sb-thread) `(sb-thread:with-recursive-lock (,lock) ,@body) #+scl `(thread:with-lock-held (,lock) ,@body)) #+cx-threads (defvar *atomic-operation-lock* (make-lock :name "contextl atomic operation lock")) (defmacro as-atomic-operation (&body body) #-cx-threads `(progn ,@body) #+cx-threads `(with-lock (*atomic-operation-lock*) ,@body)) (defstruct (symbol-mapper (:constructor make-symbol-mapper (name))) (name nil :read-only t) (map (make-hash-table :test #'eq #+allegro :weak-keys #+allegro t #+clisp :weak #+clisp :key #+(or clozure mcl) :weak #+(or clozure mcl) t #+cmu :weak-p #+cmu :key #+lispworks :weak-kind #+lispworks :key #+sbcl :weakness #+sbcl :key #+clozure :lock-free #+clozure t) :read-only t) #-(or clozure lispworks sbcl scl) (lock (make-lock :name "symbol mapper") :read-only t)) (declaim (inline atomic-ensure-symbol-mapping)) (defun atomic-ensure-symbol-mapping (symbol mapper generate) (macrolet ((locked-access (&body body) #+lispworks `(with-hash-table-locked (symbol-mapper-map mapper) ,@body) #+sbcl `(sb-ext:with-locked-hash-table ((symbol-mapper-map mapper)) ,@body) #-(or lispworks sbcl) `(with-lock ((symbol-mapper-lock mapper)) ,@body))) (or (gethash symbol (symbol-mapper-map mapper)) #+(or clozure scl (not cx-threads)) (setf (gethash symbol (symbol-mapper-map mapper)) (funcall generate)) #+(and cx-threads (not clozure) (not scl)) (locked-access (or (gethash symbol (symbol-mapper-map mapper)) (setf (gethash symbol (symbol-mapper-map mapper)) (funcall generate))))))) (defgeneric map-symbol (mapper symbol &optional generate) (:method ((mapper symbol-mapper) (symbol symbol) &optional (generate #'gensym)) (if (symbol-package symbol) (intern (format nil "=~A-FOR-~A=" (symbol-mapper-name mapper) (symbol-name symbol)) (symbol-package symbol)) (atomic-ensure-symbol-mapping symbol mapper generate)))) contextl_0.61/cx-util.lisp000644 000765 000765 00000007051 11325601122 017513 0ustar00costanza_costanza000000 000000 (in-package :contextl) #| Layers are represented as CLOS classes. To avoid nameclashes with plain CLOS classes, the name of a layer is actually mapped to an internal unambiguous name which is used instead of the regular name. |# (defvar *layer-class-definer* (make-symbol-mapper 'layer-class-definer)) (defun defining-layer (name) "Takes the name of a layer and returns its internal name." (case name ((t) 't) ((nil) (error "NIL is not a valid layer name.")) (otherwise (map-symbol *layer-class-definer* name)))) #| Layered functions have two names: The name of the caller and the name of the definer. The caller is just a function that adds a representation of the active layers to the list of arguments and calls the definer. The definer is a generic function that contains all the layered methods. The caller has the name under which a user knows about a layered function. The definer has an automatically generated name that can be unambiguously determined from the caller's name. So for example, consider the following layered function definition: (define-layered-function foo (...)) The caller is named 'foo whereas the definer is named something like =layered-function-definer-for-foo=. [The details of the mapping should be considered an implementation detail, though, and not part of the "official" API of ContextL.] |# (defvar *layered-function-definer* (make-symbol-mapper 'layered-function-definer)) (defun lf-definer-name (name) "Takes the name of a layered function caller and returns the name of the corresponding definer." (cond ((plain-function-name-p name) (map-symbol *layered-function-definer* name)) ((setf-function-name-p name) `(setf ,(map-symbol *layered-function-definer* (cadr name)))) (t (error "Illegal function name: ~S." name)))) (defun bind-lf-names (name) "Takes the name of a layered function caller and ensures that it can be retrieved again from the name of a corresponding definer." (let ((plain-function-name (plain-function-name name))) (setf (get (map-symbol *layered-function-definer* plain-function-name) 'layered-function-caller) plain-function-name))) (defun lf-caller-name (name) "Takes the name of a layered function definer and returns the name of the corresponding caller." (cond ((plain-function-name-p name) (get name 'layered-function-caller)) ((setf-function-name-p name) `(setf ,(get (cadr name) 'layered-function-caller))) (t (error "Illegal function name: ~S." name)))) #| The following are utility functions to distingush between the two kinds of function names available in Common Lisp. |# (defun plain-function-name-p (name) (when (symbolp name) (when (and (keywordp name) (not (fboundp name))) (cerror "Use it as a function anyway." "~S visible from package KEYWORD is used as a function." name)) t)) (defun setf-function-name-p (name) (and (consp name) (eq (car name) 'setf) (null (cddr name)) (let ((plain-name (cadr name))) (when (symbolp plain-name) (when (and (keywordp plain-name) (not (fboundp name))) (cerror "Use it as a function anyway." "~S is used as a function, with ~S visible from package KEYWORD." name plain-name)) t)))) (defun plain-function-name (name) (cond ((plain-function-name-p name) name) ((setf-function-name-p name) (cadr name)) (t (error "Illegal function name ~S." name)))) contextl_0.61/dynamic-wind-packages.lisp000644 000765 000765 00000002516 11325601122 022266 0ustar00costanza_costanza000000 000000 (in-package :cl-user) (defpackage #:contextl (:use #:common-lisp #:lispworks) (:export #:*symbol-access* #:call-with-dynamic-environment #:capture-dynamic-environment #:defdynamic #:dlet #:dlet* #:dletf #:dletf* #:drelet #:drelet* #:dreletf #:dreletf* #:dynamic #:dynamic-environment #:dynamic-let #:dynamic-let* #:dynamic-mark #:dynamic-progv #:dynamic-relet #:dynamic-relet* #:dynamic-reprogv #:dynamic-symbol #:dynamic-symbol-boundp #:dynamic-symbol-makunbound #:dynamic-symbol-p #:dynamic-symbol-value #:dynamic-wind #:make-dynamic-symbol #:make-special-symbol #:proceed #:set-dynamic #:safe-special-symbol-progv #:special-symbol-p #:special-symbol-progv #:special-symbol-reprogv #:with-dynamic-environment #:with-dynamic-mark #:with-symbol-access #:without-symbol-access)) (defpackage #:contextl-common-lisp (:nicknames #:cxcl) (:use #:common-lisp #:contextl) #.`(:export ,@(loop for sym being the external-symbols of :common-lisp collect sym) ,@(loop for sym being the external-symbols of :contextl collect sym))) (defpackage #:contextl-user (:use #:contextl-common-lisp) (:nicknames #:cx-user)) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :dynamic-wind *features*)) contextl_0.61/dynamic-wind.asd000644 000765 000765 00000003171 11325601122 020310 0ustar00costanza_costanza000000 000000 (asdf:defsystem #:dynamic-wind :name "dynamic-wind" :author "Pascal Costanza" :version "0.61" :licence " Copyright (c) 2005 - 2010 Pascal Costanza Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the \"Software\"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. " :depends-on (#-lispworks #:lw-compat) :components ((:file "dynamic-wind-packages") (:file "cx-threads" :depends-on ("dynamic-wind-packages")) (:file "cx-dynamic-environments" :depends-on ("dynamic-wind-packages")) (:file "cx-dynamic-variables" :depends-on ("dynamic-wind-packages" "cx-dynamic-environments" "cx-threads")) (:file "cx-dynascope" :depends-on ("dynamic-wind-packages" "cx-dynamic-variables")))) contextl_0.61/test/000755 000765 000765 00000000000 11325601122 016211 5ustar00costanza_costanza000000 000000 contextl_0.61/test/acl81-runall000644 000765 000765 00000000354 11325601122 020341 0ustar00costanza_costanza000000 000000 acl81 -s demo3.lisp acl81 -s spx.lisp acl81 -s grouped-layers.lisp acl81 -s fe.lisp acl81 -s fe2.lisp acl81 -s special-slots-1.lisp acl81 -s special-slots-2.lisp acl81 -s special-slots-3.lisp acl81 -s layer-gc.lisp acl81 -s dynenv.lisp contextl_0.61/test/ccl-runall000644 000765 000765 00000000330 11325601122 020164 0ustar00costanza_costanza000000 000000 ccl -l demo3.lisp ccl -l spx.lisp ccl -l grouped-layers.lisp ccl -l fe.lisp ccl -l fe2.lisp ccl -l special-slots-1.lisp ccl -l special-slots-2.lisp ccl -l special-slots-3.lisp ccl -l layer-gc.lisp ccl -l dynenv.lisp contextl_0.61/test/ccl-runall.lisp000644 000765 000765 00000001027 11325601122 021136 0ustar00costanza_costanza000000 000000 (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 contextl_0.61/test/clisp-runall000644 000765 000765 00000001054 11325601122 020541 0ustar00costanza_costanza000000 000000 clisp -i ~/.clisprc.lisp -on-error debug demo3.lisp clisp -i ~/.clisprc.lisp -on-error debug spx.lisp clisp -i ~/.clisprc.lisp -on-error debug grouped-layers.lisp clisp -i ~/.clisprc.lisp -on-error debug fe.lisp clisp -i ~/.clisprc.lisp -on-error debug fe2.lisp clisp -i ~/.clisprc.lisp -on-error debug special-slots-1.lisp clisp -i ~/.clisprc.lisp -on-error debug special-slots-2.lisp clisp -i ~/.clisprc.lisp -on-error debug special-slots-3.lisp clisp -i ~/.clisprc.lisp -on-error debug layer-gc.lisp clisp -i ~/.clisprc.lisp -on-error debug dynenv.lisp contextl_0.61/test/cmu-runall000644 000765 000765 00000000400 11325601122 020205 0ustar00costanza_costanza000000 000000 lisp -load demo3.lisp lisp -load spx.lisp lisp -load grouped-layers.lisp lisp -load fe.lisp lisp -load fe2.lisp lisp -load special-slots-1.lisp lisp -load special-slots-2.lisp lisp -load special-slots-3.lisp lisp -load layer-gc.lisp lisp -load dynenv.lisp contextl_0.61/test/demo3.lisp000644 000765 000765 00000017141 11325601122 020115 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl :force t) (in-package :contextl-user) (define-layered-class person () ((name :initarg :name :layered-accessor person-name))) (define-layered-function display-object (object)) (define-layered-method display-object ((object person)) (print (list 'person :name (person-name object)))) (defparameter *pascal* (make-instance 'person :name 'pascal)) (assert (equal (display-object *pascal*) '(person :name pascal))) (deflayer employment-layer) (define-layered-class employer :in employment-layer () ((name :initarg :name :layered-accessor employer-name))) (define-layered-method display-object :in employment-layer ((object employer)) (print (list 'employer :name (employer-name object)))) (defparameter *vub* (make-instance 'employer :name 'vub)) (assert (equal (with-active-layers (employment-layer) (display-object *vub*)) '(employer :name vub))) (define-layered-class person :in employment-layer () ((employer :initarg :employer :layered-accessor person-employer))) (define-layered-method display-object :in employment-layer :around ((object person)) (append (call-next-method) (print (list :employer (display-object (person-employer object)))))) (with-active-layers (employment-layer) (setf (person-employer *pascal*) *vub*)) (assert (equal (display-object *pascal*) '(person :name pascal))) (assert (equal (with-active-layers (employment-layer) (display-object *pascal*)) '(person :name pascal :employer (employer :name vub)))) (deflayer info-layer) (define-layered-class info-mixin :in info-layer () ((city :initarg :city :layered-accessor city))) (define-layered-method display-object :in info-layer :around ((object info-mixin)) (append (call-next-method) (print (list :city (city object))))) (define-layered-class person :in info-layer (info-mixin) ()) (define-layered-class employer :in info-layer (info-mixin) ()) (defparameter *docomo* (make-instance 'employer :name 'docomo :city 'munich)) (defparameter *robert* (make-instance 'person :name 'robert :employer *docomo* :city 'ilmenau)) (assert (equal (display-object *robert*) '(person :name robert))) (assert (equal (with-active-layers (employment-layer) (display-object *robert*)) '(person :name robert :employer (employer :name docomo)))) (assert (equal (with-active-layers (employment-layer info-layer) (print (display-object *robert*))) '(person :name robert :city ilmenau :employer (employer :name docomo :city munich)))) (assert (equal (with-active-layers (info-layer employment-layer) (display-object *robert*)) '(person :name robert :city ilmenau :employer (employer :name docomo :city munich)))) (assert (equal (with-active-layers (info-layer employment-layer) (with-inactive-layers (info-layer) (display-object *robert*))) (with-active-layers (employment-layer) (display-object *robert*)))) (assert (equal (with-active-layers (info-layer employment-layer info-layer) (display-object *robert*)) (with-active-layers (employment-layer info-layer) (display-object *robert*)))) (deflayer generic-display-layer) (define-layered-class displayed-slots-mixin :in generic-display-layer () ((displayed-slots :special t :initform '() :accessor displayed-slots))) (define-layered-class person :in generic-display-layer (displayed-slots-mixin) ()) (define-layered-class employer :in generic-display-layer (displayed-slots-mixin) ()) (defgeneric generic-display (object)) (defmethod generic-display (object) object) (defmethod generic-display ((object displayed-slots-mixin)) (let ((slots (displayed-slots object))) (if slots (loop for slot in slots collect slot collect (generic-display (slot-value object slot))) (format t "No slots for display selected.~%")))) (assert (equal (with-active-layers (generic-display-layer) (dletf (((displayed-slots *robert*) '(name employer)) ((displayed-slots *docomo*) '(name city))) (generic-display *robert*))) '(name robert employer (name docomo city munich)))) (deflayer slot-access-layer) (define-layered-method slot-value-using-layer :in slot-access-layer (class (object person) slot reader) (declare (ignorable class slot reader)) (list* (call-next-method) (list :slot-access 'successful))) (define-layered-class person :in slot-access-layer () ((name :layered t))) (assert (equal (with-active-layers (generic-display-layer slot-access-layer) (dletf (((displayed-slots *robert*) '(name employer)) ((displayed-slots *docomo*) '(name city))) (print (generic-display *robert*)))) '(name (robert :slot-access successful) employer (name docomo city munich)))) (define-layered-function test ()) (define-layered-method test :in t () (list 'root-layer)) (define-layered-method test :in info-layer () (list* 'info-layer (call-next-method))) (define-layered-method test :in employment-layer () (list* 'employment-layer (call-next-method))) (assert (equal (test) '(root-layer))) (assert (equal (with-active-layers (info-layer) (test)) '(info-layer root-layer))) (assert (equal (with-active-layers (info-layer employment-layer) (test)) '(employment-layer info-layer root-layer))) (assert (equal (with-active-layers (info-layer employment-layer info-layer) (test)) '(employment-layer info-layer root-layer))) (assert (equal (with-active-layers (info-layer employment-layer) (with-inactive-layers (info-layer) (test))) '(employment-layer root-layer))) (assert (equal (with-active-layers (employment-layer employment-layer) (test)) '(employment-layer root-layer))) (assert (equal (with-active-layers (info-layer employment-layer) (with-inactive-layers (employment-layer) (test))) '(info-layer root-layer))) (multiple-value-bind (required-parameters lambda-list-keyword) (contextl::parse-gf-lambda-list '(a b c &rest r)) (assert (and (equal required-parameters '(a b c)) lambda-list-keyword))) (multiple-value-bind (required-parameters lambda-list-keyword) (contextl::parse-gf-lambda-list '(&key r)) (assert (and (null required-parameters) lambda-list-keyword))) (multiple-value-bind (required-parameters lambda-list-keyword) (contextl::parse-gf-lambda-list '(a b c)) (assert (and (equal required-parameters '(a b c)) (not lambda-list-keyword)))) (multiple-value-bind (required-parameters lambda-list-keyword) (contextl::parse-gf-lambda-list '()) (assert (and (null required-parameters) (not lambda-list-keyword)))) (print :done) #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/dynamic-wind.lisp000644 000765 000765 00000011014 11325601122 021462 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :dynamic-wind) (in-package :contextl-user) (let ((symbol (make-dynamic-symbol))) (assert (dynamic-symbol-p symbol)) #-cx-disable-dynamic-environments (assert (not (dynamic-symbol-p (gensym)))) (assert (not (special-symbol-p symbol))) (assert (not (dynamic-symbol-boundp symbol))) (setf (dynamic-symbol-value symbol) 42) (assert (dynamic-symbol-boundp symbol)) (assert (eql (dynamic-symbol-value symbol) 42)) (dynamic-symbol-makunbound symbol) (assert (not (dynamic-symbol-boundp symbol))) (assert (handler-case (progn (dynamic-symbol-value symbol) nil) (error () t)))) (let ((symbol (make-special-symbol))) (assert (dynamic-symbol-p symbol)) (assert (special-symbol-p symbol)) (assert (not (special-symbol-p (gensym)))) (assert (not (dynamic-symbol-boundp symbol))) (setf (dynamic-symbol-value symbol) 42) (assert (dynamic-symbol-boundp symbol)) (assert (eql (dynamic-symbol-value symbol) 42)) (dynamic-symbol-makunbound symbol) (assert (not (dynamic-symbol-boundp symbol))) (assert (handler-case (progn (dynamic-symbol-value symbol) nil) (error () t)))) #-cx-disable-dynamic-environments (progn (defdynamic x 0) (defdynamic y 0) (defdynamic z 0) (defdynamic env (dynamic-let ((x 1) (y 2) (z 3)) (capture-dynamic-environment))) (assert (and (zerop (dynamic x)) (zerop (dynamic y)) (zerop (dynamic z)))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (dynamic x) (dynamic y) (dynamic z))) '(1 2 3))) (assert (and (zerop (dynamic x)) (zerop (dynamic y)) (zerop (dynamic z)))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (incf (dynamic x)) (incf (dynamic y)) (incf (dynamic z)))) '(2 3 4))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (dynamic x) (dynamic y) (dynamic z))) '(2 3 4))) (setf (dynamic env) (dynamic-let ((x 1)) (with-dynamic-mark (mark) (dynamic-let ((y 2)) (capture-dynamic-environment mark))))) (assert (with-dynamic-environment ((dynamic env)) (and (zerop (dynamic x)) (eql (dynamic y) 2)))) (defvar *mark*) (defun bam () (capture-dynamic-environment *mark*)) (defun baz () (dynamic-let ((y 4)) (bam))) (defun bar () (with-dynamic-mark (*mark*) (baz))) (defun foo () (dynamic-let ((x 3)) (bar))) (setf (dynamic env) (foo)) (assert (with-dynamic-environment ((dynamic env)) (and (zerop (dynamic x)) (eql (dynamic y) 4)))) (setf (dynamic env) (dynamic-let ((x 10)) (with-dynamic-mark (mark1) (dynamic-let ((y 11)) (with-dynamic-mark (mark2) (dynamic-let ((z 12)) (list (capture-dynamic-environment mark1) (capture-dynamic-environment mark2)))))))) (assert (with-dynamic-environment ((first (dynamic env))) (and (zerop (dynamic x)) (eql (dynamic y) 11) (eql (dynamic z) 12)))) (assert (with-dynamic-environment ((second (dynamic env))) (and (zerop (dynamic x)) (zerop (dynamic y)) (eql (dynamic z) 12)))) (setf (dynamic x) '(1 2 3)) (setf (dynamic env) (dynamic-relet ((x (list* 'a 'b 'c (dynamic x)))) (capture-dynamic-environment))) (assert (dynamic-let ((x '(d e f))) (with-dynamic-environment ((dynamic env)) (equal (dynamic x) '(a b c d e f))))) (setf (dynamic env) (dynamic-wind (handler-case (proceed (capture-dynamic-environment)) (error () (print "error caught correctly") t)))) (assert (with-dynamic-environment ((dynamic env)) (error "This is an error."))) (defdynamic xxx nil) (defparameter *y* (dlet ((xxx 1)) (capture-dynamic-environment))) (assert (eql (with-dynamic-environment (*y*) (dynamic xxx)) 1)) (defparameter *x* (with-dynamic-environment (*y*) (capture-dynamic-environment))) (assert (eql (with-dynamic-environment (*x*) (dynamic xxx)) 1))) #+cx-disable-dynamic-environments (print "Dynamic environments not supported.") #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/dynenv.lisp000644 000765 000765 00000024020 11325601122 020403 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (in-package :contextl-user) (let ((symbol (make-dynamic-symbol))) (assert (dynamic-symbol-p symbol)) #-cx-disable-dynamic-environments (assert (not (dynamic-symbol-p (gensym)))) (assert (not (special-symbol-p symbol))) (assert (not (dynamic-symbol-boundp symbol))) (setf (dynamic-symbol-value symbol) 42) (assert (dynamic-symbol-boundp symbol)) (assert (eql (dynamic-symbol-value symbol) 42)) (dynamic-symbol-makunbound symbol) (assert (not (dynamic-symbol-boundp symbol))) (assert (handler-case (progn (dynamic-symbol-value symbol) nil) (error () t)))) (let ((symbol (make-special-symbol))) (assert (dynamic-symbol-p symbol)) (assert (special-symbol-p symbol)) (assert (not (special-symbol-p (gensym)))) (assert (not (dynamic-symbol-boundp symbol))) (setf (dynamic-symbol-value symbol) 42) (assert (dynamic-symbol-boundp symbol)) (assert (eql (dynamic-symbol-value symbol) 42)) (dynamic-symbol-makunbound symbol) (assert (not (dynamic-symbol-boundp symbol))) (assert (handler-case (progn (dynamic-symbol-value symbol) nil) (error () t)))) #-cx-disable-dynamic-environments (progn (defdynamic x 0) (defdynamic y 0) (defdynamic z 0) (defdynamic env (dynamic-let ((x 1) (y 2) (z 3)) (capture-dynamic-environment))) (assert (and (zerop (dynamic x)) (zerop (dynamic y)) (zerop (dynamic z)))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (dynamic x) (dynamic y) (dynamic z))) '(1 2 3))) (assert (and (zerop (dynamic x)) (zerop (dynamic y)) (zerop (dynamic z)))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (incf (dynamic x)) (incf (dynamic y)) (incf (dynamic z)))) '(2 3 4))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (dynamic x) (dynamic y) (dynamic z))) '(2 3 4))) (setf (dynamic env) (dynamic-let ((x 1)) (with-dynamic-mark (mark) (dynamic-let ((y 2)) (capture-dynamic-environment mark))))) (assert (with-dynamic-environment ((dynamic env)) (and (zerop (dynamic x)) (eql (dynamic y) 2)))) (defvar *mark*) (defun bam () (capture-dynamic-environment *mark*)) (defun baz () (dynamic-let ((y 4)) (bam))) (defun bar () (with-dynamic-mark (*mark*) (baz))) (defun foo () (dynamic-let ((x 3)) (bar))) (setf (dynamic env) (foo)) (assert (with-dynamic-environment ((dynamic env)) (and (zerop (dynamic x)) (eql (dynamic y) 4)))) (setf (dynamic env) (dynamic-let ((x 10)) (with-dynamic-mark (mark1) (dynamic-let ((y 11)) (with-dynamic-mark (mark2) (dynamic-let ((z 12)) (list (capture-dynamic-environment mark1) (capture-dynamic-environment mark2)))))))) (assert (with-dynamic-environment ((first (dynamic env))) (and (zerop (dynamic x)) (eql (dynamic y) 11) (eql (dynamic z) 12)))) (assert (with-dynamic-environment ((second (dynamic env))) (and (zerop (dynamic x)) (zerop (dynamic y)) (eql (dynamic z) 12)))) (setf (dynamic x) '(1 2 3)) (setf (dynamic env) (dynamic-relet ((x (list* 'a 'b 'c (dynamic x)))) (capture-dynamic-environment))) (assert (dynamic-let ((x '(d e f))) (with-dynamic-environment ((dynamic env)) (equal (dynamic x) '(a b c d e f))))) (defclass dummy () ((x :special t :accessor x) (y :special t :accessor y) (z :special t :accessor z)) (:metaclass special-class)) (defparameter obj (make-instance 'dummy)) (setf (dynamic env) (dletf (((x obj) 1) ((y obj) 2) ((z obj) 3)) (capture-dynamic-environment))) (assert (not (or (slot-boundp obj 'x) (slot-boundp obj 'y) (slot-boundp obj 'z)))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (x obj) (y obj) (z obj))) '(1 2 3))) (assert (not (or (slot-boundp obj 'x) (slot-boundp obj 'y) (slot-boundp obj 'z)))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (incf (x obj)) (incf (y obj)) (incf (z obj)))) '(2 3 4))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (x obj) (y obj) (z obj))) '(2 3 4))) (setf (dynamic env) (dletf (((x obj) 1)) (with-dynamic-mark (mark) (dletf (((y obj) 2)) (capture-dynamic-environment mark))))) (assert (with-dynamic-environment ((dynamic env)) (and (not (slot-boundp obj 'x)) (eql (y obj) 2)))) (defun bam1 () (capture-dynamic-environment *mark*)) (defun baz1 () (dletf (((y obj) 4)) (bam1))) (defun bar1 () (with-dynamic-mark (*mark*) (baz1))) (defun foo1 () (dletf (((x obj) 3)) (bar1))) (setf (dynamic env) (foo1)) (assert (with-dynamic-environment ((dynamic env)) (and (not (slot-boundp obj 'x)) (eql (y obj) 4)))) (setf (dynamic env) (dletf (((x obj) 10)) (with-dynamic-mark (mark1) (dletf (((y obj) 11)) (with-dynamic-mark (mark2) (dletf (((z obj) 12)) (list (capture-dynamic-environment mark1) (capture-dynamic-environment mark2)))))))) (assert (with-dynamic-environment ((first (dynamic env))) (and (not (slot-boundp obj 'x)) (eql (y obj) 11) (eql (z obj) 12)))) (assert (with-dynamic-environment ((second (dynamic env))) (and (not (slot-boundp obj 'x)) (not (slot-boundp obj 'y)) (eql (z obj) 12)))) (setf (dynamic env) (dletf* (((x obj) 1) ((y obj) (+ (x obj) (x obj))) ((z obj) (+ (y obj) (y obj)))) (capture-dynamic-environment))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (x obj) (y obj) (z obj))) '(1 2 4))) (setf (x obj) '(1 2 3)) (setf (dynamic env) (dreletf (((x obj) (list* 'a 'b 'c (x obj)))) (capture-dynamic-environment))) (assert (dreletf (((x obj) '(d e f))) (with-dynamic-environment ((dynamic env)) (equal (x obj) '(a b c d e f))))) (deflayer l1) (deflayer l2) (deflayer l3) (setf (dynamic env) (with-active-layers (l1 l2 l3) (assert (equal (mapcar #'layer-name (active-layers)) '(l3 l2 l1 t))) (capture-dynamic-environment))) (assert (equal (with-dynamic-environment ((dynamic env)) (mapcar #'layer-name (active-layers))) '(l3 l2 l1 t))) (setf (dynamic env) (with-active-layers (l1 l2 l3) (with-dynamic-mark (mark) (with-inactive-layers (l1 l3) (list (capture-dynamic-environment) (capture-dynamic-environment mark)))))) (assert (equal (with-dynamic-environment ((first (dynamic env))) (mapcar #'layer-name (active-layers))) '(l2 t))) (assert (equal (with-dynamic-environment ((second (dynamic env))) (mapcar #'layer-name (active-layers))) '(t))) (assert (equal (with-active-layers (l3 l2 l1) (with-dynamic-environment ((second (dynamic env))) (mapcar #'layer-name (active-layers)))) '(l2 t))) (assert (equal (with-active-layers (l1 l2 l3 t) (with-dynamic-environment ((second (dynamic env))) (with-active-layers (l1) (mapcar #'layer-name (active-layers))))) '(l1 l2 t))) (setf (dynamic env) (dynamic-wind (handler-case (proceed (capture-dynamic-environment)) (error () (print "error caught correctly") t)))) (assert (with-dynamic-environment ((dynamic env)) (error "This is an error."))) (defdynamic xxx nil) (defparameter *y* (dlet ((xxx 1)) (capture-dynamic-environment))) (assert (eql (with-dynamic-environment (*y*) (dynamic xxx)) 1)) (defparameter *x* (with-dynamic-environment (*y*) (capture-dynamic-environment))) (assert (eql (with-dynamic-environment (*x*) (dynamic xxx)) 1)) #+lispworks (print "This part of the test suite currently doesn't run on LispWorks.") #-lispworks (progn (deflayer l5 () ((x :initarg :x :accessor x) (y :initarg :y :accessor y))) (setf (dynamic env) (with-active-layers ((l5 :x 5 :y 8)) (capture-dynamic-environment))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (mapcar #'layer-name (active-layers)) (x (find-layer 'l5)) (y (find-layer 'l5)))) '((l5 t) 5 8))) (setf (dynamic env) (with-active-layers* ((l5 :x 5) (l5 :y (* 2 (x (find-layer 'l5))))) (capture-dynamic-environment))) (assert (equal (with-dynamic-environment ((dynamic env)) (list (mapcar #'layer-name (active-layers)) (x (find-layer 'l5)) (y (find-layer 'l5)))) '((l5 t) 5 10))))) #+cx-disable-dynamic-environments (print "Dynamic environments not supported.") #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/ecl-runall000644 000765 000765 00000000366 11325601122 020177 0ustar00costanza_costanza000000 000000 ecl -load demo3.lisp ecl -load spx.lisp ecl -load grouped-layers.lisp ecl -load fe.lisp ecl -load fe2.lisp ecl -load special-slots-1.lisp ecl -load special-slots-2.lisp ecl -load special-slots-3.lisp ecl -load layer-gc.lisp ecl -load dynenv.lisp contextl_0.61/test/fe.lisp000644 000765 000765 00000000347 11325601122 017500 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (compile-file "figure-editor.lisp") (load "figure-editor") (in-package :contextl-user) (run-test) #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/fe2.lisp000644 000765 000765 00000000355 11325601122 017561 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (compile-file "figure-editor-2.lisp") (load "figure-editor-2") (in-package :contextl-user) (run-test-2) #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/fibonacci-test.lisp000644 000765 000765 00000002456 11325601122 022003 0ustar00costanza_costanza000000 000000 (in-package :contextl-user) ;; pure Common Lisp version (defvar *fib-cache*) (defun fib1 (n) (or (gethash n *fib-cache*) (setf (gethash n *fib-cache*) (if (< n 2) 1 (+ (fib1 (- n 1)) (fib1 (- n 2))))))) ;; ContextL version (define-layered-function fib2 (n)) (define-layered-method fib2 (n) (if (< n 2) 1 (+ (fib2 (- n 1)) (fib2 (- n 2))))) (deflayer fibonacci-cache) (define-layered-method fib2 :in fibonacci-cache (n) (or (gethash n *fib-cache*) (setf (gethash n *fib-cache*) (call-next-method)))) (defconstant +runs+ 10000000) (defconstant +mod+ 1000) (defun run-fib-test () (print "Timing pure Common Lisp version.") (setf *fib-cache* (make-hash-table)) (time (loop for i below +runs+ do (fib1 (mod i +mod+)))) (print "Timing ContextL version with global context switch.") (setf *fib-cache* (make-hash-table)) (time (with-active-layers (fibonacci-cache) (loop for i below +runs+ do (fib2 (mod i +mod+))))) (print "Timing ContextL version with local context switches.") (setf *fib-cache* (make-hash-table)) (time (loop for i below +runs+ do (with-active-layers (fibonacci-cache) (fib2 (mod i +mod+))))) 'done) contextl_0.61/test/figure-editor-2.lisp000644 000765 000765 00000004774 11325601122 022022 0ustar00costanza_costanza000000 000000 (in-package :contextl-user) (define-layered-class figure-element-2 () ()) (define-layered-function move-2 (figure-element dx dy)) (define-layered-class point-2 (figure-element-2) ((x :initarg :x :initform 0 :layered t :accessor point-x-2) (y :initarg :y :initform 0 :layered t :accessor point-y-2))) (define-layered-method move-2 ((elm point-2) (dx integer) (dy integer)) (incf (point-x-2 elm) dx) (incf (point-y-2 elm) dy)) (define-layered-class line-2 (figure-element-2) ((p1 :initarg :p1 :initform (make-instance 'point-2) :layered t :accessor line-p1-2) (p2 :initarg :p2 :initform (make-instance 'point-2) :layered t :accessor line-p2-2))) (define-layered-method move-2 ((elm line-2) (dx integer) (dy integer)) (move-2 (line-p1-2 elm) dx dy) (move-2 (line-p2-2 elm) dx dy)) (deflayer display-layer-2) (declaim (type integer *update-count-2*)) (defparameter *update-count-2* 0) (defun call-and-update-2 (thunk) (let ((result (with-inactive-layers (display-layer-2) (funcall thunk)))) (incf *update-count-2*) result)) (define-layered-method (setf slot-value-using-layer) :in display-layer-2 :around (new-value class (object figure-element-2) slot writer) (call-and-update-2 (lambda () (funcall writer new-value)))) (define-layered-method move-2 :in display-layer-2 :around ((elm figure-element-2) dx dy) (call-and-update-2 #'call-next-method)) (defconstant +lines-2+ 100) (defparameter *lines-2* (loop repeat +lines-2+ collect (make-instance 'line-2 :p1 (make-instance 'point-2 :x (random 100) :y (random 100)) :p2 (make-instance 'point-2 :x (random 100) :y (random 100))))) (defun move-lines/non-layered-2 () (loop for line in *lines-2* do (move-2 line 5 -5)) (loop for line in *lines-2* do (move-2 line -5 5))) (defun move-lines/layered-2 () (loop for line in *lines-2* do (with-active-layers (display-layer-2) (move-2 line 5 -5))) (loop for line in *lines-2* do (with-active-layers (display-layer-2) (move-2 line -5 5)))) (defconstant +runs-2+ 1000) (defun run-test-2 () (setf *update-count-2* 0) (time (loop repeat +runs-2+ do (move-lines/non-layered-2))) (assert (eql *update-count-2* 0)) (time (loop repeat +runs-2+ do (move-lines/layered-2))) (assert (eql *update-count-2* (* +lines-2+ +runs-2+ 2)))) contextl_0.61/test/figure-editor.lisp000644 000765 000765 00000005462 11325601122 021656 0ustar00costanza_costanza000000 000000 (in-package :contextl-user) (define-layered-class figure-element () ()) (define-layered-function move (figure-element dx dy)) (define-layered-class point (figure-element) ((x :initarg :x :initform 0 :layered-accessor point-x) (y :initarg :y :initform 0 :layered-accessor point-y))) (define-layered-method move ((elm point) (dx integer) (dy integer)) (incf (point-x elm) dx) (incf (point-y elm) dy)) (define-layered-class line (figure-element) ((p1 :initarg :p1 :initform (make-instance 'point) :layered-accessor line-p1) (p2 :initarg :p2 :initform (make-instance 'point) :layered-accessor line-p2))) (define-layered-method move ((elm line) (dx integer) (dy integer)) (move (line-p1 elm) dx dy) (move (line-p2 elm) dx dy)) (deflayer display-layer) (declaim (type integer *update-count*)) (defparameter *update-count* 0) (defun call-and-update (function object) (declare (ignore object)) (let ((result (with-inactive-layers (display-layer) (funcall function)))) (incf *update-count*) result)) (define-layered-method (setf point-x) :in display-layer :around (new-value (object point)) (call-and-update #'call-next-method object)) (define-layered-method (setf point-y) :in display-layer :around (new-value (object point)) (call-and-update #'call-next-method object)) (define-layered-method (setf line-p1) :in display-layer :around (new-value (object point)) (call-and-update #'call-next-method object)) (define-layered-method (setf line-p2) :in display-layer :around (new-value (object point)) (call-and-update #'call-next-method object)) (define-layered-method move :in display-layer :around (object dx dy) (call-and-update #'call-next-method object)) (defconstant +lines+ 100) (defparameter *lines* (loop repeat +lines+ collect (make-instance 'line :p1 (make-instance 'point :x (random 100) :y (random 100)) :p2 (make-instance 'point :x (random 100) :y (random 100))))) (defun move-lines/non-layered () (loop for line in *lines* do (move line 5 -5)) (loop for line in *lines* do (move line -5 5))) (defun move-lines/layered () (loop for line in *lines* do (with-active-layers (display-layer) (move line 5 -5))) (loop for line in *lines* do (with-active-layers (display-layer) (move line -5 5)))) (defconstant +runs+ 1000) (defun run-test () (setf *update-count* 0) (time (loop repeat +runs+ do (move-lines/non-layered))) (assert (eql *update-count* 0)) (time (loop repeat +runs+ do (move-lines/layered))) (assert (eql *update-count* (* +lines+ +runs+ 2)))) contextl_0.61/test/grouped-layers.lisp000644 000765 000765 00000004214 11325601122 022045 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (in-package :contextl-user) (defclass grouped-layer (standard-layer-class) ()) (defgeneric group-root (layer)) (defgeneric default-layer (layer)) (define-layered-method adjoin-layer-using-class ((to-add grouped-layer) active-layers) (call-next-layered-method to-add (remove-layer (group-root (find-layer to-add)) active-layers))) (define-layered-method remove-layer-using-class ((to-remove grouped-layer) active-layers) (declare (ignore active-layers)) (multiple-value-bind (new-layers cacheablep) (call-next-method) (values (adjoin-layer (default-layer (find-layer to-remove)) new-layers) cacheablep))) (deflayer output () ((group-root :initform 'output :reader group-root) (default-layer :initform 'standard-output :reader default-layer))) (deflayer standard-output (output) () (:metaclass grouped-layer)) (deflayer html-output (output) () (:metaclass grouped-layer)) (deflayer xml-output (output) () (:metaclass grouped-layer)) (deflayer json-output (output) () (:metaclass grouped-layer)) (define-layered-function make-output () (:method () '(output)) (:method :in standard-output () (list* 'standard-output (call-next-method))) (:method :in html-output () (list* 'html-output (call-next-method))) (:method :in xml-output () (list* 'xml-output (call-next-method))) (:method :in json-output () (list* 'json-output (call-next-method)))) (assert (equal (make-output) '(output))) (with-active-layers (standard-output) (assert (equal (make-output) '(standard-output output))) (with-active-layers (html-output) (assert (equal (make-output) '(html-output output))) (with-active-layers (xml-output) (assert (equal (make-output) '(xml-output output))) (with-inactive-layers (xml-output) (assert (equal (make-output) '(standard-output output)))) (assert (equal (make-output) '(xml-output output)))) (assert (equal (make-output) '(html-output output)))) (assert (equal (make-output) '(standard-output output)))) (print :done) #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/layer-gc.lisp000644 000765 000765 00000013036 11325601122 020610 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (in-package :contextl-user) (defvar *adjoined*) (defvar *removed*) (defvar *default-context*) (defvar *new-context*) (defclass my-layer-class (standard-layer-class) ()) #-cx-disable-layer-gc (loop repeat 2 do (clear-layer-caches) (defclass my-layer-class (standard-layer-class) ()) (define-layered-method adjoin-layer-using-class :after ((class my-layer-class) (active-context t)) (setf *adjoined* t)) (define-layered-method remove-layer-using-class :after ((class my-layer-class) (active-context t)) (setf *removed* t)) (deflayer foo () () (:metaclass my-layer-class)) (deflayer bar () () (:metaclass my-layer-class)) (deflayer baz (bar) () (:metaclass my-layer-class)) (setf *default-context* (current-layer-context)) ;;; (print 1) (adjoin-layer 'foo *default-context*) (assert *adjoined*) (setf *adjoined* nil) (adjoin-layer 'foo *default-context*) (assert (not *adjoined*)) (setf *adjoined* nil) (adjoin-layer 'foo *default-context*) (assert (not *adjoined*)) (reinitialize-instance (find-layer-class 'foo)) (makunbound '*adjoined*) (adjoin-layer 'foo *default-context*) (assert *adjoined*) (setf *adjoined* nil) (adjoin-layer 'foo *default-context*) (assert (not *adjoined*)) (setf *adjoined* nil) (adjoin-layer 'foo *default-context*) (assert (not *adjoined*)) ;;; (print 2) (remove-layer 'foo *default-context*) (assert *removed*) (setf *removed* nil) (remove-layer 'foo *default-context*) (assert (not *removed*)) (setf *removed* nil) (remove-layer 'foo *default-context*) (assert (not *removed*)) (reinitialize-instance (find-layer-class 'foo)) (makunbound '*removed*) (remove-layer 'foo *default-context*) (assert *removed*) (setf *removed* nil) (remove-layer 'foo *default-context*) (assert (not *removed*)) (setf *removed* nil) (remove-layer 'foo *default-context*) (assert (not *removed*)) ;;; (print 3) (setf *new-context* (adjoin-layer 'foo *default-context*)) (makunbound '*adjoined*) (adjoin-layer 'baz *new-context*) (assert *adjoined*) (setf *adjoined* nil) (adjoin-layer 'baz *new-context*) (assert (not *adjoined*)) (setf *adjoined* nil) (adjoin-layer 'baz *new-context*) (assert (not *adjoined*)) (reinitialize-instance (find-layer-class 'bar)) (setf *adjoined* nil) (adjoin-layer 'baz *new-context*) (assert *adjoined*) (setf *adjoined* nil) (adjoin-layer 'baz *new-context*) (assert (not *adjoined*)) (setf *adjoined* nil) (adjoin-layer 'baz *new-context*) (assert (not *adjoined*)) ;;; (print 4) (setf *new-context* (remove-layer 'foo *default-context*)) (makunbound '*removed*) (remove-layer 'baz *new-context*) (assert *removed*) (setf *removed* nil) (remove-layer 'baz *new-context*) (assert (not *removed*)) (setf *removed* nil) (remove-layer 'baz *new-context*) (assert (not *removed*)) (reinitialize-instance (find-layer-class 'bar)) (setf *removed* nil) (remove-layer 'baz *new-context*) (assert *removed*) (setf *removed* nil) (remove-layer 'baz *new-context*) (assert (not *removed*)) (setf *removed* nil) (remove-layer 'baz *new-context*) (assert (not *removed*)) ;;; (print 5) (setf *new-context* (adjoin-layer 'foo *default-context*)) (makunbound '*adjoined*) (adjoin-layer 'bar *new-context*) (assert *adjoined*) (setf *adjoined* nil) (adjoin-layer 'bar *new-context*) (assert (not *adjoined*)) (define-layered-method adjoin-layer-using-class :before ((class my-layer-class) (active-context t)) '()) (setf *adjoined* nil) (adjoin-layer 'bar *new-context*) (assert *adjoined*) (setf *adjoined* nil) (adjoin-layer 'bar *new-context*) (assert (not *adjoined*)) ;;; (print 6) (setf *new-context* (remove-layer 'foo *default-context*)) (makunbound '*removed*) (remove-layer 'bar *new-context*) (assert *removed*) (setf *removed* nil) (remove-layer 'bar *new-context*) (assert (not *removed*)) (define-layered-method remove-layer-using-class :before ((class my-layer-class) (active-context t)) '()) (setf *removed* nil) (remove-layer 'bar *new-context*) (assert *removed*) (setf *removed* nil) (remove-layer 'bar *new-context*) (assert (not *removed*)) ;;; (print 7) (setf *new-context* (adjoin-layer 'foo *default-context*)) (makunbound '*adjoined*) (adjoin-layer 'bar *new-context*) (assert *adjoined*) (setf *adjoined* nil) (adjoin-layer 'bar *new-context*) (assert (not *adjoined*)) (define-layered-method adjoin-layer-using-class :before ((class (eql (find-layer-class 'bar))) (active-context t)) '()) (setf *adjoined* nil) (adjoin-layer 'bar *new-context*) (assert *adjoined*) (setf *adjoined* nil) (adjoin-layer 'bar *new-context*) (assert (not *adjoined*)) ;;; (print 8) (clear-layer-caches) (setf *new-context* (remove-layer 'foo *default-context*)) (makunbound '*removed*) (remove-layer 'bar *new-context*) (assert *removed*) (setf *removed* nil) (remove-layer 'bar *new-context*) (assert (not *removed*)) (define-layered-method remove-layer-using-class :before ((class (eql (find-layer-class 'bar))) (active-context t)) '()) (setf *removed* nil) (remove-layer 'bar *new-context*) (assert *removed*) (setf *removed* nil) (remove-layer 'bar *new-context*) (assert (not *removed*)) (print :done)) #+cx-disable-layer-gc (print "Layer GC not supported.") #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/mcl-runall.lisp000644 000765 000765 00000001170 11325601122 021147 0ustar00costanza_costanza000000 000000 (load "Macintosh HD:Users:costanza:lisp:closer:contextl:test:demo3") (load "Macintosh HD:Users:costanza:lisp:closer:contextl:test:spx") (load "Macintosh HD:Users:costanza:lisp:closer:contextl:test:grouped-layers") (load "Macintosh HD:Users:costanza:lisp:closer:contextl:test:special-slots-1") (load "Macintosh HD:Users:costanza:lisp:closer:contextl:test:special-slots-2") (load "Macintosh HD:Users:costanza:lisp:closer:contextl:test:special-slots-3") (load "Macintosh HD:Users:costanza:lisp:closer:contextl:test:layer-gc") (load "Macintosh HD:Users:costanza:lisp:closer:contextl:test:dynenv") ;; figure-editor and figure-editor-2 contextl_0.61/test/runall000644 000765 000765 00000002772 11325601122 017441 0ustar00costanza_costanza000000 000000 acl81 -s demo3.lisp acl81 -s spx.lisp acl81 -s grouped-layers.lisp acl81 -s fe.lisp acl81 -s fe2.lisp acl81 -s special-slots-1.lisp acl81 -s special-slots-2.lisp acl81 -s special-slots-3.lisp acl81 -s layer-gc.lisp acl81 -s dynenv.lisp ccl -l demo3.lisp ccl -l spx.lisp ccl -l grouped-layers.lisp ccl -l fe.lisp ccl -l fe2.lisp ccl -l special-slots-1.lisp ccl -l special-slots-2.lisp ccl -l special-slots-3.lisp ccl -l layer-gc.lisp ccl -l dynenv.lisp clisp -i ~/.clisprc.lisp -on-error debug demo3.lisp clisp -i ~/.clisprc.lisp -on-error debug spx.lisp clisp -i ~/.clisprc.lisp -on-error debug grouped-layers.lisp clisp -i ~/.clisprc.lisp -on-error debug fe.lisp clisp -i ~/.clisprc.lisp -on-error debug fe2.lisp clisp -i ~/.clisprc.lisp -on-error debug special-slots-1.lisp clisp -i ~/.clisprc.lisp -on-error debug special-slots-2.lisp clisp -i ~/.clisprc.lisp -on-error debug special-slots-3.lisp clisp -i ~/.clisprc.lisp -on-error debug layer-gc.lisp clisp -i ~/.clisprc.lisp -on-error debug dynenv.lisp lisp -load demo3.lisp lisp -load spx.lisp lisp -load grouped-layers.lisp lisp -load fe.lisp lisp -load fe2.lisp lisp -load special-slots-1.lisp lisp -load special-slots-2.lisp lisp -load special-slots-3.lisp lisp -load layer-gc.lisp lisp -load dynenv.lisp sbcl --load demo3.lisp sbcl --load spx.lisp sbcl --load grouped-layers.lisp sbcl --load fe.lisp sbcl --load fe2.lisp sbcl --load special-slots-1.lisp sbcl --load special-slots-2.lisp sbcl --load special-slots-3.lisp sbcl --load layer-gc.lisp sbcl --load dynenv.lisp contextl_0.61/test/runall.lisp000644 000765 000765 00000000354 11325601122 020401 0ustar00costanza_costanza000000 000000 (load "demo3.lisp") (load "spx.lisp") (load "grouped-layers.lisp") (load "fe.lisp") (load "fe2.lisp") (load "special-slots-1.lisp") (load "special-slots-2.lisp") (load "special-slots-3.lisp") (load "layer-gc.lisp") (load "dynenv.lisp") contextl_0.61/test/sbcl-runall000644 000765 000765 00000000412 11325601122 020347 0ustar00costanza_costanza000000 000000 sbcl --load demo3.lisp sbcl --load spx.lisp sbcl --load grouped-layers.lisp sbcl --load fe.lisp sbcl --load fe2.lisp sbcl --load special-slots-1.lisp sbcl --load special-slots-2.lisp sbcl --load special-slots-3.lisp sbcl --load layer-gc.lisp sbcl --load dynenv.lisp contextl_0.61/test/special-slots-1.lisp000644 000765 000765 00000001660 11325601122 022025 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (in-package :contextl-user) (define-layered-class person1 () ((name1 :initarg :name :accessor person-name1))) (defparameter *p* (make-instance 'person1 :name "Dr. Jekyll")) (assert (equal (person-name1 *p*) "Dr. Jekyll")) (symbol-macrolet ((safe-special-symbol-progv t)) (handler-bind ((error (lambda (error) (eval '(define-layered-class person1 () ((name1 :initarg :name :special t :accessor person-name1)))) (assert (equal (person-name1 *p*) "Dr. Jekyll")) (continue error)))) (dletf (((person-name1 *p*) "Mr. Hide")) (assert (equal (person-name1 *p*) "Mr. Hide"))))) (assert (equal (person-name1 *p*) "Dr. Jekyll")) (print :done) #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/special-slots-2.lisp000644 000765 000765 00000001700 11325601122 022021 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (in-package :contextl-user) (define-layered-class person2 () ((name2 :initarg :name :layered-accessor person-name2))) (defparameter *p* (make-instance 'person2 :name "Dr. Jekyll")) (assert (equal (person-name2 *p*) "Dr. Jekyll")) (symbol-macrolet ((safe-special-symbol-progv t)) (handler-bind ((error (lambda (error) (eval '(define-layered-class person2 () ((name2 :initarg :name :special t :layered-accessor person-name2)))) (assert (equal (person-name2 *p*) "Dr. Jekyll")) (continue error)))) (dletf (((person-name2 *p*) "Mr. Hide")) (assert (equal (person-name2 *p*) "Mr. Hide"))))) (assert (equal (person-name2 *p*) "Dr. Jekyll")) (print :done) #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/special-slots-3.lisp000644 000765 000765 00000002115 11325601122 022023 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (in-package :contextl-user) (defclass person3 () ((name3 :initarg :name :accessor person-name3)) (:metaclass special-class)) (defparameter *p* (make-instance 'person3 :name "Dr. Jekyll")) (assert (equal (person-name3 *p*) "Dr. Jekyll")) (defparameter *error-count* 0) (symbol-macrolet ((safe-special-symbol-progv t)) (handler-bind ((error (lambda (error) (incf *error-count*) (eval '(defclass person3 () ((name3 :initarg :name :special t :accessor person-name3)) (:metaclass special-class))) (assert (equal (person-name3 *p*) "Dr. Jekyll")) (continue error)))) (dletf (((person-name3 *p*) "Mr. Hide")) (assert (equal (person-name3 *p*) "Mr. Hide"))))) (assert (eql *error-count* 1)) (assert (equal (person-name3 *p*) "Dr. Jekyll")) (print :done) #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/spx.lisp000644 000765 000765 00000013001 11325601122 017707 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (in-package :contextl-user) (setf (find-class 'test) nil) (defclass test () ((slot0 :initarg :slot0 :special t :reader tslot0) (slot1 :initarg :slot1 :initform 'foo :special t :allocation :class :reader tslot1)) (:metaclass special-class)) (ensure-finalized (find-class 'test)) (assert (eq (tslot1 (class-prototype (find-class 'test))) 'foo)) (assert (eq (slot-value (class-prototype (find-class 'test)) 'slot1) 'foo)) (defparameter *t* (make-instance 'test :slot0 4711 :slot1 'bar)) (assert (eql (tslot0 *t*) 4711)) (assert (eql (slot-value *t* 'slot0) 4711)) (assert (eq (tslot1 *t*) 'bar)) (assert (eq (slot-value *t* 'slot1) 'bar)) (assert (eq (tslot1 (class-prototype (find-class 'test))) 'bar)) (assert (eq (slot-value (class-prototype (find-class 'test)) 'slot1) 'bar)) (reinitialize-instance *t* :slot0 42 :slot1 'baz) (assert (eql (tslot0 *t*) 42)) (assert (eql (slot-value *t* 'slot0) 42)) (assert (eq (tslot1 *t*) 'baz)) (assert (eq (slot-value *t* 'slot1) 'baz)) (assert (eq (tslot1 (class-prototype (find-class 'test))) 'baz)) (assert (eq (slot-value (class-prototype (find-class 'test)) 'slot1) 'baz)) (deflayer test-layer () ((slot0 :initarg :slot0 :initform 'foo :reader slot0 :special t) (slot1 :initarg :slot1 :initform 'bar :reader slot1 :special t))) (assert (eq (slot0 (find-layer 'test-layer)) 'foo)) (assert (eq (slot1 (find-layer 'test-layer)) 'bar)) (with-active-layers ((test-layer :slot0 4711)) (assert (eql (slot0 (find-layer 'test-layer)) 4711)) (assert (eq (slot1 (find-layer 'test-layer)) 'bar)) (setf (slot-value (find-layer 'test-layer) 'slot0) 111) (setf (slot-value (find-layer 'test-layer) 'slot1) 222) (assert (eql (slot0 (find-layer 'test-layer)) 111)) (assert (eql (slot1 (find-layer 'test-layer)) 222))) (assert (eq (slot0 (find-layer 'test-layer)) 'foo)) (assert (eql (slot1 (find-layer 'test-layer)) 222)) (defparameter *counter* 0) (defparameter *check-counter* 0) (defclass class1 () ((some-slot :initform (incf *counter*) :reader some-slot)) (:metaclass singleton-class)) (incf *check-counter*) (ensure-finalized (find-class 'class1)) (assert (eql (some-slot (class-prototype (find-class 'class1))) *check-counter*)) (defclass class1 () ((some-slot :initform (incf *counter*) :reader some-slot)) (:metaclass singleton-class)) #+(or cmu ecl) (incf *check-counter*) (assert (eql (some-slot (class-prototype (find-class 'class1))) *check-counter*)) (defclass class1 () ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t)) (:metaclass singleton-class)) (incf *check-counter*) (assert (eql (some-slot (class-prototype (find-class 'class1))) *check-counter*)) (defclass class2 () ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t)) (:metaclass singleton-class)) (incf *check-counter*) (ensure-finalized (find-class 'class2)) (assert (eql (some-slot (class-prototype (find-class 'class2))) *check-counter*)) (defclass class2 () ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t)) (:metaclass singleton-class)) (incf *check-counter*) (assert (eql (some-slot (class-prototype (find-class 'class2))) *check-counter*)) (defclass class2 () ((some-slot :initform (incf *counter*) :reader some-slot)) (:metaclass singleton-class)) #+(or cmu ecl) (incf *check-counter*) (assert (eql (some-slot (class-prototype (find-class 'class2))) *check-counter*)) (defparameter *counter* 0) (defparameter *check-counter* 0) (deflayer layer1 () ((some-slot :initform (incf *counter*) :reader some-slot))) (incf *check-counter*) (assert (eql (some-slot (find-layer 'layer1)) *check-counter*)) (deflayer layer1 () ((some-slot :initform (incf *counter*) :reader some-slot))) #+(or cmu ecl) (incf *check-counter*) (assert (eql (some-slot (find-layer 'layer1)) *check-counter*)) (deflayer layer1 () ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t))) (incf *check-counter*) (assert (eql (some-slot (find-layer 'layer1)) *check-counter*)) (deflayer layer2 () ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t))) (incf *check-counter*) (assert (eql (some-slot (find-layer 'layer2)) *check-counter*)) (deflayer layer2 () ((some-slot :initform (incf *counter*) :reader some-slot :reinitialize t))) (incf *check-counter*) (assert (eql (some-slot (find-layer 'layer2)) *check-counter*)) (deflayer layer2 () ((some-slot :initform (incf *counter*) :reader some-slot))) #+(or cmu ecl) (incf *check-counter*) (assert (eql (some-slot (find-layer 'layer2)) *check-counter*)) (deflayer layer3 () ((some-slot :initform (incf *counter*) :reader some-slot :special t))) (incf *check-counter*) (assert (eql (some-slot (find-layer 'layer3)) *check-counter*)) #-cmu (progn (deflayer layer3 () ((some-slot :initform (incf *counter*) :reader some-slot :special t :reinitialize t))) (incf *check-counter*) ;(assert (eql (some-slot (find-layer 'layer3)) *check-counter*)) ) (dletf (((some-slot (find-layer 'layer3)) 'foo)) (assert (eql (some-slot (find-layer 'layer3)) 'foo))) (assert (eql (some-slot (find-layer 'layer3)) *check-counter*)) (deflayer layer4 () ((some-slot :initform (incf *counter*) :reader some-slot :special t))) (incf *check-counter*) (dletf (((some-slot (find-layer 'layer4)) 'bar)) (assert (eql (some-slot (find-layer 'layer4)) 'bar))) (assert (eql (some-slot (find-layer 'layer4)) *check-counter*)) (print :done) #+allegro (excl:exit) #+clozure (ccl:quit) #+cmu (ext:quit) #+ecl (si:quit) #+sbcl (sb-ext:quit) contextl_0.61/test/test-print.lisp000644 000765 000765 00000001126 11325601122 021213 0ustar00costanza_costanza000000 000000 (asdf:oos 'asdf:load-op :contextl) (in-package :contextl-user) (deflayer test-layer) (print (find-layer 'test-layer)) (print (find-layer-class 'test-layer)) (define-layered-class test-class () ()) (print (find-class 'test-class)) (define-layered-function test-function (a b c)) (print (layered-function-definer 'test-function)) (define-layered-method test-function ((a integer) (b cons) c) 42) (define-layered-method test-function :in test-layer :around ((a integer) (b cons) c) 4711) (pprint (generic-function-methods (layered-function-definer 'test-function))) (print :done)