├── .gitignore ├── .travis.yml ├── README.md ├── circle.yml ├── defclass-std-test.asd ├── defclass-std.asd ├── src └── defclass-std.lisp └── t └── defclass-std.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: required 3 | env: 4 | matrix: 5 | - LISP=abcl 6 | - LISP=sbcl COVERALLS=true 7 | - LISP=ccl 8 | - LISP=clisp 9 | - LISP=cmucl 10 | - LISP=ecl 11 | 12 | matrix: 13 | allow_failures: 14 | - env: LISP=abcl # JVM build goes wrong too many times 15 | - env: LISP=clisp # wait for cl-coveralls dependencies to support it 16 | - env: LISP=cmucl # wait for CIM to support it 17 | - env: LISP=ecl # wait for cl-coveralls dependencies to support it 18 | 19 | install: 20 | - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh; 21 | 22 | script: 23 | - cl -l defclass-std -l prove -l cl-coveralls 24 | -e '(progn 25 | (setf prove:*debug-on-error* t 26 | *debugger-hook* (lambda (c h) 27 | (declare (ignore c h)) 28 | (uiop:quit -1))) 29 | (or (coveralls:with-coveralls (:exclude "t") 30 | (prove:run :defclass-std-test)) 31 | (uiop:quit -1)))' 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # defclass-std - Standard class writing macro 2 | 3 | 4 | 5 | 6 | 7 | 8 | Most times, when sketching out a new class, I often commit lots of typos and forget to add an `:initform`. 9 | 10 | Also, the throw away class designed in the beginning may thrive and stay the same. If only there was a way to overcome these problems... There is! 11 | 12 | This simple macro atempts to give a very DRY and succint interface to the common `DEFCLASS` form. The goal is to offer most of the capabilities of a normal `DEFCLASS`, only in a more compact way. 13 | 14 | Everything compiles down to `defclass`. 15 | 16 | But with every `defclass` usually comes a `print-object` method. So we 17 | provide a simple `define-print-object/std` macro that defines a 18 | `print-object` method and prints all the class slots. 19 | 20 | **About this fork**: 21 | 22 | - the [original project](https://github.com/EuAndreh/defclass-std) by EuAndreh is archived :/ 23 | - added `define-print-object/std` (<2024-09-27>) 24 | - (`print-object/std` is the old name, deprecated) 25 | - added docstrings, organized the README 26 | 27 | 28 | ## Usage 29 | 30 | We provide `defclass/std`, which is close to `defclass`, and 31 | `class/std`, which is even shorter and close to `defstruct`. 32 | 33 | First, install the library and import the `defclass/std` symbol: 34 | 35 | ```lisp 36 | * (ql:quickload :defclass-std) ;; warn: this fork is not in Quicklisp 37 | ; => (:DEFCLASS-STD) 38 | * (import 'defclass-std:defclass/std) 39 | ; => T 40 | ``` 41 | 42 | ### defclass/std 43 | 44 | A simple class defined with `DEFCLASS/STD` looks like this: 45 | ```lisp 46 | (defclass/std example () 47 | ((slot1 slot2 slot3))) 48 | 49 | ; which expands to: 50 | 51 | (DEFCLASS EXAMPLE () 52 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 53 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 54 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL))) 55 | ``` 56 | As you can see, by default, the macro adds three options: 57 | 1. `:accessor` + the name of the slot 58 | 2. `:initarg` + the name of the slot 59 | 3. `:initform nil` 60 | 61 | So, with this short definition, you have `:initargs` defined for you, 62 | all `:initform`s are set to NIL instead of being unbound, and you now 63 | have generic methods (accessors) to get and set the slots: 64 | 65 | ~~~lisp 66 | (defparameter *example1* (make-instance 'example :slot1 "one")) 67 | ;; *EXAMPLE1* 68 | 69 | (slot1 *) 70 | ;; => "one" 71 | 72 | (slot2 **) 73 | ;; => NIL (instead of unbound slot error) 74 | ~~~ 75 | 76 | ### defclass/std vs defclass syntax 77 | 78 | Don't rush, there's is a little syntax difference, look: 79 | 80 | ~~~lisp 81 | (defclass example () 82 | (slot1 slot2 slot3)) 83 | ~~~ 84 | 85 | VS 86 | 87 | ~~~lisp 88 | (defclass/std example () 89 | ((slot1 slot2 slot3))) 90 | ~~~ 91 | 92 | There is an extra level of parentheses, as if you were already giving slot options as in: 93 | 94 | ~~~lisp 95 | (defclass example () 96 | ((slot1 :initarg :slot1) 97 | (slot2 :initarg slot2))) 98 | ~~~ 99 | 100 | ### defclass/std options 101 | 102 | To declare the **type** of a slot or to add **documentation** to a slot, use `:type` and `:doc`, respectively. 103 | 104 | ~~~lisp 105 | (defclass/std example-doc () 106 | ((slot1 :doc "doc1") 107 | (slot2 :doc "doc2"))) 108 | ~~~ 109 | 110 | If you want to **change the `:initform` value**, you can use the `:std` option: 111 | ```lisp 112 | (defclass std-test () 113 | ((slot :std 1))) 114 | 115 | ; expands to: 116 | 117 | (DEFCLASS STD-TEST () 118 | ((SLOT :ACCESSOR SLOT :INITARG :SLOT :INITFORM 1))) 119 | ``` 120 | 121 | If you want to **omit the `:initform` option,** you have two ways: 122 | 123 | 1. Use `:std :unbound` explicitly 124 | 2. Change the value of `*default-std*`. By default it is set to `T`, so, when the `:std` option is omitted, `:initform` is set to nil. When `*default-std*` is set to nil, `:initform` is omitted when `:std` is omitted. 125 | ```lisp 126 | (defclass/std omit-std () 127 | ((slot :std :unbound))) 128 | 129 | ; which is (semantically) equivalent to: 130 | (eval-when (:compile-toplevel :load-toplevel :execute) 131 | (setf *default-std* nil)) 132 | (defclass/std omit-std () 133 | ((slot))) 134 | 135 | ; which (both) expands to: 136 | 137 | (DEFCLASS OMIT-STD () 138 | ((SLOT :ACCESSOR SLOT :INITARG :SLOT))) 139 | ``` 140 | 141 | **Enable or disable accessors, readers, writers and initargs**. 142 | 143 | `:a`, `:i`, `:r` and `:w` are connected: when all of them are omitted, `:a` and `:i` are inserted by default. 144 | 145 | `:a` stands for `:accessor`, `:i` stands for `:initarg`, `:r` stands for `:reader` and `:w` stands for `:writer`. 146 | 147 | If any of those is present, the default (`:a` and `:i`) is omitted. 148 | ```lisp 149 | (defclass/std airw () 150 | ((slot1 slot2) 151 | (slot3 slot4 :r) 152 | (slot5 :w) 153 | (slot6 :a) 154 | (slot7 :ri))) 155 | 156 | ; which expands to: 157 | 158 | (DEFCLASS AIRW () 159 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 160 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 161 | (SLOT3 :READER SLOT3 :INITFORM NIL) 162 | (SLOT4 :READER SLOT4 :INITFORM NIL) 163 | (SLOT5 :WRITER SLOT5 :INITFORM NIL) 164 | (SLOT6 :ACCESSOR SLOT6 :INITFORM NIL) 165 | (SLOT7 :READER SLOT7 :INITARG :SLOT7 :INITFORM NIL))) 166 | ``` 167 | Note that slot7 has an `:ri` option. That's just `:r` and `:i` together. 168 | 169 | If you want to use `:r` and `:w` together, use `:a` instead, or you'll get an error. The same stands for `:a` + `:r` and `:a` + `:w`. 170 | 171 | You can choose to **add the class name as a prefix** for the acessor/reader/writer function. Just put `:with` or `:with-prefix` option. 172 | 173 | ```lisp 174 | (defclass/std example () 175 | ((slot1 :with) 176 | (slot2))) 177 | 178 | ; which expands to: 179 | 180 | (DEFCLASS EXAMPLE () 181 | ((SLOT1 :ACCESSOR EXAMPLE-SLOT1 :INITARG :SLOT1 :INITFORM NIL) 182 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL))) 183 | ``` 184 | 185 | To make a slot **static (class-allocated)**, use `:@@` or `:static`. 186 | 187 | You can also **add the prefix by default** by changing the value of the `*with-prefix*` special variable (defaults to `nil`): 188 | ```lisp 189 | (eval-when (:compile-toplevel :load-toplevel :execute) 190 | (setf *with-prefix* t)) 191 | (defclass/std pre () 192 | ((fix))) 193 | 194 | ; which expands to: 195 | 196 | (DEFCLASS PRE () 197 | ((FIX :ACCESSOR PRE-FIX :INITARG :FIX))) 198 | ``` 199 | 200 | Unknown keywords are left intact: 201 | ```lisp 202 | (defclass/std unknown () 203 | ((slot :unknown :keywords))) 204 | 205 | ; which expands to: 206 | 207 | (DEFCLASS UNKNOWN () 208 | ((SLOT :ACCESSOR SLOT :INITARG :SLOT :INITFORM NIL :KEYWORDS :UNKNOWN))) 209 | 210 | 211 | ; Or, even using custom accessors: 212 | 213 | (defclass/std unknown () 214 | ((slot :unknown :wi :keywords))) 215 | 216 | ; which expands to: 217 | 218 | (DEFCLASS UNKNOWN () 219 | ((SLOT :WRITER SLOT :INITARG :SLOT :INITFORM NIL :KEYWORDS :UNKNOWN))) 220 | ``` 221 | 222 | ## class/std is even shorter 223 | 224 | Usage: 225 | 226 | ~~~lisp 227 | (class/std classname slot1 slot2 … slotn) 228 | ~~~ 229 | 230 | is equivalent to 231 | 232 | ~~~lisp 233 | (defclass/std classname () 234 | ((slot1 slot2 … slotn))) 235 | ~~~ 236 | 237 | is equivalent to 238 | 239 | ~~~lisp 240 | (defclass classname () 241 | ((slot1 :accessor slot1 :initarg :slot1 :initform nil) 242 | (slot2 :accessor slot2 :initarg :slot2 :initform nil) 243 | … 244 | (slotn :accessor slotn :initarg :slotn :initform nil))) 245 | ~~~ 246 | 247 | ## class/std vs defstruct 248 | 249 | structures are defined with: 250 | 251 | ~~~lisp 252 | (defstruct structexample slot1 slot2 slot3) 253 | ~~~ 254 | 255 | they are created with `make-structexample` and accessor functions are 256 | named with the struct name prefix, as `structexample-slot1`. 257 | 258 | `class/std` has the same creation syntax: 259 | 260 | ~~~lisp 261 | (class/std classname slot1 slot2 slot3) 262 | ~~~ 263 | 264 | and doesn't follow the naming of structs by default. 265 | 266 | 267 | ## define-print-object/std 268 | 269 | Given a class 270 | 271 | ~~~lisp 272 | (defclass/std example () 273 | ((slot1 slot2 slot3))) 274 | ~~~ 275 | 276 | use: 277 | 278 | ~~~lisp 279 | (define-print-object/std example) 280 | ~~~ 281 | 282 | which expands to 283 | 284 | ~~~lisp 285 | (defmethod print-object ((obj example) stream) 286 | (print-unreadable-object (obj stream :type t :identity t) 287 | (format stream \"~{~a~^ ~}\" (collect-object-slots obj)))) 288 | ~~~ 289 | 290 | Now `example` objects show all their slots' values: 291 | 292 | ~~~lisp 293 | (make-instance 'example) 294 | ;; # 295 | ~~~ 296 | 297 | You can use `define-print-object/std` independently of `defclass/std`. 298 | 299 | Unbound slots show "UNBOUND" (as a string). 300 | 301 | See also `printing-unreadably` to select which slots to print: 302 | 303 | ~~~lisp 304 | (printing-unreadably (field2 field3) (class/std myclass field1 field2 field3)) 305 | ~~~ 306 | 307 | Now what if you want to **remove the print-object method**? You could 308 | write a basic one instead: 309 | 310 | ~~~lisp 311 | (defmethod print-object ((obj example) stream) 312 | (print-unreadable-object (obj stream :type t :identity t) 313 | ;; (format stream \"~a\" (slot1 obj)) 314 | )) 315 | ~~~ 316 | 317 | => `#`. 318 | 319 | 320 | ## Examples 321 | 322 | ```lisp 323 | (defclass/std computer (gadget) 324 | ((screen mouse keyboard :a :type string :with-prefix) 325 | (bluetooth touchpad :wi) 326 | (speaker microphone :r) 327 | (place :@@ :with :doc "Where it is" :r) 328 | (owner :static :std "Me" :w))) 329 | 330 | ; expands to: 331 | 332 | (DEFCLASS COMPUTER (GADGET) 333 | ((SCREEN :ACCESSOR COMPUTER-SCREEN :INITFORM NIL :TYPE STRING) 334 | (MOUSE :ACCESSOR COMPUTER-MOUSE :INITFORM NIL :TYPE STRING) 335 | (KEYBOARD :ACCESSOR COMPUTER-KEYBOARD :INITFORM NIL :TYPE STRING) 336 | (BLUETOOTH :WRITER BLUETOOTH :INITARG :BLUETOOTH :INITFORM NIL) 337 | (TOUCHPAD :WRITER TOUCHPAD :INITARG :TOUCHPAD :INITFORM NIL) 338 | (SPEAKER :READER SPEAKER :INITFORM NIL) 339 | (MICROPHONE :READER MICROPHONE :INITFORM NIL) 340 | (PLACE :READER COMPUTER-PLACE :INITFORM NIL :ALLOCATION :CLASS 341 | :DOCUMENTATION "Where it is") 342 | (OWNER :WRITER OWNER :INITFORM "Me" :ALLOCATION :CLASS))) 343 | ``` 344 | 345 | Real life examples: 346 | 347 | From [cl-inflector](https://github.com/AccelerationNet/cl-inflector/blob/master/langs.lisp][cl-inflector): 348 | ```lisp 349 | (defclass language () 350 | ((name :accessor name :initarg :name :initform nil) 351 | (plurals :accessor plurals :initarg :plurals :initform nil) 352 | (singulars :accessor singulars :initarg :singulars :initform nil) 353 | (uncountables :accessor uncountables :initarg :uncountables :initform nil) 354 | (irregulars :accessor irregulars :initarg :irregulars :initform nil))) 355 | 356 | ; could be written: 357 | 358 | (defclass/std language () 359 | ((name plurals singulars uncountables irregulars))) 360 | 361 | ; or, using CLASS/STD: 362 | 363 | (class/std language name plurals singulars uncountables irregulars) 364 | ``` 365 | From [clack](https://github.com/fukamachi/clack/blob/9804d0b57350032ebdcf8539bae376b5528ac1f6/src/core/handler.lisp): 366 | ```lisp 367 | (defclass () 368 | ((server-name :type keyword 369 | :initarg :server-name 370 | :accessor server-name) 371 | (acceptor :initarg :acceptor 372 | :accessor acceptor))) 373 | 374 | ; could be written (with *default-std* set to nil) 375 | (defclass/std language () 376 | ((server-name :type keyword) 377 | (acceptor))) 378 | ``` 379 | From [RESTAS](https://github.com/archimag/restas/blob/3e37f868141c785d2468fab342d57cca2e2a40dd/src/route.lisp): 380 | ```lisp 381 | (defclass route (routes:route) 382 | ((symbol :initarg :symbol :reader route-symbol) 383 | (module :initarg :module :initform nil :reader route-module) 384 | (required-method :initarg :required-method :initform nil 385 | :reader route-required-method) 386 | (arbitrary-requirement :initarg :arbitrary-requirement :initform nil 387 | :reader route-arbitrary-requirement) 388 | (render-method :initarg :render-method :initform #'identity) 389 | (headers :initarg :headers :initform nil :reader route-headers) 390 | (variables :initarg :variables :initform nil) 391 | (additional-variables :initarg :additional-variables :initform nil))) 392 | 393 | ; could be written 394 | (defclass/std route (routes-route) 395 | ((symbol :ri :with-prefix :std :unbound) 396 | (module required-method arbitrary-requirement 397 | headers variables additional-variables :ri) 398 | (render-method :i :std #'identity) 399 | (header :ir))) 400 | ``` 401 | From [defclass-star example](http://common-lisp.net/project/defclass-star/configuration.lisp.html): 402 | ```lisp 403 | (defclass configuration () 404 | ((package-name :type symbol :initarg :package-name :accessor package-name-of) 405 | (package-nicknames :initform '() :initarg :package-nicknames :accessor package-nicknames-of) 406 | (included-files :initform '() :initarg :included-files :accessor included-files-of) 407 | (gccxml-path :initform "gccxml" :initarg :gccxml-path :accessor gccxml-path-of) 408 | (gccxml-flags :initform "" :initarg :gccxml-flags :accessor gccxml-flags-of) 409 | (hidden-symbols :initform '() :initarg :hidden-symbols :accessor hidden-symbols-of) 410 | (output-filename :initform nil :initarg :output-filename :accessor output-filename-of) 411 | (options :initform (standard-configuration-options) 412 | :initarg :options 413 | :accessor options-of) 414 | (symbol-export-filter :initform 'standard-symbol-export-filter 415 | :type (or (function (symbol)) symbol) 416 | :initarg :symbol-export-filter 417 | :accessor symbol-export-filter-of) 418 | (function-name-transformer :initform 'standard-name-transformer 419 | :type (or (function (string)) symbol) 420 | :initarg :function-name-transformer 421 | :accessor function-name-transformer-of) 422 | (variable-name-transformer :initform 'standard-name-transformer 423 | :type (or (function (string)) symbol) 424 | :initarg :variable-name-transformer 425 | :accessor variable-name-transformer-of) 426 | (type-name-transformer :initform 'standard-name-transformer 427 | :type (or (function (string)) symbol) 428 | :initarg :type-name-transformer 429 | :accessor type-name-transformer-of) 430 | (temp-directory :initform (make-pathname :directory "/tmp") 431 | :initarg :temp-directory 432 | :accessor temp-directory-of) 433 | (working-directory :initform *default-pathname-defaults* 434 | :initarg :working-directory 435 | :accessor working-directory-of))) 436 | 437 | ;;; And the equivalent defclass* version (56 tree leaves): 438 | (defclass* configuration () 439 | ((package-name 440 | :type symbol) 441 | (package-nicknames '()) 442 | (included-files '()) 443 | (gccxml-path "gccxml") 444 | (gccxml-flags "") 445 | (hidden-symbols '()) 446 | (output-filename nil) 447 | (options (standard-configuration-options)) 448 | (symbol-export-filter 'standard-symbol-export-filter 449 | :type (or (function (symbol)) symbol)) 450 | (function-name-transformer 'standard-name-transformer 451 | :type (or (function (string)) symbol)) 452 | (variable-name-transformer 'standard-name-transformer 453 | :type (or (function (string)) symbol)) 454 | (type-name-transformer 'standard-name-transformer 455 | :type (or (function (string)) symbol)) 456 | (temp-directory (make-pathname :directory "/tmp")) 457 | (working-directory *default-pathname-defaults*))) 458 | 459 | ;; And the equivalent defclass/std version (46 tree leaves): 460 | (defclass/std configuration () 461 | ((package-name :type symbol :std :unbound) 462 | (package-nicknames included-files hidden-symbols output-filename) 463 | (gccxml-path :std "gccxml") 464 | (gccxml-flags :std "") 465 | (options :std (standard-configuration-options)) 466 | (symbol-export-filter :std 'standard-symbol-export-filter 467 | :type (or (function (symbol)) symbol)) 468 | (function-name-transformer variable-name-transformer type-name-transformer 469 | :std 'standard-name-transformer 470 | :type (or (function (string)) symbol)) 471 | (temp-directory :std (make-pathname :directory "/tmp")) 472 | (working-directory :std *default-pathname-defaults*))) 473 | ``` 474 | From [cl-hue](https://github.com/jd/cl-hue/blob/master/cl-hue.lisp): 475 | ```lisp 476 | (defclass light () 477 | ((bridge :initarg :bridge :accessor light-bridge) 478 | (number :initarg :number :accessor light-number) 479 | (type :initarg :type :accessor light-type) 480 | (name :initarg :name :accessor light-name) 481 | (modelid :initarg :modelid :accessor light-modelid) 482 | (uniqueid :initarg :uniqueid :accessor light-uniqueid) 483 | (swversion :initarg :swversion :accessor light-swversion) 484 | (pointsymbol :initarg :pointsymbol :accessor light-pointsymbol) 485 | (on :initarg :on :accessor light-on-p) 486 | (brightness :initarg :brightness :accessor light-brightness) 487 | (hue :initarg :hue :accessor light-hue) 488 | (saturation :initarg :saturation :accessor light-saturation) 489 | (xy :initarg :xy :accessor light-xy) 490 | (ct :initarg :ct :accessor light-ct) 491 | (alert :initarg :alert :accessor light-alert) 492 | (effect :initarg :effect :accessor light-effect) 493 | (colormode :initarg :colormode :accessor light-colormode) 494 | (reachable :initarg :reachable :accessor light-reachable-p))) 495 | 496 | ; could be written: 497 | (defclass/std light () 498 | ((bridge number type name modelid uniqueid swversion pointsymbol on brightness 499 | hue saturation xy ct alert effect colormode reachable 500 | :with-prefix :std :unbound))) 501 | 502 | ; or, using class/std: 503 | 504 | (class/std light 505 | bridge number type name modelid uniqueid swversion pointsymbol on brightness 506 | hue saturation xy ct alert effect colormode reachable 507 | :std :unbound :with) 508 | 509 | ; or, with *default-std* set to nil and *with-prefix* set to t: 510 | 511 | (class/std light 512 | bridge number type name modelid uniqueid swversion pointsymbol on brightness 513 | hue saturation xy ct alert effect colormode reachable) 514 | ``` 515 | 516 | There's a shortcut to setup a basic printing behaviour of a class, using `printing-unreadably`, but see also `define-print-object/std` for this now. 517 | 518 | ```lisp 519 | (printing-unreadably (field2 field3) (class/std myclass field1 field2 field3)) 520 | 521 | ; which expands to: 522 | 523 | (PROGN 524 | (CLASS/STD MYCLASS FIELD1 FIELD2 FIELD3) 525 | (DEFMETHOD PRINT-OBJECT ((MYCLASS MYCLASS) #:STREAM1722) 526 | (PRINT-UNREADABLE-OBJECT (MYCLASS #:STREAM1722 :TYPE T :IDENTITY T) 527 | (FORMAT #:STREAM1722 "FIELD2: ~s, FIELD3: ~s" 528 | (FIELD2 MYCLASS) (FIELD3 MYCLASS))))) 529 | ``` 530 | 531 | ## Limitations 532 | 533 | Limitations are in the tools integration. 534 | 535 | If you are faced with these limitations and the solution doesn't suit you, 536 | just transform your 537 | defclass/std to a regular defclass. You can see the maroexpansion with 538 | `C-c M` (`slime-macroexpand-1`) and copy-paste the expansion (followed 539 | by M-x downcase-region …). 540 | 541 | ### Limitation 1 542 | 543 | In Emacs and Slime (and any good editor), when the point is inside a 544 | class definition, you can press `C-c C-y` (`slime-call-defun`) to send 545 | a `make-instance` form on the REPL: 546 | 547 | ~~~lisp 548 | (defclass test () 549 | (a b)|) ;; <-- | point is here 550 | ~~~ 551 | 552 | C-c C-y => 553 | 554 | CL-REPL> (make-instance 'home-package::test |) 555 | 556 | This doesn't work *by default* inside a `defclass/std` form, you get "not in a function definition". But we can have it. 557 | 558 | ### Solution 1 559 | 560 | We can overwrite 2 Slime functions to have this keybinding back: 561 | 562 | ```lisp 563 | ;; originally in slime-repl.el 564 | (defun slime-call-defun () 565 | "Insert a call to the toplevel form defined around point into the REPL." 566 | (interactive) 567 | (cl-labels ((insert-call 568 | (name &key (function t) 569 | defclass) 570 | (let* ((setf (and function 571 | (consp name) 572 | (= (length name) 2) 573 | (eql (car name) 'setf))) 574 | (symbol (if setf 575 | (cadr name) 576 | name)) 577 | (qualified-symbol-name 578 | (slime-qualify-cl-symbol-name symbol)) 579 | (symbol-name (slime-cl-symbol-name qualified-symbol-name)) 580 | (symbol-package (slime-cl-symbol-package 581 | qualified-symbol-name)) 582 | (call (if (cl-equalp (slime-lisp-package) symbol-package) 583 | symbol-name 584 | qualified-symbol-name))) 585 | (slime-switch-to-output-buffer) 586 | (goto-char slime-repl-input-start-mark) 587 | (insert (if function 588 | "(" 589 | " ")) 590 | (when setf 591 | (insert "setf (")) 592 | (if defclass 593 | (insert "make-instance '")) 594 | (insert call) 595 | (cond (setf 596 | (insert " ") 597 | (save-excursion (insert ") )"))) 598 | (function 599 | (insert " ") 600 | (save-excursion (insert ")")))) 601 | (unless function 602 | (goto-char slime-repl-input-start-mark))))) 603 | (let ((toplevel (slime-parse-toplevel-form '(:defun :defgeneric :defmacro :define-compiler-macro 604 | :defmethod :defparameter :defvar :defconstant :defclass 605 | :defclass/std)))) ;; <---- ADDED 606 | (if (symbolp toplevel) 607 | (error "Not in a function definition") 608 | (slime-dcase toplevel 609 | (((:defun :defgeneric :defmacro :define-compiler-macro) symbol) 610 | (insert-call symbol)) 611 | ((:defmethod symbol &rest args) 612 | (declare (ignore args)) 613 | (insert-call symbol)) 614 | (((:defparameter :defvar :defconstant) symbol) 615 | (insert-call symbol :function nil)) 616 | (((:defclass) symbol) 617 | (insert-call symbol :defclass t)) 618 | (((:defclass/std) symbol) ;; <----------- ADDED 619 | (insert-call symbol :defclass t)) 620 | (t 621 | (error "Not in a function definition"))))))) 622 | ``` 623 | 624 | and 625 | 626 | ```lisp 627 | ;; originally in slime-parse.el 628 | (defun slime-parse-context (name) 629 | (save-excursion 630 | (cond ((slime-in-expression-p '(defun *)) `(:defun ,name)) 631 | ((slime-in-expression-p '(defmacro *)) `(:defmacro ,name)) 632 | ((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name)) 633 | ((slime-in-expression-p '(setf *)) 634 | ;;a setf-definition, but which? 635 | (backward-up-list 1) 636 | (slime-parse-context `(setf ,name))) 637 | ((slime-in-expression-p '(defmethod *)) 638 | (unless (looking-at "\\s ") 639 | (forward-sexp 1)) ; skip over the methodname 640 | (let (qualifiers arglist) 641 | (cl-loop for e = (read (current-buffer)) 642 | until (listp e) do (push e qualifiers) 643 | finally (setq arglist e)) 644 | `(:defmethod ,name ,@qualifiers 645 | ,(slime-arglist-specializers arglist)))) 646 | ((and (symbolp name) 647 | (slime-in-expression-p `(,name))) 648 | ;; looks like a regular call 649 | (let ((toplevel (ignore-errors (slime-parse-toplevel-form)))) 650 | (cond ((slime-in-expression-p `(setf (*))) ;a setf-call 651 | (if toplevel 652 | `(:call ,toplevel (setf ,name)) 653 | `(setf ,name))) 654 | ((not toplevel) 655 | name) 656 | ((slime-in-expression-p `(labels ((*)))) 657 | `(:labels ,toplevel ,name)) 658 | ((slime-in-expression-p `(flet ((*)))) 659 | `(:flet ,toplevel ,name)) 660 | (t 661 | `(:call ,toplevel ,name))))) 662 | ((slime-in-expression-p '(define-compiler-macro *)) 663 | `(:define-compiler-macro ,name)) 664 | ((slime-in-expression-p '(define-modify-macro *)) 665 | `(:define-modify-macro ,name)) 666 | ((slime-in-expression-p '(define-setf-expander *)) 667 | `(:define-setf-expander ,name)) 668 | ((slime-in-expression-p '(defsetf *)) 669 | `(:defsetf ,name)) 670 | ((slime-in-expression-p '(defvar *)) `(:defvar ,name)) 671 | ((slime-in-expression-p '(defparameter *)) `(:defparameter ,name)) 672 | ((slime-in-expression-p '(defconstant *)) `(:defconstant ,name)) 673 | ((slime-in-expression-p '(defclass *)) `(:defclass ,name)) 674 | ((slime-in-expression-p '(defclass/std *)) `(:defclass ,name)) ;; <-- ADDED 675 | ((slime-in-expression-p '(defpackage *)) `(:defpackage ,name)) 676 | ((slime-in-expression-p '(defstruct *)) 677 | `(:defstruct ,(if (consp name) 678 | (car name) 679 | name))) 680 | (t 681 | name)))) 682 | ``` 683 | 684 | 685 | ### ~~Limitation 2~~ 686 | 687 | Likewise, when the point is on a class name, we can call `M-x 688 | slime-export-class`. This adds the class name and all the 689 | accessors/readers/writers symbols to the `:export` clause of your 690 | package. ~~It doesn't work with a `defclass/std` form.~~ It just works actually. 691 | 692 | 693 | ## Dependencies 694 | This project depends only on [Anaphora](http://common-lisp.net/project/anaphora/) and [Alexandria](https://common-lisp.net/project/alexandria/) libraries. The test package uses the [prove](github.com/fukamachi/prove) test library. 695 | 696 | ## Installation 697 | Available on [Quicklisp](http://quicklisp.org): 698 | ``` 699 | (ql:quickload :defclass-std) 700 | ``` 701 | 702 | *warn: this fork is not (yet?) in Quicklisp* 703 | 704 | ## Bugs 705 | If you find any bug or inconsistency in the code, or if you find it too hard to use, please, feel free to open an issue. 706 | 707 | ## Tests 708 | This library is tested under [ABCL](https://common-lisp.net/project/armedbear/), [SBCL](http://www.sbcl.org/), [CCL](http://ccl.clozure.com/), [CLISP](http://www.clisp.org/) and [ECL](https://common-lisp.net/project/ecl/) Common Lisp implementations. 709 | 710 | To run all the defined tests, use: 711 | ```lisp 712 | * (asdf:test-system :defclass-std) 713 | ; prints lots of (colorful) stuff... 714 | ; => T 715 | ``` 716 | Tests are ran with [Travis CI](https://travis-ci.org/EuAndreh/defclass-std) and [Circle CI](https://circleci.com/gh/EuAndreh/defclass-std) using [cl-travis](https://github.com/luismbo/cl-travis), [CIM](https://github.com/KeenS/CIM), [cl-coveralls](https://github.com/fukamachi/cl-coveralls) and [Roswell](https://github.com/snmsts/roswell). Check it out! 717 | 718 | ## Authors 719 | + [André Miranda](https://github.com/EuAndreh) 720 | + [Joram Schrijver](https://github.com/jorams) 721 | + lisp-maintainers 722 | 723 | ## License 724 | [LLGPL](https://tldrlegal.com/license/lisp-lesser-general-public-license#fulltext). 725 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | dependencies: 2 | cache_directories: 3 | - ~/lisp 4 | pre: 5 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/release/scripts/install-for-ci.sh | sh; 6 | - case $CIRCLE_NODE_INDEX in 7 | 0) ros config set default.lisp sbcl-bin ;; 8 | 1) ros install ccl-bin; 9 | ros config set default.lisp ccl-bin ;; 10 | esac 11 | - ros run -- --version 12 | 13 | test: 14 | override: 15 | - ros -s prove -e '(or (prove:run :defclass-std-test) (uiop:quit -1))': {parallel: true} 16 | -------------------------------------------------------------------------------- /defclass-std-test.asd: -------------------------------------------------------------------------------- 1 | (defsystem defclass-std-test 2 | :name "defclass-std-test" 3 | :version "0.1.1" 4 | :author "André Miranda" 5 | :maintainer "André Miranda" 6 | :mailto "andremiramor@gmail.com" 7 | :homepage "https://github.com/EuAndreh/defclass-std" 8 | :bug-tracker "https://github.com/EuAndreh/defclass-std/issues" 9 | :source-control (:git "git@github.com:EuAndreh/defclass-std.git") 10 | :license "LLGPL" 11 | :description "Test system for defclass-std." 12 | :depends-on (defclass-std 13 | prove) 14 | :components ((:module "t" 15 | :components ((:test-file "defclass-std")))) 16 | :defsystem-depends-on (:prove-asdf) 17 | :perform (test-op :after (op c) 18 | (funcall (intern "RUN-TEST-SYSTEM" :prove-asdf) c) 19 | (asdf:clear-system c))) 20 | -------------------------------------------------------------------------------- /defclass-std.asd: -------------------------------------------------------------------------------- 1 | (defsystem defclass-std 2 | :name "defclass-std" 3 | :version "0.2.0" 4 | :author "André Miranda" 5 | :maintainer "vindarel" 6 | :mailto "vindarel@mailz.org" 7 | ;; :homepage "https://github.com/EuAndreh/defclass-std" 8 | :homepage "https://github.com/lisp-maintainers/defclass-std" 9 | :bug-tracker "https://github.com/lisp-maintainers/defclass-std/issues" 10 | :source-control (:git "git@github.com:lisp-maintainers/defclass-std.git") 11 | :license "LLGPL" 12 | :depends-on (alexandria 13 | closer-mop 14 | anaphora) 15 | :components ((:module "src" 16 | :components ((:file "defclass-std"))) 17 | (:static-file "README.md")) 18 | :description "Two shortcut macros to write DEFCLASS and PRINT-OBJECT forms quickly." 19 | :long-description #.(uiop:read-file-string 20 | (uiop:subpathname *load-truename* "README.md")) 21 | :in-order-to ((test-op (test-op defclass-std-test)))) 22 | -------------------------------------------------------------------------------- /src/defclass-std.lisp: -------------------------------------------------------------------------------- 1 | (defpackage defclass-std 2 | (:use cl) 3 | (:import-from alexandria 4 | make-keyword 5 | flatten 6 | symbolicate) 7 | (:import-from anaphora 8 | aif 9 | it) 10 | (:export #:defclass/std 11 | #:*default-std* 12 | #:*with-prefix* 13 | #:class/std 14 | #:define-print-object/std 15 | #:print-object/std 16 | #:printing-unreadably) 17 | (:documentation "Main (and only) project package.")) 18 | (in-package defclass-std) 19 | 20 | (defparameter *fusioned-keyword-combinations* 21 | '(:ai :ar :aw :ia :ir :iw :ra :ri :rw :wa :wi :wr) 22 | "All possible combinations of :a, :i, :r and :w.") 23 | 24 | (defparameter *default-added-keywords* '(:a :i) 25 | "Default abbreviated keywords added when none is found.") 26 | 27 | (defparameter *fusionable-keywords* '(:a :i :w :r) 28 | "All abbreviated keywords that can be fusioned.") 29 | 30 | (defparameter *standalone-keywords* '(:a :i :w :r :static :with :with-prefix :@@)) 31 | 32 | (defparameter *paired-keywords* '(:std :unbound :doc :type)) 33 | 34 | (defparameter *default-std* t 35 | "Special var that changes the behaviour of the DEFCLASS/STD macro. If true, adds a :initform nil by default to every field, when unespecified. If false, adds nothing.") 36 | 37 | (defparameter *with-prefix* nil 38 | "Special var that changes the behaviour of the DEFCLASS/STD macro. If tru, adds the class name as a prefix to every accessor/reader/writer function. If false, without the :with/:with-prefix slot option, adds nothing.") 39 | 40 | (defun remove-all (els list) 41 | "Applies remove recursively. Serves as a version of apeWEOFJIAOPWEIF that keeps the original sequence in the same order." 42 | (if els 43 | (remove-all (cdr els) (remove (car els) list)) 44 | list)) 45 | 46 | (defun extract-slot-names (line) 47 | "Finds all slot names in the LINE." 48 | (if (and line 49 | (not (keywordp (car line)))) 50 | (cons (car line) 51 | (extract-slot-names (cdr line))))) 52 | 53 | (defun extract-unkown-keywords (line) 54 | "Finds pairs of unknown-keywords (and optional values) in LINE." 55 | (if line 56 | (let ((slot (car line))) 57 | (cond ((or (not (keywordp slot)) 58 | (member slot *standalone-keywords*)) 59 | (extract-unkown-keywords (cdr line))) 60 | ((member slot *paired-keywords*) 61 | (extract-unkown-keywords (cddr line))) 62 | ((or (member (second line) (append *standalone-keywords* 63 | *paired-keywords*)) 64 | (null (cdr line))) 65 | (cons (car line) 66 | (extract-unkown-keywords (cdr line)))) 67 | (t (append (subseq line 0 2) 68 | (extract-unkown-keywords (cddr line)))))))) 69 | 70 | (defun split-fusioned-keywords (line) 71 | "Splits the fusioned keyword option, if present." 72 | (aif (intersection line *fusioned-keyword-combinations*) 73 | (append (remove-all it line) 74 | (mapcar #'make-keyword 75 | (flatten (mapcar (lambda (fus-kw) 76 | (coerce (string fus-kw) 77 | 'list)) 78 | it)))) 79 | (if (intersection line *fusionable-keywords*) 80 | line 81 | (append line *default-added-keywords*)))) 82 | 83 | (defun check-for-repeated-keywords (line) 84 | "Verifies if keyword options were repeated. Mainly useful for avoiding things like (:A :AI) together, or (:R :W) instead of (:A)." 85 | (cond ((and (member :w line) 86 | (member :r line)) 87 | (error "Use :A (accessor) instead of :W (writer) and :R (reader) in: ~s" 88 | line)) 89 | ((and (member :w line) 90 | (member :a line)) 91 | (error ":W (writer) and :A (accessor) shouldn't be together in: ~s." 92 | line)) 93 | ((and (member :r line) 94 | (member :a line)) 95 | (error ":R (reader) and :A (accessor) shouldn't be together in: ~s." 96 | line)))) 97 | 98 | (defun replace-keywords (env line prefix) 99 | "Receives a list of slots with keywords and returns a list of lists. Each sublist is a single slot, with all the options appended at the end." 100 | (let ((type (aif (member :type line) (cadr it) t))) 101 | (mapcar (lambda (slot) 102 | (concatenate 'list 103 | (list slot) 104 | (if (member :a line) 105 | (list :accessor (symbolicate prefix slot))) 106 | (if (member :r line) 107 | (list :reader (symbolicate prefix slot))) 108 | (if (member :w line) 109 | (list :writer (symbolicate prefix slot))) 110 | (if (member :i line) 111 | (list :initarg (make-keyword slot))) 112 | (aif (member :std line) 113 | (if (eq (cadr it) :unbound) 114 | nil 115 | (list :initform (cadr it))) 116 | (if *default-std* 117 | (if (subtypep 'null type env) 118 | (list :initform nil)))) 119 | (if (or (member :@@ line) 120 | (member :static line)) 121 | (list :allocation :class)) 122 | (aif (member :doc line) 123 | (list :documentation (cadr it))) 124 | (aif (member :type line) 125 | (list :type (cadr it))) 126 | (extract-unkown-keywords line))) 127 | (extract-slot-names line)))) 128 | 129 | (defmacro defclass/std (name direct-superclasses direct-slots &rest options 130 | &environment env) 131 | "Shortcut macro to the DEFCLASS macro. 132 | 133 | (defclass/std example () 134 | ((slot1 slot2 slot3))) 135 | 136 | expands to: 137 | 138 | (DEFCLASS EXAMPLE () 139 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 140 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 141 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL))) 142 | 143 | Each slot definition accepts options: 144 | 145 | :std 1 => changes the :initform to 1. It can be :unbound. 146 | :with or :with-prefix => creates accessors with the class name as prefix. 147 | 148 | See the README for more. 149 | 150 | See also `class/std' and `print-object/std'. 151 | " 152 | `(defclass ,name ,direct-superclasses 153 | ,(process-slots env direct-slots name) 154 | ,@options)) 155 | 156 | (defun process-slots (env direct-slots classname) 157 | "Returns the expanded list of DIRECT-SLOTS." 158 | (let ((processed (mapcar 159 | (lambda (line) 160 | (let ((prefix (if (or (member :with-prefix line) 161 | (member :with line) 162 | *with-prefix*) 163 | (concatenate 'string (string classname) "-") 164 | "")) 165 | (split-kws-line (split-fusioned-keywords line))) 166 | (check-for-repeated-keywords split-kws-line) 167 | (replace-keywords env split-kws-line prefix))) 168 | direct-slots))) 169 | (reduce #'append processed))) 170 | 171 | (defmacro class/std (name &body defaulted-slots) 172 | "The most concise shortcut macro to DEFCLASS. 173 | 174 | (class/std example slot1 slot2 slot3) 175 | 176 | expands to: 177 | 178 | (DEFCLASS/STD EXAMPLE () 179 | ((SLOT1 SLOT2 SLOT3))) 180 | 181 | which expands to: 182 | 183 | (DEFCLASS EXAMPLE () 184 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 185 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 186 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL))) 187 | " 188 | `(defclass/std ,name () 189 | ((,@defaulted-slots)))) 190 | 191 | (defmacro printing-unreadably (fields-list class-std-form 192 | &key (type t) (identity t)) 193 | "Automatically generates the unreadable printing boiler plate to print classes and its fields (from FIELDS-LIST)." 194 | (let ((g!stream (gensym "STREAM")) 195 | (name (cadr class-std-form))) 196 | `(progn ,class-std-form 197 | (defmethod print-object ((,name ,name) ,g!stream) 198 | (print-unreadable-object (,name ,g!stream 199 | :type ,type 200 | :identity ,identity) 201 | (format ,g!stream 202 | ,(format nil "~{~a: ~~s~^,~^ ~}" fields-list) 203 | ,@(mapcar (lambda (a1) 204 | `(,a1 ,name)) 205 | fields-list))))))) 206 | 207 | (defun collect-object-slots (obj) 208 | (loop for slot in (closer-mop:class-slots (class-of obj)) 209 | for name = (closer-mop:slot-definition-name slot) 210 | for val = (if (slot-boundp obj name) 211 | (slot-value obj name) 212 | "UNBOUND") 213 | collect (list name val))) 214 | 215 | (defmacro define-print-object/std (class) 216 | "Define a print-object method for objects of class CLASS. 217 | 218 | Print all slots with their values. Prints \"UNBOUND\", as a string, when slots are unbound. 219 | 220 | Usage: 221 | 222 | (defclass/std test () ((a b))) 223 | 224 | (print-object/std test) 225 | 226 | The macro expands to: 227 | 228 | (DEFMETHOD PRINT-OBJECT ((OBJ TEST) STREAM) 229 | (PRINT-UNREADABLE-OBJECT (OBJ STREAM :TYPE T :IDENTITY T) 230 | (FORMAT STREAM \"~{~a~^ ~}\" (COLLECT-OBJECT-SLOTS OBJ)))) 231 | " 232 | `(defmethod print-object ((obj ,class) stream) 233 | (print-unreadable-object (obj stream :type t :identity t) 234 | (format stream "~{~a~^ ~}" 235 | (collect-object-slots obj))))) 236 | 237 | #| 238 | (defclass/std foo2 () 239 | ((bar baz))) 240 | 241 | (define-print-object/std foo2) 242 | 243 | (defparameter foo2 (make-instance 'foo2)) 244 | |# 245 | 246 | (defmacro print-object/std (class) 247 | "Old name for DEFINE-PRINT-OBJECT/STD." 248 | `(define-print-object/std ,class)) 249 | -------------------------------------------------------------------------------- /t/defclass-std.lisp: -------------------------------------------------------------------------------- 1 | (defpackage defclass-std-test 2 | (:use cl prove defclass-std)) 3 | (in-package defclass-std-test) 4 | 5 | ;; NOTE: To run this test file, execute `(asdf:test-system :defclass-std)' in your Lisp. 6 | 7 | (plan 9) 8 | 9 | (deftest class/std->defclass/std->defclass-expansion-test 10 | (is-expand (class/std stub slot1 slot2 slot3 slot4 slot5) 11 | (DEFCLASS/STD STUB () 12 | ((SLOT1 SLOT2 SLOT3 SLOT4 SLOT5))) 13 | "CLASS/STD expands correctly into DEFCLASS/STD.") 14 | (is-expand (DEFCLASS/STD STUB () 15 | ((SLOT1 SLOT2 SLOT3 SLOT4 SLOT5))) 16 | (DEFCLASS STUB () 17 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 18 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 19 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL) 20 | (SLOT4 :ACCESSOR SLOT4 :INITARG :SLOT4 :INITFORM NIL) 21 | (SLOT5 :ACCESSOR SLOT5 :INITARG :SLOT5 :INITFORM NIL))) 22 | "DEFCLASS/STD generated by CLASS/STD expands as expected to DEFCLASS.")) 23 | 24 | (deftest class/std->defclass/std->defclass-with-args-expansion-test 25 | (is-expand (class/std new-stub var1 var2 var3 var4 :with :std :unbound) 26 | (DEFCLASS/STD NEW-STUB () 27 | ((VAR1 VAR2 VAR3 VAR4 :WITH :STD :UNBOUND))) 28 | "CLASS/STD with :keyword options expand correctly into a DEFCLASS/STD form with the same :keyword options.") 29 | (is-expand (DEFCLASS/STD NEW-STUB () 30 | ((VAR1 VAR2 VAR3 VAR4 :WITH :STD :UNBOUND))) 31 | (DEFCLASS NEW-STUB () 32 | ((VAR1 :ACCESSOR NEW-STUB-VAR1 :INITARG :VAR1) 33 | (VAR2 :ACCESSOR NEW-STUB-VAR2 :INITARG :VAR2) 34 | (VAR3 :ACCESSOR NEW-STUB-VAR3 :INITARG :VAR3) 35 | (VAR4 :ACCESSOR NEW-STUB-VAR4 :INITARG :VAR4))) 36 | "DEFCLASS/STD with keyword options generated by CLASS/STD with :keyowrd options expands as expected to DEFCLASS.")) 37 | 38 | (deftest default-accessor-initarg 39 | (is-expand (DEFCLASS/STD STUB () 40 | ((SLOT1 SLOT2 SLOT3 SLOT4 SLOT5))) 41 | (DEFCLASS STUB () 42 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 43 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 44 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL) 45 | (SLOT4 :ACCESSOR SLOT4 :INITARG :SLOT4 :INITFORM NIL) 46 | (SLOT5 :ACCESSOR SLOT5 :INITARG :SLOT5 :INITFORM NIL))) 47 | "Defaults omitted args (:ai) works correctly.")) 48 | 49 | (deftest test-all-keyword-option 50 | (is-expand (defclass/std computer (gadget) 51 | ((screen mouse keyboard :a :type string :with) 52 | (bluetooth touchpad :wi :std :unbound) 53 | (speaker microphone :r) 54 | (place :@@ :with-prefix :doc "Where it is" :r) 55 | (owner :static :std "Me" :w))) 56 | (DEFCLASS COMPUTER (GADGET) 57 | ((SCREEN :ACCESSOR COMPUTER-SCREEN :INITFORM NIL :TYPE STRING) 58 | (MOUSE :ACCESSOR COMPUTER-MOUSE :INITFORM NIL :TYPE STRING) 59 | (KEYBOARD :ACCESSOR COMPUTER-KEYBOARD :INITFORM NIL :TYPE STRING) 60 | (BLUETOOTH :WRITER BLUETOOTH :INITARG :BLUETOOTH) 61 | (TOUCHPAD :WRITER TOUCHPAD :INITARG :TOUCHPAD) 62 | (SPEAKER :READER SPEAKER :INITFORM NIL) 63 | (MICROPHONE :READER MICROPHONE :INITFORM NIL) 64 | (PLACE :READER COMPUTER-PLACE :INITFORM NIL :ALLOCATION :CLASS 65 | :DOCUMENTATION "Where it is") 66 | (OWNER :WRITER OWNER :INITFORM "Me" :ALLOCATION :CLASS))))) 67 | 68 | (deftest test-*default-std*-binding 69 | (is-expand (defclass/std default () 70 | ((with-std))) 71 | (DEFCLASS DEFAULT () 72 | ((WITH-STD :ACCESSOR WITH-STD :INITARG :WITH-STD :INITFORM NIL))) 73 | "*DEFAULT-STD* defaults to T, adding :INITFORM NIL") 74 | (let (*default-std*) 75 | (is-expand (defclass/std default () 76 | ((with-std))) 77 | (DEFCLASS DEFAULT () 78 | ((WITH-STD :ACCESSOR WITH-STD :INITARG :WITH-STD))) 79 | "When bound to NIL, *DEFAULT-STD* changes the behaviour of DEFCLASS/STD correctly, avoidind the addition of :INITFORM NIL."))) 80 | 81 | (deftest test-*with-prefix*-binding 82 | (is-expand (defclass/std prefix () 83 | ((without-prefix))) 84 | (DEFCLASS PREFIX () 85 | ((WITHOUT-PREFIX :ACCESSOR WITHOUT-PREFIX 86 | :INITARG :WITHOUT-PREFIX 87 | :INITFORM NIL))) 88 | "*WITH-PREFIX* defaults to NIL, avoiding the addition of the class name as a prefix to the accessor.") 89 | (let ((*with-prefix* t)) 90 | (is-expand (defclass/std prefix () 91 | ((without-prefix :with))) 92 | (DEFCLASS PREFIX () 93 | ((WITHOUT-PREFIX :ACCESSOR PREFIX-WITHOUT-PREFIX 94 | :INITARG :WITHOUT-PREFIX 95 | :INITFORM NIL))) 96 | "When bound to T, *WITH-PREFIX* changes the behaviour of DEFCLASS/STD, add the class name as a prefix to the accessor."))) 97 | 98 | (deftest test-ignore-unknown-keywords 99 | (is-expand (defclass/std unknown () 100 | ((slot :unknown :keywords))) 101 | (DEFCLASS UNKNOWN () 102 | ((SLOT :ACCESSOR SLOT 103 | :INITARG :SLOT 104 | :INITFORM NIL 105 | :UNKNOWN :KEYWORDS))) 106 | "DEFCLASS/STD with unknown keywords/values pairs works as expected, keeping them as they are, when no other option is present.") 107 | (is-expand (defclass/std unknown () 108 | ((slot :wi :unknown keywords :and values))) 109 | (DEFCLASS UNKNOWN () 110 | ((SLOT :WRITER SLOT 111 | :INITARG :SLOT 112 | :INITFORM NIL 113 | :UNKNOWN KEYWORDS 114 | :AND VALUES))) 115 | "DEFCLASS/STD with unknown keywords/values pairs works as expected, keeping them as they are, when other options are present.") 116 | (is-expand (defclass/std unknown () 117 | ((slot :unknown keywords :without-values))) 118 | (DEFCLASS UNKNOWN () 119 | ((SLOT :ACCESSOR SLOT 120 | :INITARG :SLOT 121 | :INITFORM NIL 122 | :UNKNOWN KEYWORDS 123 | :WITHOUT-VALUES))) 124 | "DEFCLASS/STD with unknown keywords without values pairs works as expected, when no other option is present.") 125 | (is-expand (defclass/std unknown () 126 | ((slot :a :unknown keywords :without-values))) 127 | (DEFCLASS UNKNOWN () 128 | ((SLOT :ACCESSOR SLOT 129 | :INITFORM NIL 130 | :UNKNOWN KEYWORDS 131 | :WITHOUT-VALUES))) 132 | "DEFCLASS/STD with unknown keywords without values pairs works as expected, when other options are present.")) 133 | 134 | (deftest printing-unreadably-form-expansion-test 135 | (is-expand (printing-unreadably (id name) (class/std employee name id salary)) 136 | (progn 137 | (class/std employee 138 | name 139 | id 140 | salary) 141 | (defmethod print-object ((employee employee) $stream) 142 | (print-unreadable-object (employee $stream :type t :identity t) 143 | (format $STREAM "ID: ~s, NAME: ~s" 144 | (id employee) (name employee))))))) 145 | 146 | (deftest repeated-keywords-errors-test 147 | (is-error (macroexpand-1 148 | '(defclass/std class1 () 149 | ((field :wr)))) 150 | 'simple-error 151 | ":WR throws error.") 152 | (is-error (macroexpand-1 153 | '(defclass/std class2 () 154 | ((field :wa)))) 155 | 'simple-error 156 | ":WA throws error.") 157 | (is-error (macroexpand-1 158 | '(defclass/std class3 () 159 | ((field :ra)))) 160 | 'simple-error 161 | ":RA throws error.")) 162 | 163 | (run-test-all) 164 | --------------------------------------------------------------------------------