diff -ur ltk-0.90-original/BWidget.lisp ltk-0.90/BWidget.lisp
--- ltk-0.90-original/BWidget.lisp	2006-07-15 16:45:14.000000000 +0200
+++ ltk-0.90/BWidget.lisp	2006-10-05 16:45:51.000000000 +0200
@@ -43,6 +43,7 @@
 (defpackage :bwidget
   (:use :common-lisp
 	:ltk
+	:iterate
 	)
   (:export
    	#:note-book-page
@@ -51,11 +52,35 @@
 	#:insert-page
 	#:delete-page
 	#:raise-page
+	#:configure-page
+	#:tree
+	#:tree-node
+	#:insert-node
+	#:get-node-data
+	#:set-node-data
+	#:get-node-text
+	#:set-node-text	
+	#:edit-node
+	#:bind-text
+	#:bind-image
+	#:close-tree
+	#:open-tree
+	#:selection-get
+	#:selection-set
+	#:see
+	#:index
+	#:parent
+	#:visible
+	#:exists
+	#:move-tree-node
+	#:delete-all
+	#:open-all
+	#:labelentry
    ))
 
 (in-package :bwidget)
 
-(eval-when (:load-toplevel)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (setf *init-wish-hook* (append *init-wish-hook*
 				 (list (lambda ()
 					 (send-wish "package require BWidget")
@@ -84,17 +109,21 @@
                borderwidth disabledforeground foreground repeatdelay repeatinterval
                arcradius height homogeneous side tabbevelsize tabpady width))
 
-(defmethod insert-page ((nb note-book) index &key text)
-  (let ((page-name (ltk::create-name)))
-    (format-wish "senddata [~a insert ~a ~a ~@[ -text {~A}~]]"
-                 (widget-path nb) index page-name text)
+;; todo: createcmd leavecmd image
+(defmethod insert-page ((nb note-book) index &key text raisecmd)
+  (let ((page-name (ltk::create-name))
+	(raise-callback (when raisecmd (ltk::create-name))))
+    (when raisecmd (ltk::add-callback raise-callback raisecmd))
+    (format-wish "senddata [~a insert ~a ~a ~@[ -text {~A}~]~
+        ~@[ -raisecmd {callback ~a}~]]"
+                 (widget-path nb) index page-name text raise-callback)
     (let ((path (ltk::read-data)))
       (if path
           (make-instance 'note-book-page 
                          :page-name page-name
                          :note-book nb
                          :path (string-downcase path))
-        (error "error while inserting page")))))
+	  (error "error while inserting page")))))
 
 (defmethod raise-page ((nbp note-book-page))
   (format-wish "~a raise ~a" (widget-path (note-book nbp)) (page-name nbp)))
@@ -105,4 +134,180 @@
 (defmethod compute-size ((nb note-book))
   (format-wish "~a compute_size" (widget-path nb)))
 
+(defmethod configure-page ((nbp note-book-page) &key text raisecmd)
+  (let ((page-name (page-name nbp))
+	(raise-callback (when raisecmd (ltk::create-name))))
+    (when raisecmd (ltk::add-callback raise-callback raisecmd))
+    (format-wish "~a itemconfigure ~a ~@[ -text {~A}~]~
+        ~@[ -raisecmd {callback ~a}~]"
+                 (widget-path (note-book nbp)) page-name text raise-callback)))
+
+
+(defclass tree (widget)
+  ())
+
+(defmethod initialize-instance :after ((tree tree) &key deltax deltay padx
+				       background selectbackground selectforeground
+				       selectcommand width height selectfill showlines
+				       linesfill linestipple crossfill redraw
+				       opencmd closecmd dropovermode
+				       crossopenimage crosscloseimage crossopenbitmap
+				       crossclosebitmap
+				       dragenabled draginitcmd dragendcmd dragtype
+				       dragevent dropenabled dropcmd)
+  (let* ((drop-command-name (ltk::create-name))
+	 (drop-command (when dropcmd drop-command-name)))
+    (ltk::add-callback drop-command-name dropcmd)
+    (format-wish "Tree ~a ~@[ -deltax ~(~A~)~]~
+     ~@[ -deltay ~(~A~)~]~@[ -padx ~(~A~)~]~
+     ~@[ -background ~(~A~)~]~@[ -selectbackground ~(~A~)~]~
+     ~@[ -selectforeground ~(~A~)~]~@[ -selectcommand ~(~A~)~]~
+     ~@[ -width ~(~A~)~]~@[ -height ~(~A~)~]~
+     ~@[ -selectfill ~(~A~)~]~@[ -showlines ~(~A~)~]~@[ -linesfill ~(~A~)~]~
+     ~@[ -linestipple ~(~A~)~]~@[ -crossfill ~(~A~)~]~@[ -redraw ~(~A~)~]~
+     ~@[ -opencmd ~(~A~)~]~@[ -closecmd ~(~A~)~]~@[ -dropovermode ~(~A~)~]~
+     ~@[ -crossopenimage ~(~A~)~]~@[ -crosscloseimage ~(~A~)~]~
+     ~@[ -crossopenbitmap ~(~A~)~]~@[ -crossclosebitmap ~(~A~)~]~
+     ~@[ -dragenabled ~(~A~)~]~@[ -draginitcmd ~(~A~)~]~
+     ~@[ -dragendcmd ~(~A~)~]~@[ -dragtype ~(~A~)~]~
+     ~@[ -dragevent ~(~A~)~]~@[ -dropenabled ~(~A~)~]~@[ -dropcmd {callback6 ~A}~]"
+		 (widget-path tree)
+		 deltax deltay padx
+		 background selectbackground selectforeground
+		 selectcommand width height selectfill showlines
+		 linesfill linestipple crossfill redraw
+		 opencmd closecmd dropovermode
+		 crossopenimage crosscloseimage crossopenbitmap
+		 crossclosebitmap
+		 dragenabled draginitcmd dragendcmd dragtype
+		 dragevent dropenabled drop-command)))
+
+;; drop
+
+;; FIXME: callbacks:
+;; selectcommand opencmd closecmd draginitcmd dragendcmd
+
+(defmethod insert-node ((tree tree) index parent node-name
+			&key text font image window fill data
+			open selectable drawcross padx
+			deltax anchor)
+  (format-wish "~a insert ~(~a~) ~(~a~) ~(~a~)~
+     ~@[ -text {~A}~]~
+     ~@[ -font ~(~A~)~]~@[ -image ~(~A~)~]~
+     ~@[ -window ~(~A~)~]~@[ -fill ~(~A~)~]~
+     ~@[ -data {~A}~]~@[ -open ~(~A~)~]~
+     ~@[ -selectable ~(~A~)~]~@[ -drawcross ~(~A~)~]~
+     ~@[ -padx ~(~A~)~]~@[ -deltax ~(~A~)~]~@[ -anchor ~(~A~)~]"
+	       (widget-path tree) index parent node-name
+	       text font image window fill data
+	       open selectable drawcross padx
+	       deltax anchor))
+
+(defmethod get-node-data ((tree tree) node-name)
+  (format-wish "senddatastring [~a itemcget ~(~a~) -data]"
+	       (widget-path tree) node-name)
+  (ltk::read-data))
+
+(defmethod set-node-data ((tree tree) node-name data)
+  (format-wish "~a itemconfigure ~(~a~) -data \"~a\""
+	       (widget-path tree) node-name (ltk::tkescape data)))
+
+(defmethod get-node-text ((tree tree) node-name)
+  (format-wish "senddatastring [~a itemcget ~(~a~) -text]"
+	       (widget-path tree) node-name)
+  (ltk::read-data))
+
+(defmethod edit-node ((tree tree) node-name text)
+  (format-wish "senddatastring [~a edit ~(~a~) \"~a\"]"
+	       (widget-path tree) node-name (ltk::tkescape text))
+  (ltk::read-data))
+
+(defmethod set-node-text ((tree tree) node-name text)
+  (format-wish "~a itemconfigure ~(~a~) -text \"~a\""
+	       (widget-path tree) node-name (ltk::tkescape text)))
+
+(defmethod selection-get ((tree tree))
+  (format-wish "senddatastring [~a selection get]"
+	       (widget-path tree))
+  (ltk::tcl-string-to-list (ltk::read-data)))
+
+(defmethod selection-set ((tree tree) node)
+  (format-wish "~a selection set ~(~a~)" (widget-path tree) node))
+  
+
+(defmethod bind-text ((tree tree) event fun)
+  (let ((name (ltk::create-name)))
+    (ltk::add-callback name fun)
+    (format-wish "~a bindText ~a {callbackstring ~a}"
+		 (widget-path tree)
+		 event
+		 name))
+  tree)
+
+(defmethod bind-image ((tree tree) event fun)
+  (let ((name (ltk::create-name)))
+    (ltk::add-callback name fun)
+    (format-wish "~a bindText ~a {callback ~a}"
+		 (widget-path tree)
+		 event name))
+  tree)
+
+(defmethod close-tree ((tree tree) node-name &key (recurse t))
+  (format-wish "~a closetree ~(~a~) ~a" (widget-path tree)
+	       node-name (if recurse "true" "false")))
+
+(defmethod open-tree ((tree tree) node-name &key (recurse t))
+  (format-wish "~a opentree ~(~a~) ~a" (widget-path tree) node-name (if recurse "true" "false")))
+
+(defmethod open-all ((tree tree))
+  (format-wish "senddatastring [~a nodes root]" (widget-path tree))
+  (let ((nodes (ltk::tcl-string-to-list (ltk::read-data))))
+    (iterate (for node in nodes)
+	     (format-wish "~a opentree ~(~a~)" (widget-path tree) node))))
+
+(defmethod see ((tree tree) node-name)
+  (format-wish "~a see ~(~a~)" (widget-path tree) node-name))
+
+(defmethod index ((tree tree) node-name)
+  (format-wish "senddatastring [~a index ~(~a~)]"
+	       (widget-path tree) node-name)
+  (ltk::read-data))
+
+(defmethod parent ((tree tree) node-name)
+  (format-wish "senddatastring [~a parent ~(~a~)]"
+	       (widget-path tree) node-name)
+  (ltk::read-data))
+
+(defmethod visible ((tree tree) node-name)
+  (format-wish "senddatastring [~a visible ~(~a~)]"
+	       (widget-path tree) node-name)
+  (ltk::read-data))
+
+(defmethod exists ((tree tree) node-name)
+  (format-wish "senddatastring [~a exists ~(~a~)]"
+	       (widget-path tree) node-name)
+  (ltk::read-data))
+
+(defmethod move-tree-node ((tree tree) new-parent node-name index)
+  (format-wish "senddatastring [~a move ~(~a~) ~(~a~) ~(~a~)]"
+	       (widget-path tree) new-parent node-name index))
+
+(defmethod delete-all ((tree tree))
+  (format-wish "~a delete [~a nodes root]"
+	       (widget-path tree) (widget-path tree)))
+
+;; TODO: implement:
+;; reorder nodes edit delete configure
+;; fix commands to be proper callbacks
+
+
+(defclass labelentry (entry)
+  ())
+
+(defmethod initialize-instance :before ((w labelentry) &key &allow-other-keys)
+  (setf (ltk::widget-class-name w) "LabelEntry"))
+
+
+(defmethod initialize-instance :after ((w labelentry) &key &allow-other-keys)
+  #-(and)(setf (ltk::widget-class-name w) "LabelEntry"))
 
diff -ur ltk-0.90-original/ltk.asd ltk-0.90/ltk.asd
--- ltk-0.90-original/ltk.asd	2006-07-15 16:45:14.000000000 +0200
+++ ltk-0.90/ltk.asd	2006-09-26 09:56:12.000000000 +0200
@@ -13,6 +13,9 @@
   :licence "LGPL"
   :description "LTK"
   :long-description "Lisp bindings for the Tk toolkit"
-  :components ((:file "ltk"))
+  :components ((:file "ltk")
+	       (:file "ltk-tile" :depends-on ("ltk"))
+	       (:file "BWidget" :depends-on ("ltk")))
+  :depends-on (#:cl-ppcre #:iterate #:split-sequence)
   )
 
diff -ur ltk-0.90-original/ltk.lisp ltk-0.90/ltk.lisp
--- ltk-0.90-original/ltk.lisp	2006-07-15 16:45:13.000000000 +0200
+++ ltk-0.90/ltk.lisp	2006-10-01 20:00:41.000000000 +0200
@@ -1,4 +1,4 @@
-#|
+a#|
 
  This software is Copyright (c) 2003, 2004, 2005, 2006  Peter Herth <herth@peter-herth.de>
  Parts Copyright (c) 2005 Thomas F. Burdick
@@ -120,10 +120,11 @@
 
 
 (defpackage :ltk
-  (:use :common-lisp
-        #+(or :cmu :scl) :ext
-	#+:sbcl :sb-ext
-	)
+    (:use :common-lisp
+	  #+(or :cmu :scl) :ext
+	  #+:sbcl :sb-ext
+	  :split-sequence
+	  )
   (:export #:ltktest                           
            #:*ltk-version*
            #:*cursors*
@@ -144,6 +145,7 @@
            #:after-cancel
            #:after-idle
            #:append-text
+           #:insert-text	   
            #:append-newline
            #:ask-okcancel
            #:ask-yesno
@@ -314,6 +316,9 @@
            #:set-wm-overrideredirect
            #:spinbox
            #:start-wish
+	   #:tag-add
+	   #:tag-remove
+	   #:tag-names
            #:tag-bind
            #:tag-configure
            #:text
@@ -497,6 +502,7 @@
 
   (send-wish "proc callback {s} {puts \"(:callback \\\"$s\\\")\";flush stdout} ")
   (send-wish "proc callbackval {s val} {puts \"(:callback \\\"$s\\\" $val)\"} ")
+  (send-wish "proc callback6 {s v1 v2 v3 v4 v5 v6} {puts \"(:callback \\\"$s\\\" \\\"$v1\\\" \\\"$v2\\\" \\\"$v3\\\" \\\"$v4\\\" \\\"$v5\\\" \\\"$v6\\\")\"} ")
   (send-wish "proc callbackstring {s val} {puts \"(:callback \\\"$s\\\" \\\"[escape $val]\\\")\"} ")
 
   (dolist (fun *init-wish-hook*)	; run init hook funktions 
@@ -1351,7 +1357,7 @@
 
 ;;; menues
 
-(defclass menu(widget)
+(defclass menu (widget)
   ((text :accessor text :initarg :text)
    (help :accessor menu-help :initarg :help :initform nil)
    ))
@@ -1367,7 +1373,7 @@
     (format-wish "~A add cascade -label {~A} -menu ~a~@[ -underline ~a ~]"
                  (widget-path (master m)) (text m) (widget-path m) underline)))
 
-(defun make-menu(menu text &key underline name)
+(defun make-menu (menu text &key underline name)
   (if name
       (make-instance 'menu :master menu :text text :underline underline :name name)
       (make-instance 'menu :master menu :text text :underline underline)))
@@ -1378,7 +1384,7 @@
 
 ;;; menu button
 
-(defclass menubutton(widget) 
+(defclass menubutton (widget) 
   ((text :accessor text :initarg :text :initform "")
    ))
 
@@ -1388,12 +1394,12 @@
   (format-wish "~A add command -label {~A}  -command {callback ~A}~@[ -underline ~a ~]~@[ -accelerator {~a} ~]"
                (widget-path (master m)) (text m) (name m) underline accelerator))
 
-(defun make-menubutton(menu text command &key underline accelerator)
+(defun make-menubutton (menu text command &key underline accelerator)
   (let* ((mb (make-instance 'menubutton :master menu :text text :command command :underline underline
 			    :accelerator accelerator)))
     mb))
 
-(defclass menucheckbutton(widget) 
+(defclass menucheckbutton (widget) 
   ((text :accessor text :initarg :text)
    (command :accessor command :initarg :command :initform nil)))
 
@@ -1411,7 +1417,7 @@
   (format-wish "set ~a ~a" (name cb) val)
   val)
 
-(defclass menuradiobutton(widget) 
+(defclass menuradiobutton (widget) 
   ((text :accessor text :initarg :text)
    (command :accessor command :initarg :command :initform nil)
    (group :accessor group :initarg :group :initform nil)))
@@ -1677,9 +1683,12 @@
 (defmethod (setf text) (new-text (self scrolled-text))
   (setf (text (textbox self)) new-text))
 
-(defgeneric insert-object (txt object))
-(defmethod insert-object ((txt scrolled-text) obj)
-  (format-wish "~a window create end -window ~a" (widget-path (textbox txt)) (widget-path obj))
+(defgeneric insert-object (txt obj &key position padx))
+(defmethod insert-object ((txt scrolled-text) obj &key (position :insert) padx)
+  (format-wish "~a window create ~(~a~) ~@[ -padx ~(~a~)~] -window ~a"
+	       (widget-path (textbox txt))
+	       position padx
+	       (widget-path obj))
   txt)
 
 (defgeneric see (txt pos))
@@ -2148,11 +2157,19 @@
   (make-instance 'text :master master :width width :height height))
 
 (defmethod append-text ((txt text) text &rest tags)
-  (format-wish "~a insert end \"~a\" {~{ ~(~a~)~}}" (widget-path txt) (tkescape text) tags)
+  (format-wish "~a insert end \"~a\" ~@[{~{~(~a~)~}}~]" (widget-path txt) (tkescape text) tags)
+  txt)
+
+(defmethod insert-text ((txt text) text &key tags (position :insert))
+  (format-wish "~a insert ~(~a~) \"~a\" ~@[{~{~(~a~) ~}}~]"
+	       (widget-path txt) position (tkescape text) tags)
   txt)
 
-(defmethod insert-object ((txt text) obj)
-  (format-wish "~a window create end -window ~a" (widget-path txt) (widget-path obj))
+(defmethod insert-object ((txt text) obj &key (position :insert) padx)
+  (format-wish "~a window create ~(~a~) ~@[ -padx ~(~a~)~] -window ~a"
+	       (widget-path txt)
+	       position padx
+	       (widget-path obj))
   txt)
 
 (defun append-newline (text)
@@ -2163,16 +2180,45 @@
   (format-wish "~A delete 0.0 end" (widget-path txt))
   txt)
 
-(defmethod see((txt text) pos)
+(defmethod see ((txt text) pos)
   (format-wish "~a see ~a" (widget-path txt) pos)
   txt)
 
+;;; tags
+
+(defun tag-to-string (tag)
+  "Convert a lisp-side tag to a string, return the resulting string"
+  (if (stringp tag)
+      tag
+      (if tag
+	  (format nil "~(~a~)" tag)
+	  "")))
+
+(defun tcl-string-to-list (str)
+  "Convert a TCL string with a list of items to a list of strings."
+  (loop for item in (cl-ppcre:all-matches-as-strings "(\\w+)|({[\\w\\s]+})" str)
+	collect (cl-ppcre:regex-replace "^{([\\w\\s]+)}$" item "\\1")))
+
+(defgeneric tag-add (txt tag &rest indices))
+(defmethod tag-add ((txt text) tag &rest indices)
+  (format-wish "~a tag add ~a ~{ ~(~a~)~}"
+	       (widget-path txt)
+	       (tag-to-string tag)
+	       indices)
+  txt)
+
+(defgeneric tag-remove (txt tag &rest indices))
+(defmethod tag-remove ((txt text) tag &rest indices)
+  (format-wish "~a tag remove ~a ~{ ~(~a~)~}"
+	       (widget-path txt)
+	       (tag-to-string tag)
+	       indices)
+  txt)
+
 (defgeneric tag-configure (txt tag option value))
 (defmethod tag-configure ((txt text) tag option value)
   (format-wish "~a tag configure ~a -~(~a~) {~(~a~)}" (widget-path txt)
-	       (if (stringp tag)
-		   tag
-		 (format nil "~(~a~)" tag))
+	       (tag-to-string tag)
 	       option value)
   txt)
 
@@ -2181,10 +2227,113 @@
   "bind fun to event of the tag of the text widget txt"
   (let ((name (create-name)))
     (add-callback name fun)
-    (format-wish "~a tag bind ~a ~a {callback ~A}" (widget-path txt) tag event name)
-    )
+    (format-wish "~a tag bind ~(~a~) ~a {callback ~A}"
+		 (widget-path txt) (tag-to-string tag)
+		 event name))
+  txt)
+
+(defgeneric tag-delete (txt tag &rest other-tags))
+(defmethod tag-delete ((txt text) tag &rest other-tags)
+  (format-wish "~a tag delete ~a ~{ ~(~a~)~}"
+	       (widget-path txt)
+	       (tag-to-string tag)
+	       (mapcar #'tag-to-string other-tags))
+  txt)
+
+(defgeneric tag-lower (txt tag &optional other-tag))
+(defmethod tag-lower ((txt text) tag &optional other-tag)
+  (format-wish "~a tag lower ~a ~a"
+	       (widget-path txt)
+	       (tag-to-string tag)
+	       (tag-to-string other-tag))
   txt)
 
+(defgeneric tag-raise (txt tag &optional other-tag))
+(defmethod tag-raise ((txt text) tag &optional other-tag)
+  (format-wish "~a tag raise ~a ~a"
+	       (widget-path txt)
+	       (tag-to-string tag)
+	       (tag-to-string other-tag))
+  txt)
+
+(defgeneric tag-names (txt index))
+(defmethod tag-names ((txt text) index)
+  (format-wish "senddatastring [~a tag names ~(~a~)]"
+	       (widget-path txt)
+	       index)
+  (tcl-string-to-list (read-data)))
+
+(defgeneric tag-nextrange (txt tag index1 &optional index2))
+(defmethod tag-nextrange ((txt text) tag index1 &optional index2)
+  (format-wish "senddatastring [~a tag nextrange ~a ~(~a~) ~(~a~)]"
+	       (widget-path txt)
+	       (tag-to-string tag)
+	       index1
+	       (if index2 index2 ""))
+  (tcl-string-to-list (read-data)))
+
+(defgeneric tag-prevrange (txt tag index1 &optional index2))
+(defmethod tag-prevrange ((txt text) tag index1 &optional index2)
+  (format-wish "senddatastring [~a tag nextrange ~a ~(~a~) ~(~a~)]"
+	       (widget-path txt)
+	       (tag-to-string tag)
+	       index1
+	       (if index2 index2 ""))
+  (tcl-string-to-list (read-data)))
+
+(defgeneric tag-ranges (txt tag))
+(defmethod tag-ranges ((txt text) tag)
+  (format-wish "senddatastring [~a tag ranges ~a]" (widget-path txt) (tag-to-string tag))
+  (tcl-string-to-list (read-data)))
+
+;;; marks
+
+(defgeneric mark-gravity ((txt text) mark direction))
+(defmethod mark-gravity ((txt text) mark direction)
+  (format-wish "~a mark gravity ~a ~(~a~)" (widget-path txt) (tag-to-string mark) direction))
+
+(defgeneric mark-names ((txt text)))
+(defmethod mark-names ((txt text))
+  (format-wish "senddatastring [~a mark names]" (widget-path txt))
+  (tcl-string-to-list (read-data)))
+
+(defgeneric mark-next ((txt text) index))
+(defmethod mark-next ((txt text) index)
+  (format-wish "senddatastring [~a mark next ~(~a~)]" (widget-path txt) index)
+  (read-data))
+
+(defgeneric mark-previous ((txt text) index))
+(defmethod mark-previous ((txt text) index)
+  (format-wish "senddatastring [~a mark previous ~(~a~)]" (widget-path txt) index)
+  (read-data))
+
+(defgeneric mark-set ((txt text) mark index))
+(defmethod mark-set ((txt text) mark index)
+  (format-wish "~a mark set ~a ~(~a~)" (widget-path txt) (tag-to-string mark) index))
+
+(defgeneric mark-unset ((txt text) mark &optional other-marks))
+(defmethod mark-unset ((txt text) mark &optional other-marks)
+  (format-wish "~a mark unset ~a~{ ~a~}"
+	       (widget-path txt)
+	       (tag-to-string mark)
+	       (mapcar #'tag-to-string other-marks)))
+
+;;; dumping
+
+(defgeneric dump ((txt text) index1 &key index2 switches))
+(defmethod dump ((txt text) index1 &key index2 switches)
+  (format-wish "senddatastring [~a dump ~{ -~(~a~)~} ~(~a~) ~(~a~)]"
+	       (widget-path txt)
+	       switches
+	       index1
+	       (if index2 index2 ""))
+  (read-data))
+
+(defgeneric index ((txt text) index))
+(defmethod index ((txt text) index)
+  (format-wish "senddatastring [~a index ~(~a~)]" (widget-path txt) index)
+  (read-data))
+
 (defmethod text ((text text))
   (format-wish "senddatastring [~a get 1.0 end]" (widget-path text))
   (read-data))
@@ -2207,9 +2356,10 @@
   (format-wish "set file [open {~a} \"r\"];~a delete 1.0 end;~a insert end [read $file];close $file;puts \"(:DATA asdf)\"" filename (widget-path txt) (widget-path txt))
   (read-data))
 
+
 ;;; photo image object
 
-(defclass photo-image(tkobject)
+(defclass photo-image (tkobject)
   ()
   )
 
@@ -2238,6 +2388,14 @@
 	   "ishow.ppm")
   (image-load p "ishow.ppm"))
 
+
+;; images in text
+(defgeneric text-image-create (txt img index &rest options))
+(defmethod text-image-create ((txt text) (img photo-image) index &key align padx pady)
+  (format-wish "~a image create ~(~a~) -image ~a ~@[ -align ~a~]~@[ -padx ~a~]~@[ -pady ~a~]"
+	       (widget-path txt) index (widget-path img) align padx pady))
+
+
 ;;;; generic methods on widgets
 
 ;;; pack method for widget arrangement in container
