;; ;; Resources ;; (option 'add "*LabeledEntry.Entry.Background" "white" "widgetDefault") (option 'add "*LabeledEntry.Entry.Font" "fixed" "widgetDefault") (option 'add "*LabeledEntry.Entry.Relief" "sunken" "widgetDefault") ;; ;; Class definition ;; (define-class <Labeled-entry> (<Tk-composite-widget> <Entry>) ((entry :accessor entry-of) (label :accessor label-of) (class :init-keyword :class :init-form "LabeledEntry") ;; Fictive slots (title :accessor title :init-keyword :title :allocation :propagated :propagate-to ((label text))) (title-width :accessor title-width :init-keyword :title-width :allocation :propagated :propagate-to ((label width))) (title-anchor :accessor title-anchor :init-keyword :title-anchor :allocation :propagated :propagate-to ((label anchor))) (anchor :accessor anchor :init-keyword :anchor :allocation :propagated :propagate-to (label)) (background :accessor background :init-keyword :background :allocation :propagated :propagate-to (frame entry label)) (foreground :accessor foreground :init-keyword :foreground :allocation :propagated :propagate-to (entry label)) (border-width :accessor border-width :allocation :propagated :init-keyword :border-width :propagate-to (frame)) (relief :accessor relief :init-keyword :relief :allocation :propagated :propagate-to (frame)) (entry-relief :accessor entry-relief :init-keyword :entry-relief :allocation :propagated :propagate-to ((entry relief))) )) (define-method initialize-composite-widget ((self <Labeled-entry>) initargs frame) (let* ((e (make <Entry> :parent frame)) (l (make <Label> :parent frame))) (next-method) (pack (Id l) :side "left" :padx 2 :pady 2) (pack e :side "right" :padx 2 :pady 2 :expand #t :fill "x") (slot-set! self 'Id (slot-ref e 'Id)) (slot-set! self 'entry e) (slot-set! self 'label l)))