├── .gitignore ├── FUNDING.yml ├── LICENSE ├── README.md ├── VERSION ├── core.lisp ├── docs ├── _config.yml ├── api-reference.md ├── assets │ └── images │ │ └── fmcs-logo.png ├── basic-usage.md ├── concepts.md ├── demonic-metaprogramming.md ├── fmcs-vs-clos-mop.md ├── index.md └── overview.md ├── fmcs.asd ├── fmcs.lisp ├── map.lisp ├── methods.lisp ├── package.lisp ├── root.lisp ├── test ├── package.lisp └── suite.lisp └── util.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | *.dfsl 5 | *.pfsl 6 | *.d64fsl 7 | *.p64fsl 8 | *.lx64fsl 9 | *.lx32fsl 10 | *.dx64fsl 11 | *.dx32fsl 12 | *.fx64fsl 13 | *.fx32fsl 14 | *.sx64fsl 15 | *.sx32fsl 16 | *.wx64fsl 17 | *.wx32fsl 18 | -------------------------------------------------------------------------------- /FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: thephoeron 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 1984--1994, Jürgen Walther and the Contributors 4 | Copyright (c) 2023 "the Phoeron" Colin J.E. Lupton 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # FMCS 2 | 3 | This is the Flavors Meta-Class System (FMCS) for _Demonic Metaprogramming_ in Common Lisp, an alternative to CLOS+MOP. It has been restored from the [CMU AI Repository][CMUAIREPO], alongside Jürgen Walther's [BABYLON][] AI Workbench system, from which the sources were extracted. 4 | 5 | ## TODO 6 | 7 | The following tasks are required to complete the restoration of FMCS: 8 | 9 | - [x] Extract FMCS from BABYLON 10 | - [x] Clean up original source-code 11 | - [x] Translate German comments to English 12 | - [ ] Restore and update original documentation 13 | - [ ] Generate API Documentation in Markdown format 14 | - [ ] Generate unit tests 15 | 16 | ## Demonic Metaprogramming 17 | 18 | TODO: give a brief overview of Demonic Metaprogramming, and how it differs from the MOP, covering the following topics: 19 | 20 | - Modelling software by Control Flow and Data Flow 21 | - SSA-Form and Phi-Functions as Nondeterminstic Choice 22 | - Angelic and Demonic Semantics of Nondeterministic Choice 23 | - Favoring Demonic Semantics for Metaprogramming 24 | - Demonic Nondeterminism over Unified Control/Data Flow Graph 25 | - Demon Methods versus Generic Functions 26 | - The Flavors System versus CLOS 27 | - The Flavors Meta-Class System (FMCS) versus the MOP 28 | - Demonic Semantics of Backquote Syntax in Macroexpansion 29 | 30 | ## Basic Usage 31 | 32 | - Defining Flavor Classes 33 | - Defining Flavor Metaclasses 34 | - Defining Mixins 35 | - Defining Demon Methods 36 | 37 | ## SBCL Users 38 | 39 | For SBCL, FMCS relies on `FARE-QUASIQUOTE` to macroexpand backquote syntax in keeping with idiomatic conventions followed by all other Common Lisp implementations. 40 | 41 | When using FMCS for your own projects, you will need to conditionally depend on `FARE-QUASIQUOTE-EXTRAS` for SBCL in your ASDF systems, and use its named-readtable in every source-file where FMCS forms are used to ensure correct macroexpansion at every level. 42 | 43 | For example, in your ASDF system definition: 44 | 45 | ```lisp 46 | (defsystem my-project 47 | ... 48 | :depends-on ((:feature :sbcl fare-quasiquote-extras) 49 | fmcs) 50 | :components ((:file "package") 51 | (:file "my-project"))) 52 | ``` 53 | 54 | And in your source-files: 55 | 56 | ```lisp 57 | (in-package :my-project) 58 | 59 | #+sbcl 60 | (named-readtables:in-readtable :fare-quasiquote) 61 | 62 | ... 63 | 64 | #+sbcl 65 | (named-readtables:in-readtable :standard) 66 | 67 | ;; eof 68 | ``` 69 | 70 | Alternatively, as the documentation for `FARE-QUASIQUOTE` suggests, you can use ASDF's `:around-compile` hook to automatically wrap all source-files in the appropriate `NAMED-READTABLES:IN-READTABLE` forms. 71 | 72 | ## Authors 73 | 74 | - ["the Phoeron" Colin J.E. Lupton][@thephoeron] 75 | - Jürgen Walther 76 | 77 | Including contributions by, and code based on the work of: 78 | 79 | - Pierre Cointe 80 | - Thomas Christaller 81 | - Harry Bretthauer 82 | - Eckehard Gross 83 | - Jürgen Kopp 84 | 85 | ## License 86 | 87 | Copyright © 1984–2023, the Authors. Restrored from the CMU AI Repository and released under the MIT License. Please see the [LICENSE](LICENSE) file for details. 88 | 89 | > **Restoration Note:** as explicitly noted in the original source-code, FMCS 90 | > was released by Jürgen Walthers under similar terms as the X Windows System, 91 | > X11, and the MIT License is the closest modern, standardized FOSS equivalent. 92 | 93 | [BABYLON]: https://github.com/thephoeron/babylon 94 | [BAPHOMET]: https://github.com/thephoeron/baphomet 95 | [CMUAIREPO]: https://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/0.html 96 | [@thephoeron]: https://github.com/thephoeron 97 | -------------------------------------------------------------------------------- /VERSION: -------------------------------------------------------------------------------- 1 | "2.4.0" 2 | -------------------------------------------------------------------------------- /core.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- 2 | 3 | (in-package :fmcs) 4 | 5 | ;;; This is the kernel of a Meta Class System (MCS), based on 6 | ;;; ObjVlisp by Pierre Cointe and Micro Flavor System by Thomas Christaller. 7 | 8 | ;;; Author: Harry Bretthauer 9 | ;;; Juergen Kopp 10 | 11 | #+sbcl 12 | (named-readtables:in-readtable :fare-quasiquote) 13 | 14 | ;;; -------------------------------------------------------------------------- 15 | ;;; Global variables 16 | ;;; -------------------------------------------------------------------------- 17 | 18 | (defvar *save-combined-methods* T) 19 | 20 | (defvar STANDARD-OBJECT nil) 21 | (defvar STANDARD-CLASS nil) 22 | 23 | (defvar STANDARD-ACCESSORS nil) ; will be set below 24 | 25 | ;;; -------------------------------------------------------------------------- 26 | ;;; Data structure for objects of the Meta Class System 27 | ;;; -------------------------------------------------------------------------- 28 | 29 | ;;; An object of the Meta Class System is represented as a structure. 30 | ;;; Its slots are represented as a vector called environment (env) 31 | 32 | (defstruct (MCSOBJECT (:conc-name mcs-) 33 | (:print-function print-mcs)) ; print-mcs defined below 34 | env) 35 | 36 | (declaim (simple-vector mcs-env)) 37 | 38 | ;;; -------------------------------------------------------------------------- 39 | ;;; Slot access functions 40 | ;;; -------------------------------------------------------------------------- 41 | 42 | ;;; Slots of each class object are: 43 | ;;; isit name supers cplist all-slots all-slot-defaults own-slots 44 | ;;; methods basicnew-fn slot-accessor-fn subclasses 45 | 46 | ;;; Slots indices in all classes 47 | 48 | (defmacro index-of-isit () 0) 49 | (defmacro index-of-name () 1) 50 | (defmacro index-of-supers () 2) 51 | (defmacro index-of-cplist () 3) 52 | (defmacro index-of-all-slots () 4) 53 | (defmacro index-of-all-slot-defaults () 5) 54 | (defmacro index-of-own-slots () 6) 55 | (defmacro index-of-methods () 7) 56 | (defmacro index-of-basicnew-fn () 8) 57 | (defmacro index-of-slot-accessor-fn () 9) 58 | (defmacro index-of-subclasses () 10) 59 | 60 | ;;; Systems internal slot access functions 61 | 62 | (defmacro MCS-GET-SLOT (vector slot-position) 63 | `(svref ,vector ,slot-position)) 64 | 65 | (defmacro MCS-SLOT-VALUE (object slot-position) 66 | `(svref (mcs-env ,object) ,slot-position)) 67 | 68 | ;;; Slot access function to use in methods 69 | 70 | (defmacro GET-CLASS () ;added e.gross 71 | `(svref inst-env (index-of-isit))) 72 | 73 | (defmacro GET-SLOT (slot) ;changed e.gross 74 | `(svref inst-env 75 | (funcall (svref class-env (index-of-slot-accessor-fn)) ,slot))) 76 | 77 | ;(defmacro SET-SLOT (slot new-value) 78 | ; `(setf (svref inst-env 79 | ; (funcall (svref class-env (index-of-slot-accessor-fn)) ,slot)) 80 | ; ,new-value)) 81 | 82 | (defmacro GET-CLASS-SLOT (slot) 83 | (case (eval slot) 84 | (isit `(svref class-env (index-of-isit))) 85 | (name `(svref class-env (index-of-name))) 86 | (supers `(svref class-env (index-of-supers))) 87 | (cplist `(svref class-env (index-of-cplist))) 88 | (methods `(svref class-env (index-of-methods))) 89 | (basicnew-fn `(svref class-env (index-of-basicnew-fn))) 90 | (all-slots `(svref class-env (index-of-all-slots))) 91 | (t `(slot-value (mcs-get-slot inst-env (index-of-isit)) ,slot)))) 92 | 93 | ;(defmacro SET-CLASS-SLOT (slot new-value) 94 | ; `(set-slot-value (mcs-get-slot inst-env (index-of-isit)) ,slot ,new-value) 95 | ; ) 96 | 97 | ;;; universal (public) slot access functions 98 | 99 | (defun SLOT-VALUE (object slot) 100 | (let ((object-env (mcs-env object))) 101 | (svref object-env 102 | (funcall (svref (mcs-env (svref object-env (index-of-isit))) 103 | (index-of-slot-accessor-fn)) 104 | slot)))) 105 | 106 | (defun SET-SLOT-VALUE (object slot value) 107 | (let ((object-env (mcs-env object))) 108 | (setf (svref object-env 109 | (funcall (svref (mcs-env (svref object-env (index-of-isit))) 110 | (index-of-slot-accessor-fn)) 111 | slot)) 112 | value))) 113 | 114 | (defsetf slot-value set-slot-value) 115 | 116 | ;;; -------------------------------------------------------------------------- 117 | ;;; Data structure for method entries 118 | ;;; -------------------------------------------------------------------------- 119 | 120 | (defstruct METHOD-ENTRY 121 | type 122 | methods-list 123 | combined-method) 124 | 125 | ;;; methods-list = ((:before . before-fn) ... (:after . after-fn)) 126 | ;;; methods lambda list: 127 | ;;; of around and primary methods: 128 | ;;; (self class-env inst-env next-methods args arg1 arg2 ...) 129 | ;;; of before and after methods: 130 | ;;; (self class-env inst-env arg1 arg2 ...) 131 | 132 | (defmacro GET-SELECTOR-ENTRY (a_selector) 133 | `(gethash ,a_selector (get-class-slot 'methods))) 134 | 135 | (defmacro GET-QUALIFIED-METHOD (qualifier list-of-methods) 136 | `(assoc ,qualifier ,list-of-methods :test #'eq)) 137 | 138 | (defmacro QUALIFIER-OF (method) 139 | `(first ,method)) 140 | 141 | (defmacro LAMBDA-EXPR-OF (method) 142 | `(rest ,method)) 143 | 144 | (defmacro add-qualified-method (qualifier method-entry new-fn) 145 | `(let ((qualified-method 146 | (get-qualified-method ,qualifier (method-entry-methods-list ,method-entry)))) 147 | (if qualified-method 148 | (rplacd qualified-method ,new-fn) 149 | (setf (method-entry-methods-list ,method-entry) 150 | (acons ,qualifier 151 | ,new-fn 152 | (method-entry-methods-list ,method-entry)))))) 153 | 154 | (defmacro around-of (applicable-methods) 155 | `(first ,applicable-methods)) 156 | 157 | (defmacro demons-of (applicable-methods) 158 | `(rest ,applicable-methods)) 159 | 160 | (defmacro before-of (applicable-methods) 161 | `(second ,applicable-methods)) 162 | 163 | (defmacro primary-of (applicable-methods) 164 | `(third ,applicable-methods)) 165 | 166 | (defmacro after-of (applicable-methods) 167 | `(fourth ,applicable-methods)) 168 | 169 | ;;; -------------------------------------------------------------------------- 170 | ;;; Method combination functions 171 | ;;; -------------------------------------------------------------------------- 172 | 173 | (declaim (inline DEMON-METHOD-COMBINATION)) 174 | 175 | (defun DEMON-METHOD-COMBINATION (self class-env inst-env selector applicable-methods args) 176 | (declare (ignore selector)) 177 | (let ((before-methods (before-of applicable-methods)) 178 | (primary-methods (primary-of applicable-methods)) 179 | (after-methods (after-of applicable-methods))) 180 | (prog2 181 | (loop 182 | (if (null before-methods) (return ())) 183 | (apply (pop before-methods) 184 | self class-env inst-env args)) 185 | (apply (first primary-methods) 186 | self class-env inst-env :primary-caller (rest primary-methods) 187 | args args) 188 | (loop 189 | (if (null after-methods) (return ())) 190 | (apply (pop after-methods) 191 | self class-env inst-env args))))) 192 | 193 | (declaim (inline STANDARD-METHOD-COMBINATION)) 194 | 195 | (defun STANDARD-METHOD-COMBINATION (self class-env inst-env selector applicable-methods args) 196 | (let ((around-methods (around-of applicable-methods))) 197 | (if around-methods 198 | (apply (first around-methods) 199 | self class-env inst-env 200 | :around-caller (cons (rest around-methods) 201 | (demons-of applicable-methods)) 202 | args 203 | args) 204 | (demon-method-combination self class-env inst-env selector applicable-methods args)))) 205 | 206 | (declaim (inline SIMPLE-METHOD-COMBINATION)) 207 | 208 | (defun SIMPLE-METHOD-COMBINATION (self class-env inst-env selector applicable-methods args) 209 | (declare (ignore selector)) 210 | (let ((primary-methods (primary-of applicable-methods))) 211 | (apply (first primary-methods) 212 | self class-env inst-env :primary-caller (rest primary-methods) 213 | args args))) 214 | 215 | ;;; -------------------------------------------------------------------------- 216 | ;;; General message handler 217 | ;;; -------------------------------------------------------------------------- 218 | 219 | (defmacro GET-COMBINED-METHOD (a_selector) 220 | `(let ((method-entry (gethash ,a_selector (get-class-slot 'methods)))) 221 | (if method-entry (method-entry-combined-method method-entry)))) 222 | 223 | ;(declaim (inline STANDARD-MESSAGE-HANDLER)) 224 | 225 | (defun STANDARD-MESSAGE-HANDLER (self class-env inst-env selector args) 226 | (let ((combined-method (get-combined-method selector))) 227 | (if combined-method 228 | (funcall (svref combined-method 0) 229 | self class-env inst-env selector (svref combined-method 1) args) 230 | (multiple-value-bind 231 | (method-combination-fn applicable-methods) 232 | (standard-method-lookup class-env selector) 233 | (if applicable-methods 234 | (progn 235 | (if *save-combined-methods* 236 | (save-combined-method class-env selector 237 | method-combination-fn applicable-methods)) 238 | (funcall method-combination-fn 239 | self class-env inst-env selector applicable-methods args)) 240 | (standard-message-handler self class-env inst-env 241 | :default-handler (cons selector args))))))) 242 | 243 | ;;; -------------------------------------------------------------------------- 244 | ;;; Send functions and macros 245 | ;;; -------------------------------------------------------------------------- 246 | 247 | (defun SEND-MESSAGE (self selector &rest args) 248 | (if (typep self 'mcsobject) 249 | (let* ((inst-env (mcs-env self)) 250 | (class-env (mcs-env (svref inst-env (index-of-isit))))) 251 | (standard-message-handler self class-env inst-env selector args)) 252 | (format nil "ERROR in SEND: SEND can't be applied on ~S" self))) 253 | 254 | (defun SEND-FAST (self sel &rest args) 255 | (let* ((inst-env (mcs-env self)) 256 | (class-env (mcs-env (svref inst-env (index-of-isit))))) 257 | (standard-message-handler self class-env inst-env sel args))) 258 | 259 | (defmacro SEND-SELF (sel &rest args) 260 | `(standard-message-handler self class-env inst-env ,sel (list ,@args))) 261 | 262 | ;;; -------------------------------------------------------------------------- 263 | ;;; Compile method functions 264 | ;;; -------------------------------------------------------------------------- 265 | 266 | (defun SAVE-COMBINED-METHOD (class-env selector method-combination-fn applicable-methods) 267 | (let ((method-entry (gethash selector (get-class-slot 'methods)))) 268 | (if method-entry 269 | (setf (method-entry-combined-method (gethash selector (get-class-slot 'methods))) 270 | (vector method-combination-fn applicable-methods)) 271 | (setf (gethash selector (get-class-slot 'methods)) 272 | (make-method-entry :type 'standard 273 | :methods-list nil 274 | :combined-method 275 | (vector method-combination-fn applicable-methods)))))) 276 | 277 | (defun COMBINE-CLASS-METHOD (a_class a_selector) 278 | (let ((class-env (mcs-env a_class))) 279 | (multiple-value-bind 280 | (method-combination-fn applicable-methods) 281 | (standard-method-lookup class-env a_selector) 282 | (if applicable-methods 283 | (let ((method-entry (gethash a_selector (get-class-slot 'methods)))) 284 | (if method-entry 285 | (setf (method-entry-combined-method 286 | (gethash a_selector (get-class-slot 'methods))) 287 | (vector method-combination-fn applicable-methods)) 288 | (setf (gethash a_selector (get-class-slot 'methods)) 289 | (make-method-entry 290 | :type 'standard :methods-list nil 291 | :combined-method 292 | (vector method-combination-fn applicable-methods)))) 293 | (format nil "Method ~S of class ~S has been combined" a_selector a_class)) 294 | (format nil "No Method ~S of class ~S could been combined" a_selector a_class))))) 295 | 296 | (defmacro COMBINE-CLASS-METHODS (&rest classes) 297 | `(let ((list-of-classes ',classes)) 298 | (loop 299 | (if (null list-of-classes) (return ())) 300 | (let* ((class (eval (pop list-of-classes))) 301 | (all-methods-list (send-message class :get-protocol))) 302 | (loop 303 | (if (null all-methods-list) (return ())) 304 | (combine-class-method class (pop all-methods-list))))))) 305 | 306 | ;;; -------------------------------------------------------------------------- 307 | ;;; Call-next-method macro and functions 308 | ;;; -------------------------------------------------------------------------- 309 | 310 | ;;; CALL-NEXT-METHOD can be used in :around and :primary methods 311 | ;;; If (call-next-method) occurs in an :around method, the next :around method 312 | ;;; is called, if there is one. If no, procede with :before, primary and :after 313 | ;;; methods. If (call-next-method) occurs in a :primary method the next 314 | ;;; :primary method is called, if there is one. If no, an error message is send. 315 | 316 | (defun CALL-NEXT-METHOD-FN (self class-env inst-env caller next-methods args) 317 | (if (eq caller :primary-caller) 318 | (let ((next-method (first next-methods))) 319 | (if next-method 320 | (apply next-method 321 | self class-env inst-env 322 | :primary-caller (rest next-methods) args 323 | args) 324 | (error "Can't call next method from primary method."))) 325 | (let ((around-methods (around-of next-methods))) 326 | (if around-methods 327 | (apply (first around-methods) 328 | self class-env inst-env 329 | :around-caller (cons (rest around-methods) 330 | (demons-of next-methods)) 331 | args args) 332 | (demon-method-combination self class-env inst-env 333 | :dummy-selector 334 | next-methods 335 | args))))) 336 | 337 | (defmacro CALL-NEXT-METHOD (&rest changed-args) 338 | (if changed-args 339 | `(call-next-method-fn self class-env inst-env mcs%caller mcs%next-methods 340 | ',changed-args) 341 | `(call-next-method-fn self class-env inst-env mcs%caller mcs%next-methods mcs%args))) 342 | 343 | ;;; -------------------------------------------------------------------------- 344 | ;;; Method lookup functions 345 | ;;; -------------------------------------------------------------------------- 346 | 347 | (declaim (inline GET-METHOD-ENTRY)) 348 | 349 | (defun GET-METHOD-ENTRY (a_class a_selector) 350 | (gethash a_selector (mcs-slot-value a_class (index-of-methods)))) 351 | 352 | (defun STANDARD-METHOD-LOOKUP (class-env a_selector) 353 | (let ((r-class-precedence-list (reverse (get-class-slot 'cplist))) 354 | (around-methods nil) (before-methods nil) (primary-methods nil) 355 | (after-methods nil)) 356 | (loop 357 | (if (null r-class-precedence-list) 358 | (return 359 | (if primary-methods 360 | (values (if around-methods 361 | 'standard-method-combination 362 | (if (or before-methods after-methods) 363 | 'demon-method-combination 364 | 'simple-method-combination)) 365 | (list around-methods before-methods 366 | primary-methods (reverse after-methods))) 367 | (if (or after-methods before-methods around-methods) 368 | (error "Method combination error: missing primary method for ~S." 369 | a_selector) 370 | (values nil nil))))) 371 | (let ((method (get-method-entry (pop r-class-precedence-list) a_selector))) 372 | (if method 373 | (let ((own-methods-list (method-entry-methods-list method))) 374 | (let ((around-method (get-qualified-method :around own-methods-list)) 375 | (before-method (get-qualified-method :before own-methods-list)) 376 | (primary-method (get-qualified-method :primary own-methods-list)) 377 | (after-method (get-qualified-method :after own-methods-list))) 378 | (if before-method 379 | (setq before-methods (cons (lambda-expr-of before-method) before-methods))) 380 | (if after-method 381 | (setq after-methods (cons (lambda-expr-of after-method) after-methods))) 382 | (if primary-method 383 | (setq primary-methods (cons (lambda-expr-of primary-method) primary-methods))) 384 | (if around-method 385 | (setq around-methods (cons (lambda-expr-of around-method) around-methods)))))))))) 386 | 387 | ;;; -------------------------------------------------------------------------- 388 | ;;; Defmethod macro and helps 389 | ;;; -------------------------------------------------------------------------- 390 | 391 | (defun modify-body (body add-parameter-list &optional result) 392 | (let ((f (first body)) 393 | (r (rest body))) 394 | (cond ((typep f 'string) 395 | (modify-body r add-parameter-list (list f))) 396 | ((and (listp f) (eq (first f) 'declare)) 397 | (modify-body r add-parameter-list (append result (list f)))) 398 | (t (append result 399 | #+(or :MCL :EXCL) 400 | '((declare (ignore-if-unused self class-env inst-env 401 | mcs%caller mcs%next-methods mcs%args))) 402 | #-(or :MCL :EXCL) 403 | add-parameter-list 404 | body))))) 405 | 406 | (defun MAKE-LAMBDA-EXPR (qualifier parameter-list body) 407 | (let ((add-parameter-list 408 | (if (member qualifier '(:around :primary) :test #'eq) 409 | `(self class-env inst-env mcs%caller mcs%next-methods mcs%args) 410 | `(self class-env inst-env)))) 411 | `(lambda (,@add-parameter-list ,@parameter-list) 412 | ,@(modify-body body add-parameter-list)))) 413 | 414 | (defun REMOVE-INVALID-COMBINED-METHODS (a_class selector) 415 | (let ((method-entry (gethash selector (mcs-slot-value a_class (index-of-methods))))) 416 | (if method-entry (setf (method-entry-combined-method method-entry) nil))) 417 | (let ((subclasses (mcs-slot-value a_class (index-of-subclasses)))) 418 | (loop 419 | (if (null subclasses) (return ())) 420 | (remove-invalid-combined-methods (pop subclasses) selector)))) 421 | 422 | (defmacro DEFMETHOD ((a_class . qualifier-and-selector) parameter-list &rest body) 423 | (let ((qualifier (if (second qualifier-and-selector) 424 | (first qualifier-and-selector) 425 | :primary)) 426 | (selector (if (second qualifier-and-selector) 427 | (second qualifier-and-selector) 428 | (first qualifier-and-selector)))) 429 | `(let ((method-entry 430 | (gethash ,selector (mcs-slot-value ,a_class (index-of-methods)))) 431 | (new-method-fn 432 | (function ,(make-lambda-expr qualifier parameter-list body)))) 433 | (if method-entry 434 | (add-qualified-method ,qualifier method-entry new-method-fn) 435 | (setf (gethash ,selector (mcs-slot-value ,a_class (index-of-methods))) 436 | (make-method-entry :type 'standard 437 | :methods-list 438 | (acons ,qualifier new-method-fn ()) 439 | :combined-method nil) )) 440 | (remove-invalid-combined-methods ,a_class ,selector) 441 | (format nil "~:[~S~;~S ~S~] of ~S" (second ',qualifier-and-selector) 442 | ,@qualifier-and-selector ',a_class)))) 443 | 444 | ;;;------------------------------------------------------------------------ 445 | ;;; Basic slot access methods 446 | ;;;------------------------------------------------------------------------ 447 | 448 | (eval-when (:compile-toplevel :load-toplevel :execute) 449 | 450 | (defun gen-get-slot-method (index) 451 | (let ((call-next-parms '(mcs%caller mcs%next-methods mcs%args))) 452 | `(lambda (self class-env inst-env . ,call-next-parms) 453 | (declare (ignore self class-env . ,call-next-parms)) 454 | (svref inst-env ,index)))) 455 | 456 | (defun gen-set-slot-method (index) 457 | (let ((call-next-parms '(mcs%caller mcs%next-methods mcs%args))) 458 | `(lambda (self class-env inst-env ,@call-next-parms value) 459 | (declare (ignore self class-env ,@call-next-parms)) 460 | (setf (svref inst-env ,index) value))))) 461 | 462 | (defun gen-get-slot-closure (index) 463 | #'(lambda (self class-env inst-env mcs%caller mcs%next-methods mcs%args) 464 | (declare (ignore self class-env mcs%caller mcs%next-methods mcs%args)) 465 | (svref inst-env index))) 466 | 467 | (defun gen-set-slot-closure (index) 468 | #'(lambda (self class-env inst-env mcs%caller mcs%next-methods mcs%args value) 469 | (declare (ignore self class-env mcs%caller mcs%next-methods mcs%args)) 470 | (setf (svref inst-env index) value))) 471 | 472 | (defmacro generate-standard-accessors (nr &aux result) 473 | `(let ((array (make-array ,nr :adjustable t))) 474 | (declare (vector array)) 475 | ,@(dotimes (i nr (nreverse result)) 476 | (declare (fixnum i nr)) 477 | (setf result 478 | (cons `(setf (aref array ,i) 479 | (cons (function ,(gen-get-slot-method i)) 480 | (function ,(gen-set-slot-method i)))) 481 | result))) 482 | array)) 483 | 484 | (defun adjust-standard-accessors (array nr) 485 | (declare (vector array) 486 | (fixnum nr)) 487 | (let ((i (length array))) 488 | (declare (fixnum i)) 489 | (multiple-value-bind (x y) (ceiling nr 16) 490 | (declare (ignore x)) 491 | (setq nr (- nr y)) 492 | ; x nil) ; because x should be ignored 493 | (adjust-array array nr) 494 | (loop 495 | (if (>= i nr) 496 | (return array)) 497 | (setf (aref array i) 498 | (cons (gen-get-slot-closure i) 499 | (gen-set-slot-closure i))) 500 | (setq i (1+ i)))))) 501 | 502 | ;;; Generate 48 standard slot access methods 503 | 504 | (setq STANDARD-ACCESSORS (generate-standard-accessors 64)) 505 | 506 | ;;; ---------------------------------------------------------------- 507 | ;;; -*- USER INTERFACE -*- 508 | ;;; ---------------------------------------------------------------- 509 | 510 | (defun PRINT-MCS (object stream depth) 511 | (declare (ignore depth)) 512 | (let ((class-env (mcs-env (mcs-slot-value object (index-of-isit))))) 513 | (if (member 'supers (mcs-get-slot class-env (index-of-all-slots))) 514 | (format stream "#" 515 | (mcs-slot-value object (index-of-name))) 516 | (format stream "#" 517 | (mcs-get-slot class-env (index-of-name)))))) 518 | 519 | (defun DESCRIBE-MCS (object &optional (stream t)) 520 | (if (typep object 'mcsobject) 521 | (let* ((inst-env (mcs-env object)) 522 | (class-env (mcs-env (mcs-get-slot inst-env (index-of-isit))))) 523 | (format stream "~&~S, an object of class ~S,~% has instance variable values:~%" 524 | object (mcs-get-slot class-env (index-of-name))) 525 | (dolist (ivar (mcs-get-slot class-env (index-of-all-slots))) 526 | (format stream "~% ~S:~27T~S" ivar (slot-value object ivar)))) 527 | (describe object))) 528 | 529 | ;;; DEFMETHOD macro already defined 530 | 531 | (defmacro DEFCLASS (a_class a_list-of-instance-variables a_list-of-superclasses &key (metaclass 'standard-class)) 532 | `(setq ,a_class 533 | (funcall (mcs-slot-value ,metaclass (index-of-basicnew-fn)) 534 | ,metaclass 535 | :name ',a_class 536 | :supers (if ',a_list-of-superclasses 537 | (list ,@a_list-of-superclasses) 538 | (list standard-object)) 539 | :own-slots ',a_list-of-instance-variables 540 | ))) 541 | 542 | (defmacro DEFMETACLASS (a_class a_list-of-instance-variables a_list-of-superclasses &key (metaclass 'standard-class)) 543 | `(setq ,a_class 544 | (funcall (mcs-slot-value ,metaclass (index-of-basicnew-fn)) 545 | ,metaclass 546 | :name ',a_class 547 | :supers (if ',a_list-of-superclasses 548 | (list ,@a_list-of-superclasses) 549 | (list standard-class)) 550 | :own-slots ',a_list-of-instance-variables 551 | ))) 552 | 553 | (defmacro MAKE-INSTANCE (a_class &rest initializations) 554 | `(let ((class ,(if (and (listp a_class) (eq (first a_class) 'quote)) 555 | (second a_class) 556 | `(eval ,a_class)))) 557 | (funcall (mcs-slot-value class (index-of-basicnew-fn)) 558 | class ,@initializations))) 559 | 560 | #+sbcl 561 | (named-readtables:in-readtable :standard) 562 | 563 | ;;; eof 564 | -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | remote_theme: pages-themes/minimal@v0.2.0 2 | plugins: 3 | - jekyll-remote-theme 4 | title: FMCS 2.4 5 | description: Demonic Metaprogramming Framework for Common Lisp. 6 | logo: /assets/images/fmcs-logo.png 7 | -------------------------------------------------------------------------------- /docs/api-reference.md: -------------------------------------------------------------------------------- 1 | # FMCS User Manual >> API Reference 2 | 3 | ## Flavor Classes 4 | 5 | ## Flavor Metaclasses 6 | 7 | ## Flavor Mixins 8 | 9 | ## Demon Methods 10 | 11 | ## Frames 12 | 13 | ## Behaviors 14 | 15 | ## Traces 16 | 17 | ## Whoppers 18 | 19 | ## Macros 20 | 21 | ## Functions 22 | 23 | ## Special Variables 24 | -------------------------------------------------------------------------------- /docs/assets/images/fmcs-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thephoeron/fmcs/6109fb3ea5f1d3ff581f9c930fcd13da5702ee13/docs/assets/images/fmcs-logo.png -------------------------------------------------------------------------------- /docs/basic-usage.md: -------------------------------------------------------------------------------- 1 | # FMCS User Manual > Basic Usage 2 | 3 | ## Installation 4 | 5 | FMCS uses ASDF3. To install FMCS, clone the repository into an ASDF local 6 | projects directory, such as `~/common-lisp/` or `~/quicklisp/local-projects/`. 7 | 8 | Then FMCS may be loaded directly by ASDF with `(asdf:load-system :fmcs)` or 9 | using a package manager such as Quicklisp with `(ql:quickload :fmcs)`, 10 | and used as a dependency for other ASDF3 systems. 11 | 12 | ## Planned Feature: FMCS Named Readtable 13 | 14 | In all your source-files where you use FMCS, switch to the `:FMCS` named readtable: 15 | 16 | ```lisp 17 | (in-package :) 18 | 19 | (named-readtables:in-readtable :fmcs) 20 | ``` 21 | 22 | ## Defining Flavor Classes 23 | 24 | ```lisp 25 | (def$flavor ...) 26 | ``` 27 | 28 | ## Defining Flavor Metaclasses 29 | 30 | ```lisp 31 | (def$flavor ...) 32 | ``` 33 | 34 | ## Defining Flavor Mixins 35 | 36 | ```lisp 37 | (def$flavor ...) 38 | ``` 39 | 40 | ## Defining Demon Methods 41 | 42 | ```lisp 43 | (def$method ( :) ...) 44 | ``` 45 | 46 | ## Defining Frames 47 | 48 | ```lisp 49 | (def$frame ...) 50 | ``` 51 | 52 | ## Defining Behaviors 53 | 54 | ```lisp 55 | (def$behavior ...) 56 | ``` 57 | 58 | ## Traceing Demon Methods 59 | 60 | ```lisp 61 | (trace$method ...) 62 | ``` 63 | 64 | ## Untraceing Demon Methods 65 | 66 | ```lisp 67 | (untrace$method ...) 68 | ``` 69 | 70 | ## Defining Whoppers 71 | 72 | ```lisp 73 | (defwhopper ...) 74 | ``` 75 | 76 | ## SBCL Users 77 | 78 | > :warning: Note:
79 | > This will be deprecated in favor of an `:FMCS` named readtable in a future release. 80 | 81 | For SBCL, FMCS relies on `FARE-QUASIQUOTE` to macroexpand backquote syntax in keeping with idiomatic conventions followed by all other Common Lisp implementations. 82 | 83 | When using FMCS for your own projects, you will need to conditionally depend on `FARE-QUASIQUOTE-EXTRAS` for SBCL in your ASDF systems, and use its named-readtable in every source-file where FMCS forms are used to ensure correct macroexpansion at every level. 84 | 85 | For example, in your ASDF system definition: 86 | 87 | ```lisp 88 | (defsystem my-project 89 | ... 90 | :depends-on ((:feature :sbcl fare-quasiquote-extras) 91 | fmcs) 92 | :components ((:file "package") 93 | (:file "my-project"))) 94 | ``` 95 | 96 | And in your source-files: 97 | 98 | ```lisp 99 | (in-package :my-project) 100 | 101 | #+sbcl 102 | (named-readtables:in-readtable :fare-quasiquote) 103 | 104 | ... 105 | 106 | #+sbcl 107 | (named-readtables:in-readtable :standard) 108 | 109 | ;; eof 110 | ``` 111 | 112 | Alternatively, as the documentation for `FARE-QUASIQUOTE` suggests, you can use ASDF's `:around-compile` hook to automatically wrap all source-files in the appropriate `NAMED-READTABLES:IN-READTABLE` forms. 113 | -------------------------------------------------------------------------------- /docs/concepts.md: -------------------------------------------------------------------------------- 1 | # FMCS User Manual > Concepts 2 | 3 | ## Flavors 4 | 5 | ## Flavor Classes 6 | 7 | ## Flavor Metaclasses 8 | 9 | ## Flavor Mixins 10 | 11 | ## Demon Methods 12 | 13 | ## Frames 14 | 15 | ## Behaviours 16 | 17 | ## Traces 18 | 19 | ## Whoppers 20 | -------------------------------------------------------------------------------- /docs/demonic-metaprogramming.md: -------------------------------------------------------------------------------- 1 | # FMCS User Manual > What Is Demonic Metaprogramming? 2 | 3 | ## Modelling software by Control Flow and Data Flow 4 | 5 | ## SSA-Form and Phi-Functions as Nondeterminstic Choice 6 | 7 | ## Angelic and Demonic Semantics of Nondeterministic Choice 8 | 9 | ## Favoring Demonic Semantics for Metaprogramming 10 | 11 | ## Demonic Nondeterminism over Unified Control/Data Flow Graph 12 | 13 | ## Demonic Semantics of Method Combination 14 | 15 | ## Demonic Semantics of Introspection 16 | 17 | ## Demonic Semantics of Backquote Syntax in Macroexpansion 18 | -------------------------------------------------------------------------------- /docs/fmcs-vs-clos-mop.md: -------------------------------------------------------------------------------- 1 | # FMCS User Manual > FMCS vs. CLOS+MOP 2 | 3 | ## FMCS Flavors vs. CLOS Objects 4 | 5 | ## FMCS Flavor Classes vs. CLOS Classes 6 | 7 | ## FMCS Flavor Metaclasses vs. MOP Metaclasses 8 | 9 | ## FMCS Flavor Mixins vs. CLOS Multiple Inheritance 10 | 11 | ## FMCS Demon Methods vs. CLOS Generic Functions 12 | 13 | ## FMCS Frames 14 | 15 | ## FMCS Behaviors 16 | 17 | ## FMCS Traces 18 | 19 | ## FMCS Whoppers 20 | -------------------------------------------------------------------------------- /docs/index.md: -------------------------------------------------------------------------------- 1 | # Flavors Meta-Class System (FMCS): User Manual 2 | 3 | > :warning: **This is a work in progress.** The documentation is being restored 4 | > and updated from the original sources. Please check back later for updates. 5 | 6 | This manual describes the Flavors Meta-Class System (FMCS) for 7 | _Demonic Metaprogramming_ in Common Lisp, an alternative to CLOS+MOP. It has 8 | been restored from the [CMU AI Repository][CMUAIREPO] alongside Jürgen 9 | Walther's [BABYLON][BABYLON] AI Workbench system, from which the sources of 10 | FMCS were extracted as a standalone library. 11 | 12 | - [Overview](./overview.md) 13 | - [Basic Usage](./basic-usage.md) 14 | - [Installation](./basic-usage.md#installation) 15 | - [Defining Flavor Classes](./basic-usage.md#defining-flavor-classes) 16 | - [Defining Flavor Metaclasses](./basic-usage.md#defining-flavor-metaclasses) 17 | - [Defining Flavor Mixins](./basic-usage.md#defining-flavor-mixins) 18 | - [Defining Demon Methods](./basic-usage.md#defining-demon-methods) 19 | - [Defining Behaviours](./basic-usage.md#defining-behaviours) 20 | - [Defining Traces](./basic-usage.md#defining-traces) 21 | - [Defining Whoppers](./basic-usage.md#defining-whoppers) 22 | - [Defining Frames](./basic-usage.md#defining-frames) 23 | - [SBCL Users](./basic-usage.md#sbcl-users) 24 | - [What Is Demonic Metaprogramming?](./demonic-metaprogramming.md) 25 | - [Modelling software by Control Flow and Data Flow](./demonic-metaprogramming.md#modelling-software-by-control-flow-and-data-flow) 26 | - [SSA-Form and Phi-Functions as Nondeterminstic Choice](./demonic-metaprogramming.md#ssa-form-and-phi-functions-as-nondeterminstic-choice) 27 | - [Angelic and Demonic Semantics of Nondeterministic Choice](./demonic-metaprogramming.md#angelic-and-demonic-semantics-of-nondeterministic-choice) 28 | - [Favoring Demonic Semantics for Metaprogramming](./demonic-metaprogramming.md#favoring-demonic-semantics-for-metaprogramming) 29 | - [Demonic Nondeterminism over Unified Control/Data Flow Graph](./demonic-metaprogramming.md#demonic-nondeterminism-over-unified-controldata-flow-graph) 30 | - [Demonic Semantics of Method Combination](./demonic-metaprogramming.md#demonic-semantics-of-method-combination) 31 | - [Demonic Semantics of Introspection](./demonic-metaprogramming.md#demonic-semantics-of-introspection) 32 | - [Demonic Semantics of Backquote Syntax in Macroexpansion](./demonic-metaprogramming.md#demonic-semantics-of-backquote-syntax-in-macroexpansion) 33 | - [FMCS vs. CLOS+MOP](./fmcs-vs-clos-mop.md) 34 | - [FFMCS Flavors vs. CLOS Objects](./fmcs-vs-clos-mop.md#fmcs-flavors-vs-clos-objects) 35 | - [FMCS Flavor Classes vs. CLOS Classes](./fmcs-vs-clos-mop.md#fmcs-flavor-classes-vs-clos-classes) 36 | - [FMCS Flavor Metaclasses vs. MOP Metaclasses](./fmcs-vs-clos-mop.md#fmcs-flavor-metaclasses-vs-mop-metaclasses) 37 | - [FMCS Flavor Mixins vs. CLOS Multiple Inheritance](./fmcs-vs-clos-mop.md#fmcs-flavor-mixins-vs-clos-multiple-inheritance) 38 | - [FMCS Demon Methods vs. CLOS Generic Functions](./fmcs-vs-clos-mop.md#fmcs-demon-methods-vs-clos-generic-functions) 39 | - [FMCS Frames](./fmcs-vs-clos-mop.md#fmcs-frames) 40 | - [FMCS Behaviors](./fmcs-vs-clos-mop.md#fmcs-behaviors) 41 | - [FMCS Traces](./fmcs-vs-clos-mop.md#fmcs-traces) 42 | - [FMCS Whoppers](./fmcs-vs-clos-mop.md#fmcs-whoppers) 43 | - [Concepts](./concepts.md) 44 | - [Flavors](./concepts.md#flavors) 45 | - [Flavor Classes](./concepts.md#flavor-classes) 46 | - [Flavor Metaclasses](./concepts.md#flavor-metaclasses) 47 | - [Flavor Mixins](./concepts.md#flavor-mixins) 48 | - [Demon Methods](./concepts.md#demon-methods) 49 | - [Frames](./concepts.md#frames) 50 | - [Behaviours](./concepts.md#behaviours) 51 | - [Traces](./concepts.md#traces) 52 | - [Whoppers](./concepts.md#whoppers) 53 | - [API Reference](./api-reference.md) 54 | - [Flavor Classes](./api-reference.md#flavor-classes) 55 | - [Flavor Metaclasses](./api-reference.md#flavor-metaclasses) 56 | - [Flavor Mixins](./api-reference.md#flavor-mixins) 57 | - [Demon Methods](./api-reference.md#demon-methods) 58 | - [Frames](./api-reference.md#frames) 59 | - [Behaviors](./api-reference.md#behaviors) 60 | - [Traces](./api-reference.md#traces) 61 | - [Whoppers](./api-reference.md#whoppers) 62 | - [Macros](./api-reference.md#macros) 63 | - [Functions](./api-reference.md#functions) 64 | - [Special Variables](./api-reference.md#special-variables) 65 | 66 | ## Authors 67 | 68 | - ["the Phoeron" Colin J.E. Lupton][@thephoeron] 69 | - Jürgen Walther 70 | 71 | Including contributions by, and code based on the work of: 72 | 73 | - Pierre Cointe 74 | - Thomas Christaller 75 | - Harry Bretthauer 76 | - Eckehard Gross 77 | - Jürgen Kopp 78 | 79 | ## License 80 | 81 | Copyright © 1984–2023, the Authors. Restrored from the CMU AI Repository and released under the MIT License. Please see the [LICENSE](LICENSE) file for details. 82 | 83 | > **Restoration Note:** as explicitly noted in the original source-code, FMCS 84 | > was released by Jürgen Walthers under similar terms as the X Windows System, 85 | > X11, and the MIT License is the closest modern, standardized FOSS equivalent. 86 | 87 | [BABYLON]: https://github.com/thephoeron/babylon 88 | [BAPHOMET]: https://github.com/thephoeron/baphomet 89 | [CMUAIREPO]: https://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/0.html 90 | [@thephoeron]: https://github.com/thephoeron 91 | 92 | -------------------------------------------------------------------------------- /docs/overview.md: -------------------------------------------------------------------------------- 1 | # FMCS User Manual > Overview 2 | -------------------------------------------------------------------------------- /fmcs.asd: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage fmcs/asdf 4 | (:nicknames fmcs/sys) 5 | (:use cl asdf uiop)) 6 | 7 | (in-package :fmcs/asdf) 8 | 9 | (defsystem fmcs 10 | :description "Flavors Meta-Class System (FMCS) for Demonic Metaprogramming in Common Lisp, an alternative to CLOS+MOP, restored from the CMU AI Repository." 11 | :author ("\"the Phoeron\" Colin J.E. Lupton " 12 | "Jürgen Walther " 13 | "Pierre Cointe" 14 | "Thomas Christaller" 15 | "Harry Bretthauer" 16 | "Jürgen Kopp") 17 | :maintainer "\"the Phoeron\" Colin J.E. Lupton " 18 | :mailto "thephoeron@protonmail.com" 19 | :homepage "https://thephoeron.github.io/fmcs/" 20 | :source-control (:git "https://github.com/thephoeron/fmcs.git") 21 | :bug-tracker "https://github.com/thephoeron/fmcs/issues" 22 | :license "MIT" 23 | :version (:read-file-form "VERSION") 24 | :depends-on ((:feature :sbcl fare-quasiquote-extras)) 25 | :serial t 26 | :components ((:file "package") 27 | (:file "core") 28 | (:file "root") 29 | (:file "methods") 30 | (:file "util") 31 | (:file "map") 32 | (:file "fmcs"))) 33 | 34 | (defsystem fmcs/test 35 | :description "Test suite for the FMCS system." 36 | :author "\"the Phoeron\" Colin J.E. Lupton " 37 | :mailto "thephoeron@protonmail.com" 38 | :homepage "https://thephoeron.github.io/fmcs/" 39 | :source-control (:git "https://github.com/thephoeron/fmcs.git") 40 | :bug-tracker "https://github.com/thephoeron/fmcs/issues" 41 | :license "MIT" 42 | :version (:read-file-form "VERSION") 43 | :depends-on (fmcs) 44 | :serial t 45 | :components ((:module "test" 46 | :components ((:file "package") 47 | (:file "suite"))))) 48 | -------------------------------------------------------------------------------- /fmcs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :fmcs) 2 | 3 | ;; If everything compiles and loads correctly, then we can PROVIDE :FMCS 4 | ;; and add it to the *FEATURES* list. 5 | 6 | (provide :fmcs) 7 | 8 | (pushnew :fmcs *features*) -------------------------------------------------------------------------------- /map.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- 2 | 3 | (in-package :fmcs) 4 | 5 | ;; Copyright 1989, 1988, 1987, 1986, 1985 and 1984 BY 6 | ;; G M D 7 | ;; Postfach 1240 8 | ;; D-5205 St. Augustin 9 | ;; FRG 10 | 11 | ;; Authors: Harry Bretthauer, Eckehard Gross, Juergen Kopp, Juergen Walther 12 | 13 | ;; 14 | ;; Mapping to the underlying Flavor System MCS 15 | ;; 16 | 17 | #+sbcl 18 | (named-readtables:in-readtable :fare-quasiquote) 19 | 20 | ;;;(export 'self) 21 | 22 | (defvar flavor-class nil) 23 | 24 | ; ------------------------------------------------------------------- 25 | ; $send self is substituted by send-self 26 | ; ------------------------------------------------------------------- 27 | 28 | (defun subst-$send-self (form) 29 | (cond ((atom form) form) 30 | ((eq (first form) '$send) 31 | (when (eq (second form) 'self) 32 | (rplaca form 'send-self) 33 | (rplacd form (cddr form))) 34 | (subst-$send-self (cdr form))) 35 | (t (subst-$send-self (car form)) 36 | (subst-$send-self (cdr form)))) 37 | form) 38 | 39 | ; ------------------------------------------------------------------- 40 | ; Instance variables are referred to in methods like free variables 41 | ; ------------------------------------------------------------------- 42 | 43 | (defun SUBLIS-SELECT (a_list tree &optional (test #'eql) 44 | (filter #'(lambda (expr) 45 | (declare (ignore expr)) 46 | t))) 47 | (declare (list a_list)) 48 | (cond ((atom tree) tree) 49 | ((funcall (the function filter) tree) 50 | (let ((pair (assoc (first tree) a_list :test test))) 51 | (cond (pair (rplaca tree (cdr pair)) 52 | (sublis-select a_list (cdr tree) test filter)) 53 | (t (sublis-select a_list (car tree) test filter) 54 | (sublis-select a_list (cdr tree) test filter))))) 55 | (t ())) 56 | tree) 57 | 58 | (defun COMPILE-SLOT-REFERENCES (slot-names lambda-body &optional (slot-access-fn 'get-slot)) 59 | ; (print "in compile-slot-ref.") 60 | (sublis-select (mapcar #'(lambda (a_slot) 61 | (cons a_slot (list slot-access-fn (list 'quote a_slot)))) 62 | slot-names) 63 | lambda-body 64 | #'eql 65 | #'(lambda (x) 66 | (and (listp x) 67 | (not (eql (car x) slot-access-fn)) 68 | (not (eq (car x) 'quote)))))) 69 | 70 | ;;; ------------------------------------------------------------------ 71 | ;;; 72 | ;;; ------------------------------------------------------------------ 73 | 74 | (defun GET-ALL-REQUIRED-SLOT-NAMES (class) 75 | (append (mcs-slot-value class (index-of-all-slots)) 76 | (slot-value class 'req-inst-vars))) 77 | 78 | (defun required-instance-variables (options) 79 | (dolist (option options) 80 | (if (and (consp option) 81 | (equal (car option) :required-instance-variables)) 82 | (return (cdr option))))) 83 | 84 | (defmetaclass flavor-class (req-inst-vars) ()) 85 | 86 | (setf (mcs-slot-value flavor-class (index-of-basicnew-fn)) 87 | #'(lambda (isit &key (name nil) (supers nil) (own-slots nil) 88 | (req-inst-vars nil)) 89 | (send-fast 90 | (make-mcsobject 91 | :env (vector isit name supers nil nil nil own-slots 92 | (make-hash-table :test #'eq) 93 | nil nil nil req-inst-vars)) 94 | :basic-init))) 95 | 96 | (defmethod (flavor-class :basic-init) () 97 | (send-self :compute-cplist) 98 | (send-self :inherit-slots-with-defaults) 99 | self) 100 | 101 | (defmethod (flavor-class :init) (&rest inits) 102 | (declare (ignore inits)) 103 | (send-self :compute-slot-accessor-fn) 104 | (send-self :extend-subclasses-of-supers) 105 | (send-self :compute-slot-access-methods) 106 | (send-self :compute-basicnew-fn) 107 | self) 108 | 109 | ;;; ------------------------------------------------------------------ 110 | ;;; Definition forms for Flavors 111 | ;;; ------------------------------------------------------------------ 112 | 113 | ;;;(export 'def$flavor) 114 | (defmacro def$flavor (a_class a_list-of-instance-variables 115 | a_list-of-superclasses &rest options) 116 | `(progn 117 | (eval-when (:compile-toplevel) 118 | (defvar ,a_class) ; to suppress compiler warnings 119 | (setq ,a_class 120 | (funcall (mcs-slot-value flavor-class (index-of-basicnew-fn)) 121 | flavor-class 122 | :name ',a_class 123 | :supers (if ',a_list-of-superclasses 124 | (list ,@a_list-of-superclasses) 125 | (list standard-object)) 126 | :own-slots ',a_list-of-instance-variables 127 | :req-inst-vars ',(required-instance-variables options)))) 128 | ; why this is compilable in the context of def-kb-configuration in GCLisp 129 | ; and the old version with let is not, the lord knows 130 | (eval-when (:load-toplevel) 131 | (defvar ,a_class) 132 | (setq ,a_class 133 | (send-fast (funcall (mcs-slot-value flavor-class (index-of-basicnew-fn)) 134 | flavor-class 135 | :name ',a_class 136 | :supers (if ',a_list-of-superclasses 137 | (list ,@a_list-of-superclasses) 138 | (list standard-object)) 139 | :own-slots ',a_list-of-instance-variables 140 | :req-inst-vars ',(required-instance-variables options)) 141 | :init))) 142 | (eval-when (:execute) 143 | (defvar ,a_class) ; to suppress compiler warnings 144 | (let ((new-class (funcall (mcs-slot-value flavor-class (index-of-basicnew-fn)) 145 | flavor-class 146 | :name ',a_class 147 | :supers (if ',a_list-of-superclasses 148 | (list ,@a_list-of-superclasses) 149 | (list standard-object)) 150 | :own-slots ',a_list-of-instance-variables 151 | :req-inst-vars ',(required-instance-variables options)))) 152 | (if (flavorp ',a_class) 153 | (redefine-class ,a_class new-class) 154 | (setq ,a_class (send-fast new-class :init))))))) 155 | 156 | ;;; During the development of a system, it is often necessary to change or 157 | ;;; redefine Flavors. When a Flavor is redefined, corresponding parts of the 158 | ;;; inheritance hierarchy must be adapted to the new state. 159 | 160 | ;;; This means that: 161 | ;;; - the Flavor must be removed from the subclass lists of its former 162 | ;;; superclasses 163 | ;;; - and the former subclasses of the Flavor must be redefined. 164 | 165 | ;;; Instances of changed Flavors remain unchanged and must be recreated by the 166 | ;;; programmer. This means that program parts that create or use instances must 167 | ;;; be re-evaluated. Therefore, a corresponding warning is issued to the user! 168 | 169 | ;;;(export '*redefine-warnings*) 170 | (defvar *redefine-warnings* nil) 171 | 172 | (defun redefine-class (old-class new-class) 173 | (let ((old-supers (mcs-slot-value old-class (index-of-supers))) 174 | (old-methods (mcs-slot-value old-class (index-of-methods))) 175 | (old-subclasses (mcs-slot-value old-class (index-of-subclasses))) 176 | (new-cplist (cons old-class (rest (slot-value new-class 'cplist))))) 177 | (remove-subclass old-class old-supers) 178 | (setf (mcs-env old-class) (mcs-env new-class)) 179 | (setf (slot-value old-class 'cplist) new-cplist) 180 | (send-fast old-class :init) 181 | (let ((new-methods (mcs-slot-value old-class (index-of-methods)))) 182 | (maphash #'(lambda (key value) 183 | (if (not (gethash key new-methods)) 184 | (setf (gethash key new-methods) value))) 185 | old-methods)) 186 | (if *redefine-warnings* 187 | (warn "~&~S has been redefined. Instances may be invalid now!" old-class)) 188 | (redefine-subclasses old-subclasses) 189 | old-class)) 190 | 191 | (defun remove-subclass (class superclasses) 192 | (dolist (super superclasses) 193 | (setf (mcs-slot-value super (index-of-subclasses)) 194 | (remove class (mcs-slot-value super (index-of-subclasses)) :test #'eq)))) 195 | 196 | (defun redefine-subclasses (list-of-classes) 197 | (dolist (subclass list-of-classes) 198 | (eval 199 | `(def$flavor ,(slot-value subclass 'name) 200 | ,(slot-value subclass 'own-slots) 201 | ,(mapcar #'(lambda (class) 202 | (slot-value class 'name)) 203 | (slot-value subclass 'supers)) 204 | (:required-instance-variables ,@(slot-value subclass 'req-inst-vars)))))) 205 | 206 | ;;;(export 'def$frame) 207 | (defmacro def$frame (name instance-vars components &rest options) 208 | `(def$flavor ,name ,instance-vars ,components ,@options)) 209 | 210 | ;;; ------------------------------------------------------------------ 211 | ;;; Definition forms for Demon Methods, Behaviors, and Tracing Macros 212 | ;;; ------------------------------------------------------------------ 213 | 214 | ;;;(export 'def$method) 215 | (defmacro def$method ((name . type&selector) varlist . body) 216 | (let ((new-body 217 | (compile-slot-references (get-all-required-slot-names (symbol-value name)) 218 | (subst-$send-self body)))) 219 | `(defmethod (,name ,@type&selector) ,varlist ,@new-body))) 220 | 221 | ;;;(export 'def$behavior) 222 | (defmacro def$behavior ((name . type&selector) varlist . body) 223 | (let ((new-body (subst-$send-self body))) 224 | `(defmethod (,name ,@type&selector) ,varlist ,@new-body))) 225 | 226 | ;;;(export 'undef$method) 227 | (defmacro undef$method ((name . type&selector)) ; for testing only 228 | `(undefmethod (,name . ,type&selector))) 229 | 230 | ;;;(export 'trace$method) 231 | (defmacro trace$method ((flav-name selector)) 232 | "traces a method on *trace-output*" 233 | `(mcs-trace ,flav-name ,selector)) 234 | 235 | ;;;(export 'untrace$method) 236 | (defmacro untrace$method ((flav-name selector)) 237 | "untraces a method" 238 | `(mcs-untrace ,flav-name ,selector)) 239 | 240 | ;;;(export 'is-traced$method) 241 | (defmacro is-traced$method ((flav-name selector)) 242 | "untraces a method" 243 | `(mcs-is-traced ,flav-name ,selector)) 244 | 245 | ;;;(export 'compile-$flavor-$methods) 246 | (defmacro compile-$flavor-$methods (&rest flavors) 247 | `(eval-when (:load-toplevel) 248 | (combine-class-methods ,@flavors))) 249 | 250 | ;;; ------------------------------------------------------------------ 251 | ;;; WHOPPER = :AROUND method combination 252 | ;;; ------------------------------------------------------------------ 253 | 254 | ;;;(export 'defwhopper) 255 | (defmacro defwhopper ((flavor-name operation) arglist &body body) 256 | `(def$method (,flavor-name :around ,operation) (,@arglist) 257 | ,@body)) 258 | 259 | ;;;(export 'continue-whopper) 260 | (defmacro continue-whopper (&rest changed-args) 261 | (if changed-args 262 | `(call-next-method-fn self class-env inst-env mcs%caller mcs%next-methods 263 | (list ,@changed-args)) 264 | `(call-next-method-fn self class-env inst-env mcs%caller mcs%next-methods 265 | mcs%args))) 266 | 267 | ;;; ------------------------------------------------------------------ 268 | ;;; Sending messages 269 | ;;; ------------------------------------------------------------------ 270 | 271 | ; (send-message (object selector &rest message) is provided by mcs 272 | 273 | ;;;(export '$send) 274 | (defmacro $send (object message &rest args) 275 | `(send-message ,object ,message ,@args)) 276 | 277 | ;;;(export 'lexpr-$send) 278 | (defmacro lexpr-$send (object message &rest args) 279 | `(apply #'send-message ,object ,message ,@args)) 280 | 281 | ;;; ------------------------------------------------------------------ 282 | ;;; Functions and macros for flavors and instances 283 | ;;; ------------------------------------------------------------------ 284 | 285 | ;;; the typep function of different lisp implementations behave differently 286 | ;;; in case of unknown type specifiers, 287 | ;;; it may warn you, give an error, or return nil 288 | ;;; what a horror 289 | 290 | ;;;(export 'flavorp) 291 | (defun flavorp (object) 292 | (if (and (boundp object)(typep (symbol-value object) 'mcsobject)) 293 | (send-fast (symbol-value object) :class-p))) 294 | 295 | ;;;(export 'flavor-instancep) 296 | (defun flavor-instancep (object) 297 | (typep object 'mcsobject)) 298 | 299 | ;;;(export 'flavor-typep) 300 | (defun flavor-typep (object type) 301 | (if (typep object 'mcsobject) 302 | (if (and (boundp type) 303 | (member (symbol-value type) 304 | (mcs-slot-value (mcs-slot-value object (index-of-isit)) 305 | (index-of-cplist)) 306 | :test #'eq)) 307 | t) 308 | (unless (flavorp type) 309 | (typep object type)))) 310 | 311 | 312 | ;;;(export 'flavor-type-of) 313 | (defun flavor-type-of (object) 314 | (if (typep object 'mcsobject) 315 | (mcs-slot-value (mcs-slot-value object (index-of-isit)) (index-of-name)) 316 | (type-of object))) 317 | 318 | ;;; ------------------------------- 319 | 320 | ;;;(export 'get-flavor-instance-slots) 321 | (defun get-flavor-instance-slots (instance) 322 | (remove 'isit (mcs-slot-value (mcs-slot-value instance (index-of-isit)) 323 | (index-of-all-slots)))) 324 | 325 | ;;;(export 'symbol-value-in-$instance) 326 | (defmacro symbol-value-in-$instance (instance slot-name) 327 | `(slot-value ,instance ,slot-name)) 328 | 329 | ;;;(export '$slot) 330 | (defmacro $slot (slot-name) 331 | `(get-slot ,slot-name)) 332 | 333 | ;;; ------------------------------------------------------------------ 334 | ;;; Definition forms for Flavor Instances 335 | ;;; ------------------------------------------------------------------ 336 | 337 | ;; (defmacro make-$instance (flavor &rest init-plist) 338 | ;; `(send (eval ,flavor) :new ,@init-plist)) 339 | 340 | ;; 3.1.89 341 | 342 | ;;;(export 'MAKE-$INSTANCE) 343 | (defmacro MAKE-$INSTANCE (flavor &rest initializations) 344 | `(let ((class (symbol-value ,flavor))) 345 | (funcall (mcs-slot-value class (index-of-basicnew-fn)) 346 | class ,@initializations))) 347 | 348 | ;;;(export 'make-window-or-instance) 349 | (defmacro make-window-or-instance (flavor &rest initializations) 350 | `(MAKE-$INSTANCE ,flavor ,@initializations)) 351 | 352 | 353 | ;;; ------------------------------------------------------------------- 354 | ;;; Demon Methods for all Flavor Instances 355 | ;;; ------------------------------------------------------------------- 356 | 357 | ;;; are defined in the file `util.lisp` for FMCS STANDARD-OBJECT 358 | 359 | ; :describe 360 | ; :which-operations 361 | ; :apropos 362 | ; :operation-handled-p 363 | ; :send-if-handles 364 | ; :how-combined 365 | 366 | #+sbcl 367 | (named-readtables:in-readtable :standard) 368 | 369 | ;; eof 370 | -------------------------------------------------------------------------------- /methods.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- 2 | 3 | (in-package :fmcs) 4 | 5 | #+sbcl 6 | (named-readtables:in-readtable :fare-quasiquote) 7 | 8 | ;;; ------------------------------------------------------------------ 9 | ;;; Inheritance methods 10 | ;;; ------------------------------------------------------------------ 11 | 12 | (defmethod (standard-class :compute-cplist) () 13 | (let ((result ()) 14 | (r-supers (reverse (mcs-get-slot inst-env (index-of-supers))))) 15 | (loop 16 | (if (null r-supers) (return ())) 17 | (setf result 18 | (append (mcs-slot-value (pop r-supers) (index-of-cplist)) 19 | result))) 20 | (setf (mcs-get-slot inst-env (index-of-cplist)) 21 | (remove-duplicates (cons self result) 22 | :test #'eq)))) 23 | 24 | (defmethod (standard-class :inherit-slots-with-defaults) () 25 | (let* ((own-slots-specification 26 | (mcs-get-slot inst-env (index-of-own-slots))) 27 | (slots-result (mapcar #'(lambda (el) (if (listp el) (first el) el)) 28 | own-slots-specification)) 29 | (defaults-result (mapcar #'(lambda (el) (if (listp el) 30 | el 31 | (list el nil))) 32 | own-slots-specification)) 33 | (components (rest (mcs-get-slot inst-env (index-of-cplist))))) 34 | (loop 35 | (if (null components) (return ())) 36 | (setq slots-result 37 | (append (mcs-slot-value (first components) (index-of-all-slots)) 38 | slots-result)) 39 | (setq defaults-result 40 | (append defaults-result 41 | (mcs-slot-value (first components) 42 | (index-of-all-slot-defaults)))) 43 | (pop components)) 44 | (setf (mcs-get-slot inst-env (index-of-all-slots)) 45 | (remove-duplicates slots-result :test #'eq :from-end t)) 46 | (setf (mcs-get-slot inst-env (index-of-all-slot-defaults)) 47 | (remove-duplicates defaults-result :test #'eq :key #'car :from-end t)))) 48 | 49 | (defmethod (standard-class :compute-slot-access-methods) () 50 | (let* ((slots (rest (mcs-get-slot inst-env (index-of-all-slots)))) 51 | (nr (1+ (length slots))) 52 | (counter (1+ (index-of-isit))) 53 | (array standard-accessors)) 54 | (declare (fixnum nr counter) 55 | (vector array) 56 | (list slots)) 57 | (if (> nr (length array)) 58 | (setq standard-accessors (adjust-standard-accessors array nr))) 59 | (loop 60 | (if (null slots) (return ())) 61 | (let ((slot-name (pop slots)) 62 | (fn-pair (aref array counter))) 63 | (setf (gethash (intern (string slot-name) :keyword) 64 | (mcs-get-slot inst-env (index-of-methods))) 65 | (make-method-entry :type 'standard 66 | :methods-list 67 | (acons :primary (car fn-pair) ()) 68 | :combined-method nil)) 69 | (setf (gethash (intern (concatenate 'string "SET-" (string slot-name)) 70 | :keyword) 71 | (mcs-get-slot inst-env (index-of-methods))) 72 | (make-method-entry :type 'standard 73 | :methods-list 74 | (acons :primary (cdr fn-pair) ()) 75 | :combined-method nil)) 76 | (setq counter (1+ counter)))))) 77 | 78 | (defmethod (standard-class :compute-slot-accessor-fn) () 79 | (setf (mcs-get-slot inst-env (index-of-slot-accessor-fn)) 80 | (compile 81 | nil 82 | `(lambda (slot) 83 | (case slot 84 | ,@(let ((slots (mcs-get-slot inst-env (index-of-all-slots))) 85 | (list-of-var-pos-pairs nil) 86 | (counter (index-of-isit))) 87 | (declare (fixnum counter)) 88 | (loop 89 | (if (null slots) (return list-of-var-pos-pairs)) 90 | (setq list-of-var-pos-pairs 91 | (append list-of-var-pos-pairs 92 | (list (cons (pop slots) (list counter))))) 93 | (setq counter (1+ counter))) 94 | list-of-var-pos-pairs) 95 | (t (error "No slot ~S in instances of ." 96 | slot ',(mcs-get-slot inst-env (index-of-name))))))))) 97 | 98 | (defmethod (standard-class :extend-subclasses-of-supers) () 99 | (dolist (super (mcs-get-slot inst-env (index-of-supers))) 100 | (setf (mcs-slot-value super (index-of-subclasses)) 101 | (cons self (mcs-slot-value super (index-of-subclasses)))))) 102 | 103 | (defmethod (standard-class :compute-basicnew-fn) (&rest keys) 104 | (let ((key-list (rest (mcs-get-slot inst-env (index-of-all-slots)))) 105 | (slot-list (rest (mcs-get-slot inst-env (index-of-all-slots)))) 106 | (keys+defaults (mcs-get-slot inst-env (index-of-all-slot-defaults)))) 107 | (when keys 108 | (setq key-list keys) 109 | (setq slot-list (mapcar #'(lambda (slot) 110 | (if (member slot key-list :test #'eq) 111 | slot 112 | (second (assoc slot keys+defaults 113 | :test #'eq)))) 114 | slot-list)) 115 | (setq keys+defaults (mapcar #'(lambda (key) 116 | (assoc key keys+defaults :test #'eq)) 117 | key-list))) 118 | (setf (mcs-get-slot inst-env (index-of-basicnew-fn)) 119 | (compile nil 120 | `(lambda (isit &key ,@keys+defaults) 121 | (send-fast 122 | (make-mcsobject 123 | :env (vector isit ,@slot-list)) 124 | :init ,@key-list)))))) 125 | 126 | #| 127 | (defmethod (standard-class :recompute-cplist) () 128 | (setf (mcs-get-slot inst-env (index-of-cplist)) 129 | (send-self :inheritance-algorithm))) 130 | 131 | (defmethod (standard-class :inheritance-algorithm) () 132 | (labels 133 | ((traverse-node (a_class result) 134 | (if (member a_class result :test #'eq) 135 | result 136 | (cons a_class 137 | (traverse-list 138 | (reverse (mcs-slot-value a_class 139 | (index-of-supers))) 140 | result)))) 141 | (traverse-list (r-supers result) 142 | (if (null r-supers) 143 | result 144 | (traverse-list 145 | (rest r-supers) 146 | (traverse-node (first r-supers) result)) 147 | ))) 148 | (cons self 149 | (traverse-list (reverse (mcs-get-slot inst-env (index-of-supers))) 150 | nil)))) 151 | |# 152 | 153 | ;;; ------------------------------------------------------------------ 154 | ;;; Object protocol methods 155 | ;;; ------------------------------------------------------------------ 156 | 157 | (defmethod (standard-object :isit) () 158 | (mcs-get-slot inst-env (index-of-isit))) 159 | 160 | (defmethod (standard-object :class-name) () 161 | (mcs-get-slot class-env (index-of-name))) 162 | 163 | (defmethod (standard-object :class-p) () 164 | (if (member 'supers (get-class-slot 'all-slots) :test #'eq) 165 | t nil)) 166 | 167 | (defmethod (standard-object :metaclass-p) () 168 | (if (and (member 'cplist (get-class-slot 'all-slots) :test #'eq) 169 | (member standard-class (mcs-get-slot inst-env (index-of-cplist)) 170 | :test #'eq)) 171 | t)) 172 | 173 | (defmethod (standard-object :default-handler) (&rest message) 174 | (send-self :error-handler (first message))) 175 | 176 | (defmethod (standard-object :error-handler) (selector) 177 | (error "~S can not handle this message: ~S" 178 | (mcs-get-slot class-env (index-of-name)) selector)) 179 | 180 | (defmethod (standard-object :operation-handled-p) (operation) 181 | (let ((opened (mcs-get-slot class-env (index-of-cplist)))) 182 | (loop 183 | (if (null opened) (return ())) 184 | (let ((a-class (pop opened))) 185 | (if (get-method-entry a-class operation) 186 | (return T)))))) 187 | 188 | (defmethod (standard-object :send-if-handles) (operation &rest arguments) 189 | (let ((opened (mcs-get-slot class-env (index-of-cplist)))) 190 | (loop 191 | (if (null opened) (return ())) 192 | (let ((a-class (pop opened))) 193 | (if (get-method-entry a-class operation) 194 | (return (standard-message-handler self class-env inst-env operation 195 | arguments))))))) 196 | 197 | #+sbcl 198 | (named-readtables:in-readtable :standard) 199 | 200 | ;; eof 201 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage fmcs 4 | (:nicknames flavors-metaclass-system flavors) 5 | (:use cl) 6 | (:shadow #:defclass 7 | #:defmethod 8 | #:make-instance 9 | #:slot-value 10 | #:standard-object 11 | #:standard-class 12 | #:self 13 | #:call-next-method) 14 | (:export #:*redefine-warnings* 15 | #:self 16 | #:$slot 17 | #:def$flavor 18 | #:def$method 19 | #:undef$method 20 | #:def$frame 21 | #:def$behavior 22 | #:trace$method 23 | #:untrace$method 24 | #:is-traced$method 25 | #:compile-$flavor-$methods 26 | #:defwhopper 27 | #:continue-whopper 28 | #:$send 29 | #:lexpr-$send 30 | #:flavorp 31 | #:flavor-instancep 32 | #:flavor-typep 33 | #:flavor-type-of 34 | #:get-flavor-instance-slots 35 | #:symbol-value-in-$instance 36 | #:make-$instance 37 | #:make-window-or-instance 38 | #:mcs-trace 39 | #:mcs-untrace 40 | #:mcs-is-traced)) 41 | 42 | (in-package :fmcs) 43 | -------------------------------------------------------------------------------- /root.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- 2 | 3 | (in-package :fmcs) 4 | 5 | #+sbcl 6 | (named-readtables:in-readtable :fare-quasiquote) 7 | 8 | ;;; -------------------------------------------------------------------------- 9 | ;;; Hand coded object standard-class 10 | ;;; -------------------------------------------------------------------------- 11 | 12 | (setq STANDARD-CLASS 13 | (make-mcsobject 14 | :env 15 | (vector 16 | 'isit ; :isit will be set below 17 | 'standard-class ; :name 18 | nil ; :supers 19 | nil ; :cplist 20 | '(isit ; :all-slots 21 | name supers cplist all-slots all-slot-defaults own-slots 22 | methods basicnew-fn slot-accessor-fn subclasses) 23 | '((name nil) ; :all-slot-defaults 24 | (supers nil)(cplist nil)(all-slots nil)(all-slot-defaults nil) 25 | (own-slots nil)(methods (make-hash-table :test #'eq)) 26 | (basicnew-fn nil)(slot-accessor-fn nil) (subclasses nil)) 27 | '(name ; :own-slots 28 | supers cplist all-slots all-slot-defaults own-slots 29 | methods basicnew-fn slot-accessor-fn subclasses) 30 | (make-hash-table :test #'eq) ; :methods 31 | ; :basicnew-fn 32 | #'(lambda (isit &key (name nil) (supers nil) (own-slots nil)) 33 | (send-fast 34 | (make-mcsobject 35 | :env 36 | (vector isit name supers nil nil nil own-slots 37 | (make-hash-table :test #'eq) 38 | nil nil nil)) 39 | :init name supers own-slots)) 40 | ; :slot-accessor-fn 41 | #'(lambda (slot) 42 | (case slot 43 | (isit (index-of-isit)) 44 | (name (index-of-name)) 45 | (supers (index-of-supers)) 46 | (cplist (index-of-cplist)) 47 | (all-slots (index-of-all-slots)) 48 | (own-slots (index-of-own-slots)) 49 | (all-slot-defaults (index-of-all-slot-defaults)) 50 | (methods (index-of-methods)) 51 | (basicnew-fn (index-of-basicnew-fn)) 52 | (slot-accessor-fn (index-of-slot-accessor-fn)) 53 | (subclasses (index-of-subclasses)) 54 | (t (error "no slot")))) 55 | nil ; :subclasses 56 | ))) 57 | 58 | ;;; Slot 'isit of standard-class have to be set to itself 59 | 60 | (setf (svref (mcs-env standard-class) (index-of-isit)) standard-class) 61 | 62 | ;;; ---- INSTANCE CREATOR METHOD ---- 63 | 64 | (defmethod (standard-class :new) (&rest inits) 65 | (apply (mcs-get-slot inst-env (index-of-basicnew-fn)) 66 | self inits)) 67 | 68 | ;;; ---- INITIALIZE METHOD ---- 69 | 70 | (defmethod (standard-class :init) (&rest inits) 71 | (declare (ignore inits)) 72 | (send-self :compute-cplist) 73 | (send-self :inherit-slots-with-defaults) 74 | (send-self :compute-slot-accessor-fn) 75 | (send-self :extend-subclasses-of-supers) 76 | (send-self :compute-slot-access-methods) 77 | (send-self :compute-basicnew-fn) 78 | self) 79 | 80 | ;;; -------------------------------------------------------------------------- 81 | ;;; Hand coded object standard-object 82 | ;;; -------------------------------------------------------------------------- 83 | 84 | (setq STANDARD-OBJECT 85 | (make-mcsobject 86 | :env 87 | (vector 88 | standard-class ; :isit 89 | 'standard-object ; :name 90 | nil ; :supers 91 | nil ; :cplist 92 | '(isit) ; :all-slots 93 | nil ; :all-slot-defaults 94 | '(isit) ; :own-slots 95 | (make-hash-table :test #'eq) ; :methods 96 | #'(lambda (isit) ; :basicnew-fn 97 | (send-fast 98 | (make-mcsobject :env (vector isit)) 99 | :init)) 100 | #'(lambda (slot) ; :slot-accessor-fn 101 | (case slot 102 | (isit (index-of-isit)) 103 | (t (error "no slot")))) 104 | (list standard-class) ; :subclasses 105 | ))) 106 | 107 | (setf (slot-value standard-object 'cplist) (list standard-object)) 108 | (setf (slot-value standard-class 'supers) (list standard-object)) 109 | (setf (slot-value standard-class 'cplist) (list standard-class standard-object)) 110 | 111 | ;;; ---- INITIALIZE METHOD ---- 112 | 113 | (defmethod (standard-object :init) (&rest inits) 114 | (declare (ignore inits)) 115 | self) 116 | 117 | #+sbcl 118 | (named-readtables:in-readtable :standard) 119 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thephoeron/fmcs/6109fb3ea5f1d3ff581f9c930fcd13da5702ee13/test/package.lisp -------------------------------------------------------------------------------- /test/suite.lisp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thephoeron/fmcs/6109fb3ea5f1d3ff581f9c930fcd13da5702ee13/test/suite.lisp -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- 2 | 3 | (in-package :fmcs) 4 | 5 | #+sbcl 6 | (named-readtables:in-readtable :fare-quasiquote) 7 | 8 | ;;; -------------------------------------------------------------------------- 9 | ;;; Trace utilities 10 | ;;; -------------------------------------------------------------------------- 11 | 12 | (defvar *indent-for-methods-trace* 0.) 13 | (declaim (fixnum *indent-for-methods-trace*)) 14 | 15 | (defun increment-indent-for-methods-trace () 16 | (setq *indent-for-methods-trace* (+ (the fixnum *indent-for-methods-trace*) 2.))) 17 | 18 | (defun decrement-indent-for-methods-trace () 19 | (setq *indent-for-methods-trace* (- (the fixnum *indent-for-methods-trace*) 2.))) 20 | 21 | (defun TRACED-DEMON-COMBINATION (self class-env inst-env selector applicable-methods args) 22 | (let ((before-methods (before-of applicable-methods)) 23 | (primary-methods (primary-of applicable-methods)) 24 | (after-methods (after-of applicable-methods)) 25 | (class-name (mcs-get-slot class-env (index-of-name))) 26 | (result nil)) 27 | (declare (list before-methods primary-methods after-methods)) 28 | (format *trace-output* "~%~V@T Entering method ~S of class ~S" 29 | (increment-indent-for-methods-trace) selector class-name) 30 | (format *trace-output* "~%~V@T Executing ~S before methods" 31 | *indent-for-methods-trace* (length before-methods)) 32 | (loop 33 | (if (null before-methods) (return ())) 34 | (apply (pop before-methods) 35 | self class-env inst-env args)) 36 | (setq result 37 | (apply (first primary-methods) 38 | self class-env inst-env :primary-caller (rest primary-methods) 39 | args args)) 40 | (format *trace-output* "~%~V@T Executing ~S after methods" 41 | *indent-for-methods-trace* (length after-methods)) 42 | (loop 43 | (if (null after-methods) (return ())) 44 | (apply (pop after-methods) 45 | self class-env inst-env args)) 46 | (format *trace-output* "~%~V@T Exiting method ~S of class ~S with result: ~S" 47 | *indent-for-methods-trace* selector class-name result) 48 | (decrement-indent-for-methods-trace) 49 | result)) 50 | 51 | (defun TRACED-SIMPLE-COMBINATION (self class-env inst-env selector applicable-methods args) 52 | (let ((primary-methods (primary-of applicable-methods)) 53 | (class-name (mcs-get-slot class-env (index-of-name))) 54 | result) 55 | (increment-indent-for-methods-trace) 56 | (format *trace-output* "~%~V@T Entering method ~S of class ~S" 57 | *indent-for-methods-trace* selector class-name) 58 | (setq result 59 | (apply (first primary-methods) 60 | self class-env inst-env :primary-caller (rest primary-methods) 61 | args args)) 62 | (format *trace-output* "~%~V@T Exiting method ~S of class ~S with result: ~S" 63 | *indent-for-methods-trace* selector class-name result) 64 | (decrement-indent-for-methods-trace) 65 | result)) 66 | 67 | ;;;(export 'MCS-TRACE) 68 | (defun MCS-TRACE (a_class selector) 69 | (let* ((class-env (mcs-env a_class)) 70 | (combined-method (get-combined-method selector))) 71 | (if combined-method 72 | (let ((combination-fn (svref combined-method 0))) 73 | (setf (svref combined-method 0) 74 | (case combination-fn 75 | (simple-method-combination 'traced-simple-combination) 76 | (demon-method-combination 'traced-demon-combination) 77 | (standard-method-combination 'traced-standard-combination) 78 | (t combination-fn)))) 79 | (progn 80 | (combine-class-method a_class selector) 81 | (if (get-combined-method selector) 82 | (mcs-trace a_class selector)))))) 83 | 84 | ;;;(export 'MCS-UNTRACE) 85 | (defun MCS-UNTRACE (a_class selector) 86 | (let* ((class-env (mcs-env a_class)) 87 | (combined-method (get-combined-method selector))) 88 | (if combined-method 89 | (let ((combination-fn (svref combined-method 0))) 90 | (setf (svref combined-method 0) 91 | (case combination-fn 92 | (traced-simple-combination 'simple-method-combination) 93 | (traced-demon-combination 'demon-method-combination) 94 | (traced-standard-combination 'standard-method-combination) 95 | (t combination-fn))))))) 96 | 97 | ;;;(export 'MCS-IS-TRACED) 98 | (defun MCS-IS-TRACED (a_class selector) 99 | (let* ((class-env (mcs-env a_class)) 100 | (combined-method (get-combined-method selector))) 101 | (if combined-method 102 | (case (svref combined-method 0) 103 | (traced-simple-combination t) 104 | (traced-demon-combination t) 105 | (traced-standard-combination t) 106 | (t nil))))) 107 | 108 | (defmethod (standard-class :trace-methods) (&rest selectors) 109 | (dolist (selector selectors 'done) 110 | (mcs-trace self selector))) 111 | 112 | (defmethod (standard-class :untrace-methods) (&rest selectors) 113 | (dolist (selector selectors 'done) 114 | (mcs-untrace self selector))) 115 | 116 | ;;; -------------------------------------------------------------------------- 117 | ;;; Protocol utilities 118 | ;;; -------------------------------------------------------------------------- 119 | 120 | (defmethod (standard-class :get-local-protocol) () 121 | (let ((protocol ())) 122 | (maphash #'(lambda (key val) 123 | (if (method-entry-methods-list val) 124 | (setq protocol (cons key protocol)))) 125 | (mcs-get-slot inst-env (index-of-methods))) 126 | protocol)) 127 | 128 | (defmethod (standard-class :get-protocol) () 129 | (let ((protocol ()) 130 | (opened (mcs-get-slot inst-env (index-of-cplist)))) 131 | (loop 132 | (if (null opened) (return ())) 133 | (maphash #'(lambda (key val) 134 | (declare (ignore val)) 135 | (setq protocol (cons key protocol))) 136 | (mcs-slot-value (pop opened) (index-of-methods)))) 137 | (remove-duplicates protocol :test #'eq))) 138 | 139 | ;;; -------------------------------------------------------------------------- 140 | ;;; Other utilities 141 | ;;; -------------------------------------------------------------------------- 142 | 143 | (defun WHERE-METHOD-LOOKUP (class-env a_selector) 144 | (declare (inline GET-METHOD-ENTRY)) 145 | (let ((r-class-precedence-list 146 | (reverse (mcs-get-slot class-env (index-of-cplist)))) 147 | (around-methods nil) (before-methods nil) 148 | (primary-methods nil) (after-methods nil)) 149 | (loop 150 | (if (null r-class-precedence-list) 151 | (return 152 | (values (if primary-methods 153 | (if around-methods 154 | 'standard-method-combination 155 | (if (or before-methods after-methods) 156 | 'demon-method-combination 157 | 'simple-method-combination)) 158 | (if (or after-methods before-methods around-methods) 159 | 'missing-primary-method)) 160 | (list around-methods before-methods 161 | primary-methods (reverse after-methods))))) 162 | (let* ((c-class (pop r-class-precedence-list)) 163 | (method (get-method-entry c-class a_selector))) 164 | (if method 165 | (let ((own-methods-list (method-entry-methods-list method))) 166 | (let ((around-method (get-qualified-method :around own-methods-list)) 167 | (before-method (get-qualified-method :before own-methods-list)) 168 | (primary-method (get-qualified-method :primary own-methods-list)) 169 | (after-method (get-qualified-method :after own-methods-list)) 170 | (c-class-name (slot-value c-class 'name))) 171 | (if before-method 172 | (setq before-methods (cons c-class-name before-methods))) 173 | (if after-method 174 | (setq after-methods (cons c-class-name after-methods))) 175 | (if primary-method 176 | (setq primary-methods (cons c-class-name primary-methods))) 177 | (if around-method 178 | (setq around-methods (cons c-class-name around-methods)))))))))) 179 | 180 | (defmethod (standard-object :how-combined) (selector) 181 | (multiple-value-bind 182 | (method-combination-fn where-defined-list) 183 | (where-method-lookup class-env selector) 184 | (if (null method-combination-fn) 185 | (progn 186 | (format t "~%no method, :default-handler is called") 187 | (send-self :how-combined :default-handler)) 188 | (progn 189 | (if (eq method-combination-fn 'missing-primary-method) 190 | (format t "~%illegal combination, missing primary method") 191 | (format t "~%selector ~S has combination type: ~S" 192 | selector method-combination-fn)) 193 | (if (first where-defined-list) 194 | (format t "~%around methods are defined in class: ~{~% ~s ~}" 195 | (first where-defined-list))) 196 | (if (second where-defined-list) 197 | (format t "~%before methods are defined in class: ~{~% ~s ~}" 198 | (second where-defined-list))) 199 | (if (third where-defined-list) 200 | (format t "~%primary methods are defined in class: ~{~% ~s ~}" 201 | (third where-defined-list))) 202 | (if (fourth where-defined-list) 203 | (format t "~%after methods are defined in class: ~{~% ~s ~}" 204 | (fourth where-defined-list))))))) 205 | 206 | (defmethod (standard-object :which-operations) () 207 | (send-fast (get-slot 'isit) :get-protocol)) 208 | 209 | (defmethod (standard-object :describe) () 210 | (format t "~&~S, an object of class ~S,~% has instance variable values:~%" 211 | self (get-class-slot 'name)) 212 | (dolist (ivar (get-class-slot 'all-slots)) 213 | (format t "~% ~S:~27T~S" ivar (slot-value self ivar)))) 214 | 215 | (defmethod (standard-object :describe-short) () 216 | (format t "an object of class ~S with instance variable values:~%~S" 217 | (get-class-slot 'name) 218 | (rest (mapcar #'(lambda (ivar) 219 | `(,ivar ,(slot-value self ivar))) 220 | (get-class-slot 'all-slots))))) 221 | 222 | (defmethod (standard-object :apropos) (substring) 223 | (remove nil 224 | (mapcar #'(lambda (method) 225 | (if (search substring (string method) 226 | :test #'char-equal) method)) 227 | (send-fast (get-slot 'isit) :get-protocol)) 228 | :test #'eq)) 229 | 230 | #+sbcl 231 | (named-readtables:in-readtable :standard) 232 | 233 | ;;; eof 234 | --------------------------------------------------------------------------------