(in-package :free-clim-internal) (define-protocol-class indirect-ink (design)) (define-protocol-predicate indirect-ink-p (indirect-ink)) (define-protocol-generic-function resolve-indirect-ink-1 (medium (ink indirect-ink))) ;;; (defclass standard-foreground-ink (indirect-ink) ()) (defclass standard-background-ink (indirect-ink) ()) (defconstant* +foreground-ink+ (make-instance 'standard-foreground-ink)) (defconstant* +background-ink+ (make-instance 'standard-background-ink)) (defmethod resolve-indirect-ink-1 (medium (ink standard-foreground-ink)) (medium-foreground medium)) (defmethod resolve-indirect-ink-1 (medium (ink standard-background-ink)) (medium-background medium)) (defmethod make-load-form ((object standard-foreground-ink) &optional environment) (declare (ignore environment)) '+foreground-ink+) (defmethod make-load-form ((object standard-background-ink) &optional environment) (declare (ignore environment)) '+backgrond-ink+) (defmethod print-object ((object standard-foreground-ink) stream) (format stream "#.~S" (make-load-form object))) (defmethod print-object ((object standard-background-ink) stream) (format stream "#.~S" (make-load-form object))) (defun resolve-indirect-ink (medium ink) (labels ((jonhnie (ink yet) (cond ((not (indirect-ink-p ink)) ink) ((member ink yet) (error "Infinite indirect ink recursion detected.")) ((jonhnie (resolve-indirect-ink-1 medium ink) (cons ink yet)))))) (jonhnie ink nil)))