aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Pouar <pouar@pouar.net>2020-07-20 13:28:03 -0500
committerGravatar Pouar <pouar@pouar.net>2020-07-20 13:28:03 -0500
commit6957e286c507e6922f3fe29ea6b6fb96226a3d2c (patch)
treefc77de083cb0f1bdc1fc0ccce8c80774ec3bab51
parentforgot macros made with macrolet are invisible to the iterate macro (diff)
use a macro for this
-rw-r--r--core/classes.lisp46
-rw-r--r--core/util.lisp8
-rw-r--r--data/epilog/pyramid.lisp18
-rw-r--r--packages.lisp3
4 files changed, 38 insertions, 37 deletions
diff --git a/core/classes.lisp b/core/classes.lisp
index ef4b34b..9df677f 100644
--- a/core/classes.lisp
+++ b/core/classes.lisp
@@ -27,16 +27,14 @@
(defmethod print-object ((o element-type) s)
(let ((class (slot-value (class-of o) 'name)))
(if class
- (let ((*package* (find-package :keyword)))
- (print-unreadable-object (o s :type t :identity t)
- (write class :stream s)))
+ (print-unreadable-object-with-prefix (o s :type t :identity t)
+ (write class :stream s))
(call-next-method))))
(defmethod print-object ((o element-type-class) s)
(let ((class (slot-value o 'name)))
(if class
- (let ((*package* (find-package :keyword)))
- (print-unreadable-object (o s :type t :identity nil)
- (f:fmt s (:s class) " " (:s (class-name o)))))
+ (print-unreadable-object-with-prefix (o s :type t :identity nil)
+ (f:fmt s (:s class) " " (:s (class-name o))))
(call-next-method))))
(defgeneric coerce-element-type (element)
(:method ((element-type (eql nil)))
@@ -551,9 +549,8 @@
(defclass ally-last-minute-potty-training (ally potty-trained-team-member) ())
(defclass ally-feral (ally potty-trained-team-member) ())
(defmethod print-object ((obj ally) stream)
- (let ((*package* (find-package :keyword)))
- (print-unreadable-object (obj stream :type t :identity t)
- (print-slot obj 'name stream))))
+ (print-unreadable-object-with-prefix (obj stream :type t :identity t)
+ (print-slot obj 'name stream)))
(defclass playable-ally (ally) ())
(defmethod initialize-instance :after
((c base-character) &rest initargs &key &allow-other-keys)
@@ -786,11 +783,10 @@
:documentation "list containing what npcs team member might show up when you enter an area. Each entry looks like this @code{(:chance chance :npc npc)} If @var{RANDOM} is specified, then the probability of the enemy being spawn is @var{CHANCE} out of 1 where @var{CHANCE} is a number between 0 and 1"))
(:documentation "A zone on the map"))
(defmethod print-object ((obj zone) stream)
- (let ((*package* (find-package :keyword)))
- (print-unreadable-object (obj stream :type t :identity t)
- (print-slot obj 'position stream)
- (write-string " " stream)
- (print-slot obj 'name stream))))
+ (print-unreadable-object-with-prefix (obj stream :type t :identity t)
+ (print-slot obj 'position stream)
+ (write-string " " stream)
+ (print-slot obj 'name stream)))
(defclass prop (yadfa-class)
((description
:initarg :description
@@ -830,9 +826,8 @@
:documentation "Plist of actions who's lambda-list is @code{(prop &key &allow-other-keys)} that the player sees as actions they can perform with the prop, @var{PROP} is the instance that this slot belongs to"))
(:documentation "Tangible objects in the AREA that the player can interact with"))
(defmethod print-object ((obj prop) stream)
- (let ((*package* (find-package :keyword)))
- (print-unreadable-object (obj stream :type t :identity t)
- (print-slot obj 'name stream))))
+ (print-unreadable-object-with-prefix (obj stream :type t :identity t)
+ (print-slot obj 'name stream)))
(defclass consumable (item)
()
(:documentation "Doesn't actually cause items to be consumable, but is there to make filtering easier"))
@@ -1171,15 +1166,14 @@
(attack (player-of *game*) character a))
t))))
(defmethod print-object ((obj enemy) stream)
- (let ((*package* (find-package :keyword)))
- (print-unreadable-object (obj stream :type t :identity t)
- (cond ((not (slot-boundp obj 'male))
- (print-slot obj 'male stream))
- ((slot-value obj 'male)
- (write "Male" :stream stream))
- (t (write "Female" :stream stream)))
- (write-string " " stream)
- (print-slot obj 'species stream))))
+ (print-unreadable-object-with-prefix (obj stream :type t :identity t)
+ (cond ((not (slot-boundp obj 'male))
+ (print-slot obj 'male stream))
+ ((slot-value obj 'male)
+ (write "Male" :stream stream))
+ (t (write "Female" :stream stream)))
+ (write-string " " stream)
+ (print-slot obj 'species stream)))
(defclass bladder-enemy (enemy bladder-character) ()
(:documentation "Class for an enemy with a bladder fill rate. This enemy may @{wet,mess@} @{him,her@}self in battle."))
(defclass bowels-enemy (enemy bowels-character) ()
diff --git a/core/util.lisp b/core/util.lisp
index b8a4c0c..ebe18a0 100644
--- a/core/util.lisp
+++ b/core/util.lisp
@@ -10,6 +10,14 @@
(1- (ash 1 width))))
(defmethod lambda-list ((lambda-exp list))
(cadr lambda-exp))
+(defmacro print-unreadable-object-with-prefix ((object stream &key (type nil type-supplied-p) (identity nil identity-supplied-p))
+ &body body)
+ ;; apparently the ansi standard says that all keywords are printed with the package prefix
+ ;; and so making the current package the keyword package has the effect of causing the printer
+ ;; to print all symbols with the package prefix
+ `(let ((*package* (find-package :keyword)))
+ (print-unreadable-object (,object ,stream ,@(when type-supplied-p `(:type ,type)) ,@(when identity-supplied-p `(:identity ,identity)))
+ ,@body)))
(defmethod lambda-list ((lambda-exp function))
(swank-backend:arglist lambda-exp))
(defmacro do-push (item &rest places)
diff --git a/data/epilog/pyramid.lisp b/data/epilog/pyramid.lisp
index e5cb41a..1df4d22 100644
--- a/data/epilog/pyramid.lisp
+++ b/data/epilog/pyramid.lisp
@@ -64,17 +64,15 @@
:initarg :name
:accessor name-of)))
(defmethod print-object ((object object) stream)
- (let ((*package* (find-package :keyword)))
- (print-unreadable-object (object stream :type t)
- (if (slot-boundp object 'name)
- (write (slot-value object 'name) :stream stream)
- (write-string "#<unbound>" stream)))))
+ (print-unreadable-object-with-prefix (object stream :type t)
+ (if (slot-boundp object 'name)
+ (write (slot-value object 'name) :stream stream)
+ (write-string "#<unbound>" stream))))
(defmethod print-object ((object puzzle) stream)
- (let ((*package* (find-package :keyword)))
- (print-unreadable-object (object stream :type t)
- (if (slot-boundp object 'name)
- (write (slot-value object 'name) :stream stream)
- (write-string "#<unbound>" stream)))))
+ (print-unreadable-object-with-prefix (object stream :type t)
+ (if (slot-boundp object 'name)
+ (write (slot-value object 'name) :stream stream)
+ (write-string "#<unbound>" stream))))
(serapeum:eval-always (c:define-presentation-type object (&optional place)))
(cc:define-conditional-application-frame game-frame
()
diff --git a/packages.lisp b/packages.lisp
index 8a35192..ec42613 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -22,7 +22,8 @@
#:in*
#:sum*
#:defunassert
- #:lappendf)
+ #:lappendf
+ #:print-unreadable-object-with-prefix)
(:documentation "Utility functions that aren't really part of the game's API")
(:local-nicknames (:s :serapeum) (:a :alexandria) (:u :ugly-tiny-infix-macro) (:g :global-vars)
(:c :clim) (:ce :clim-extensions) (:cc :conditional-commands)))