mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-09 02:33:14 -08:00
Code Issues Projects Releases Packages Wiki Activity

Remove unused Tk port

Browse source
This commit is contained in:
jjgarcia 2005-05-19 11:43:31 +00:00
parent 981644e41d
commit 8663bdb8c9
33 changed files with 0 additions and 4369 deletions
Download patch file Download diff file Expand all files Collapse all files

271
src/tk/Demos/hanoi.lsp
View file

@ -1,271 +0,0 @@
;;
;; Hanoi - Towers of Hanoi diversion
;;
;; This program is a rewriting in ECL/tk of a program found on the net.
;; Original author is Damon A Permezel (probably fubar!dap@natinst.com)
;; Re-writing is very direct and needs much more working
;;
;; Modified for ECL by G. Attardi (attardi@di.unipi.it)
(in-package "TK")
(defvar sys:*gc-verbose* NIL)
(defvar hanoi-canvas "")
(defvar hanoi-running NIL)
(defvar hanoi-stop NIL)
(defvar previousRings 0)
(defvar max-rings 20)
(defvar num-rings 6)
(defvar colours '(DarkOliveGreen snow4 royalblue2 palegreen4
rosybrown1 wheat4 tan2 brown2 tomato3 hotpink3))
(defvar pole (make-array 3)) ; elts are <nRing . xPos>
(defvar ring (make-array (+ max-rings 1))); elts are <pole width . obj>
(defvar accel 0)
(defvar base 32)
(defvar fly-row 32)
(defvar width-incr 12)
(defvar width-min (* 8 width-incr))
(defvar ring-height 26)
(defvar ring-spacing (/ (* 2 ring-height) 3))
;;
;; Setup the main window
;;
(defun SetupHanoi ()
;; Create top level window
(toplevel ".h" "-class" "Queens")
(wm "title" ".h" "Towers of Hanoi")
(wm "iconname" ".h" "Towers of Hanoi")
;;
;; setup frame and main menu button
;;
(label ".h.title" "-text" "Towers of Hanoi" "-bd" 4 "-fg" "RoyalBlue"
"-relief" "ridge")
(frame ".h.f")
(button ".h.f.run" "-text" "Run" "-command"
'(DoHanoi (parse-integer (funcall .h.nrframe.scale "get")) T))
(button ".h.f.stop" "-text" "Stop" "-command" '(setq hanoi-stop 1))
(button ".h.f.quit" "-text" "Quit" "-command" '(destroy .h))
(pack .h.f.run .h.f.stop .h.f.quit "-fill" "x" "-side" "left" "-expand" T)
;;
;; setup next frame, for #rings slider
;;
(frame ".h.nrframe" "-bd" 2 "-relief" "raised")
(pack (label ".h.nrframe.label" "-text" "Number of Rings: " "-width" 16
"-anchor" "e")
"-side" "left")
(pack (scale ".h.nrframe.scale" "-orient" "hor" "-from" 1 "-to" max-rings
"-font" "fixed" "-command" "setq num-rings")
"-side" "right" "-expand" T "-fill" "x")
(funcall .h.nrframe.scale "set" num-rings)
;;
;; setup next frame, for speed slider
;;
(frame ".h.speed-frame" "-bd" 2 "-relief" "raised")
(pack (label ".h.speed-frame.label" "-text" "Speed: " "-width" 15
"-anchor" "e")
"-side" "left")
(pack (scale ".h.speed-frame.scale" "-orient" "hor" "-from" 1 "-to" 100
"-font" "fixed" "-command" "setq tk::accel")
"-side" "right" "-expand" T "-fill" "x")
(funcall .h.speed-frame.scale "set" 100)
;;
;; setup frame for canvas to appear in
;;
(frame ".h.canv-frame" "-bd" 4 "-relief" "groove")
(pack (canvas ".h.canv-frame.canvas" "-relief" "sunken"))
(setq hanoi-canvas .h.canv-frame.canvas)
;;
;; Pack evrybody
;;
(pack .h.title .h.nrframe .h.speed-frame .h.canv-frame .h.f
"-expand" T "-fill" "x")
;;
;; key bindings
;;
(bind ".h" "<KeyPress-r>" '(DoHanoi (parse-integer
(funcall .h.nrframe.scale "get")) T))
(bind ".h" "<KeyPress-s>" '(setq hanoi-stop T))
(bind ".h" "<KeyPress-q>" '(destroy .h))
;;
;; Display tower
;;
(DoHanoi num-rings NIL)
)
;;
;; DoHanoi
;;
;; Input:
;; n # of rings
;;
;; setup the canvas for displaying the Hanoi simulation
;; Call hanoi if run-it is true.
;;
(defun DoHanoi (n run-it)
(unless hanoi-running
(setq ring-width (+ width-min (* n width-incr)))
(setq wm-width (+ (* 3 ring-width) (* 4 12)))
(setq wm-height (+ (* ring-spacing n) fly-row (* 2 ring-height)))
(setq hanoi-stop NIL)
(setq hanoi-running T)
(setq base (- wm-height 32))
;;
;; cleanup from previous run
;;
(do ((i 1 (+ i 1)))
((> i previousRings))
(funcall hanoi-canvas "delete" (cddr (svref ring i))))
;;
;; configure the canvas appropriately
;;
(funcall hanoi-canvas "configure" "-width" wm-width "-height" wm-height)
;;
;; setup poles
;;
(dotimes (i 3)
(setf (svref pole i)
(cons 0 (+ (/ (* i wm-width) 3) (/ ring-width 2) 8))))
;;
;; setup rings
;;
(dotimes (i n)
(let* ((colour (nth (mod i 10) colours))
(w (- ring-width (* i 12)))
(y (- base (* i ring-spacing)))
(x (- (cdr (svref pole 0)) (/ w 2)))
(r (- n i)))
(setf (svref ring r)
(cons 0
(cons w
(funcall hanoi-canvas "create"
"oval" x y (+ x w) (+ y ring-height)
"-fill" colour
"-outline" colour
"-width" 12))))))
(setf (svref pole 0) (cons n (cdr (svref pole 0))))
(setq previousRings n)
(update)
(when run-it (Hanoi n 0 2 1))
(setq hanoi-running NIL)))
;;
;; Hanoi: the guts of the algorithm
;;
;; Input:
;; n # of rings
;; from pole to move from
;; to pole to move to
;; work pole to aid in performing work
;;
(defun Hanoi (n from to work)
(when (and (> n 0) (not hanoi-stop))
(Hanoi (- n 1) from work to)
(unless hanoi-stop (MoveRing n to))
(Hanoi (- n 1) work to from)))
;;
;; MoveRing: move a ring to a new pole
;;
;; Input:
;; n ring number
;; to destination pole
;;
(defun MoveRing (n to)
;;
;; ring(n,obj) can be queried as to its current position.
;; Thus, we don't need to know which pole the ring is moving from.
;;
(let* ((inc 0)
(tox 0)
(toy 0)
(r (cddr (svref ring n)))
(coords (mapcar #'parse-integer (funcall hanoi-canvas "coords" r)))
(x0 (nth 0 coords))
(y0 (nth 1 coords))
(x1 (nth 2 coords))
(y1 (nth 3 coords)))
;;
;; move up to the "fly row"
;;
(do ()
((<= y0 fly-row))
(setq inc (if (> (- y0 fly-row) accel) accel (- y0 fly-row)))
(setq y0 (- y0 inc))
(setq y1 (- y1 inc))
(funcall hanoi-canvas "coords" r x0 y0 x1 y1)
(update))
;;
;; one less ring on this pole
;;
(let ((tmp (car (svref ring n))))
(setf (car (svref pole tmp)) (- (car (svref pole tmp)) 1)))
;;
;; determine target X position, based on destination pole, and fly ring
;; over to new pole
;;
(setq toX (- (cdr (svref pole to))
(/ (second (svref ring n)) 2)))
(do ()
((>= x0 toX))
(setq inc (if (> (- toX x0) accel) accel (- toX x0)))
(setq x0 (+ x0 inc))
(setq x1 (+ x1 inc))
(funcall hanoi-canvas "coords" r x0 y0 x1 y1)
(update))
(do ()
((<= x0 toX))
(setq inc (if (> (- x0 toX) accel) accel (- x0 toX)))
(setq x0 (- x0 inc))
(setq x1 (- x1 inc))
(funcall hanoi-canvas "coords" r x0 y0 x1 y1)
(update))
;;
;; determine target Y position, based on ;; rings on destination pole.
;;
(setq toY (- base (* (car (svref pole to)) ring-spacing)))
;;
;; float ring down
;;
(do ()
((>= y0 toY))
(setq inc (if (> (- toY y0) accel) accel (- toY y0)))
(setq y0 (+ y0 inc))
(setq y1 (+ y1 inc))
(funcall hanoi-canvas "coords" r x0 y0 x1 y1)
(update))
;;
;; increase destination pole usage
;;
(incf (car (svref pole to)))
(setf (car (svref ring n)) to)))
(SetupHanoi)

14
src/tk/Demos/hello.lsp
View file

@ -1,14 +0,0 @@
;; Simple Tk script to create a button that prints "Hello, world".
;; Click on the button to terminate the program.
;;
;; The first line below creates the button, and the second line
;; arranges for packer to manage the button's geometry, centering
;; it in the application's main window.
(in-package "TK")
(button ".hello" "-text" "Hello, world"
"-command" '(progn
(format t "Hello, world~%")
(destroy .hello)))
(pack .hello)

288
src/tk/Demos/queens.lsp
View file

@ -1,288 +0,0 @@
;
; This demo is a contribution of Grant Edwards (grante@rosemount.com)
; Modified for ECL by G. Attardi (attardi@di.unipi.it)
; Yet another "my first STk program" type thing. This one is the "8
; queens" puzzle. You try to figure out how to place 8 queens on a
; chessboard so that none of the queens can be taken in a single move.
; You can do it yourself (and it will make sure you follow the rules)
; or you can ask it to solve the puzzle starting with a given board
; configuration.
(in-package "TK")
(defvar queen-bitmap (concatenate 'string "@"
si:*system-directory* "tk/bitmaps/queen"))
; size of board (it's square)
(defvar size 8)
; Predicate that is true if the queens at p1 and p2 can't take each
; other in 1 move. p1 and p2 are pairs of the form ( x . y ) where
; x is column and y is row (both from 0 to size-1).
(defun legal-position-pair? (p1 p2)
(let ((x1 (car p1)) (y1 (cdr p1)) (x2 (car p2)) (y2 (cdr p2)))
(not (or
(= x1 x2)
(= y1 y2)
(= (abs (- x1 x2)) (abs (- y1 y2)))))))
; Predicate that is true if none of the queens in list history can
; take queen at postion new in one move. "history" is a list of
; position pairs. "new" is the position pair which we are testing.
(defun legal-move? (history new)
(cond
((null history) T)
((not (legal-position-pair? (car history) new)) NIL)
(T (legal-move? (cdr history) new))))
; This is the procedure that solves the puzzle given a list of
; occupied squares and a list of empty rows. It's also passed a
; continuation so that it can abort when the user asks it to stop.
; Add a legal move to history list and recurse to build up strings of
; legal moves. The chessboard is updated as pieces are placed. When
; it reaches the required length, it waits for user to press the Next
; or Stop button. "history" is a list of pairs that denotes where
; there are already queens. "ylist" is a list of rows that still need
; to be filled. "break" is a continuation to be called when the
; procedure is to be aborted.
(defun add-queen (history ylist break)
(cond
(stopPushed (throw break NIL))
((null ylist) (progn (write history)
(terpri)
(waitForNextButton)
(when stopPushed
(throw break NIL))))
(T (let ((newy (car ylist)))
(dotimes (newx size)
(when (legal-move? history (cons newx newy))
(activate-button newx newy)
(update)
(add-queen (cons (cons newx newy) history)
(cdr ylist) break)
(deactivate-button newx newy)
(update)))))))
; global boolean used to keep track of whether or not the user is
; allowed to rearrange the board.
(defvar userModsEnabled T)
; set up button states and solve the puzzle starting with the current
; board configuration.
(defun do-solve ()
(setq stopPushed NIL)
(.q.upper.solve "configure" "-state" "disabled")
(.q.upper.stop "configure" "-state" "normal")
(.q.upper.clear "configure" "-state" "disabled")
(.q.upper.quit "configure" "-state" "disabled")
(setq userModsEnabled NIL)
(let ((break (cons nil nil)))
(catch break
(add-queen (current-positions) (empty-rows) break)))
(.q.upper.stop "configure" "-state" "disabled")
(.q.upper.clear "configure" "-state" "normal")
(setq userModsEnabled T)
(.q.upper.solve "configure" "-state" "normal")
(.q.upper.quit "configure" "-state" "normal"))
; Create two matrixes. Each has an entry for each square on the
; board. One matrix is Tk button procedures, the other is booleans
; that reflect whether or not the square is occupied.
(defvar board-buttons (make-array (list size size)))
(defvar board-states (make-array (list size size)))
; redraw the button so that it is occupied and update the matrix of
; booleans
(defun activate-button (x y)
(funcall (aref board-buttons y x)
"configure" "-relief" "raised" "-foreground" "#000")
(setf (aref board-states y x) T))
; redraw the button so that it is empty and update the matrix of
; booleans
(defun deactivate-button (x y)
(let* ((b (aref board-buttons y x))
(bg (fifth (funcall b "configure" "-background"))))
(funcall b "configure" "-relief" "flat" "-foreground" bg)
(setf (aref board-states y x) NIL)))
; flash a button
(defun flash-button (x y)
(funcall (aref board-buttons y x) "flash"))
; Procedure called when the user clicks on a square in the chessboard.
; If user modifications are not enabled, then do nothing. Otherwise
; toggle the sate of the square. When placing a queen on a previously
; empty square, remove existing queens that could be taken by the new
; one.
(defun toggle-button (x y)
(cond
((not userModsEnabled) NIL)
((aref board-states y x) (deactivate-button x y))
(t (activate-button x y)
(update)
(dotimes (ox size)
(dotimes (oy size)
(when (and (aref board-states oy ox)
(not (and (= x ox) (= y oy)))
(not (legal-position-pair? (cons x y) (cons ox oy))))
(flash-button ox oy)
(flash-button ox oy)
(flash-button ox oy)
(deactivate-button ox oy)
(update)))))))
; clear the board
(defun clear-board ()
(dotimes (x size) (dotimes (y size) (deactivate-button x y))))
; Procedures to return a list of consecutive integers from start to
; end (inclusive).
(defun interval (start end)
(do ((s start)
(e end (1- e))
(l () (cons e l)))
((> s e) l)))
(defun rinterval (start end)
(do ((s start (1+ s))
(e end)
(l () (cons s l)))
((> s e) l)))
; Return a list of integers that identify the rows on the chessboard
; that are empty
(defun empty-rows ()
(let ((empty ()))
(dotimes (row size)
(dotimes (col size (push row empty))
(when (aref board-states row col)
(return))))
empty))
; Return a list of pairs ( x . y ) indicating which squares are
; currently occupied.
(defun current-positions ()
(let ((p ()))
(dotimes (x size)
(dotimes (y size)
(when (aref board-states y x)
(push (cons x y) p))))
p))
; Booleans used to detect when user presses a button
(defvar nextOrStopPushed NIL)
(defvar stopPushed NIL)
; Procedure to wait for the user to press either the next or stop
; buttons.
(defun waitForNextButton ()
(.q.upper.next "configure" "-state" "normal")
(tkwait "variable" 'nextOrStopPushed)
(.q.upper.next "configure" "-state" "disabled"))
; Create top level window
(toplevel ".q" "-class" "Queens")
(wm "title" .q "Queens")
(wm "iconname" .q "Queens")
; Define two frames. The upper will hold control buttons, the lower
; the chessboard buttons
(frame ".q.lower")
(frame ".q.upper" "-relief" "raised" "-borderwidth" 2)
; add a frame to the lower frame for each row of sqaures on the
; chessboard and fill that row with buttons (one per square).
(dotimes (y size)
(let ((rowframe (format NIL ".q.lower.row~a" y)))
(frame rowframe)
(dotimes (x size)
(let* ((bn (format NIL "~a.b~a" rowframe x))
(bp (intern (button bn
"-bitmap" queen-bitmap
"-relief" "flat"))))
(setf (aref board-buttons y x) (symbol-function bp))
(setf (aref board-states y x) NIL) ; if we reload file
(let ((bg (if (oddp (+ x y)) "#bbb" "#eee")))
(funcall bp "configure" "-background" bg "-activebackground" "#fff"
"-foreground" bg))
(bind bn "<Button-1>" `(toggle-button ,x ,y))
(bind bn "<Any-Enter>" '())
(bind bn "<Any-Leave>" '())
(bind bn "<ButtonRelease-1>" '())
(pack bn "-side" "left")
)
)
(pack (intern rowframe) "-side" "bottom")
)
)
; add control buttons to upper frame
(button ".q.upper.quit" "-text" "Quit" "-command" '(destroy .q))
(frame ".q.upper.fill")
(button ".q.upper.solve" "-text" "Solve" "-command" '(do-solve))
(button ".q.upper.clear" "-text" "Clear" "-command" '(clear-board))
(button ".q.upper.next"
"-text" "Next"
"-state" "disabled"
"-command" '(setq stopPushed NIL
nextOrStopPushed T))
(button ".q.upper.stop"
"-text" "Stop"
"-state" "disabled"
"-command" '(setq stopPushed T
nextOrStopPushed T))
(pack .q.upper.solve "-side" "left" "-padx" 4 "-pady" 4)
(pack .q.upper.next "-side" "left" "-padx" 4 "-pady" 4)
(pack .q.upper.stop "-side" "left" "-padx" 4 "-pady" 4)
(pack .q.upper.clear "-side" "left" "-padx" 4 "-pady" 4)
(pack .q.upper.quit "-side" "right" "-padx" 4 "-pady" 4)
(pack .q.upper.fill "-side" "right" "-fill" "x")
; arrange the two top level frames
(pack .q.upper "-side" "top" "-fill" "x")
(pack .q.lower "-side" "bottom")

36
src/tk/Makefile.in
View file

@ -1,36 +0,0 @@
top_srcdir= @top_srcdir@
srcdir = @srcdir@
VPATH = @srcdir@
MACHINE = @host@
# Programs used by "make":
#
CC = @CC@
DEFS = -D$(MACHINE)
CFLAGS = -c @CPPFLAGS@ @CFLAGS@ $(DEFS)
OFLAG = @OFLAG@
SHELL = /bin/sh
RM = @RM@
# Source Directories
HDIR = @HDIR@
# Files
HFILES = @HFILES@
OBJS = @TKOBJS@
all: $(OBJS)
clean:
$(RM) $(OBJS) core a.out
# Build rules
%.o : %.c
$(CC) -c $(CFLAGS) $(OFLAG) $< -o $@

8
src/tk/bitmaps/error
View file

@ -1,8 +0,0 @@
#define error_width 17
#define error_height 17
static char error_bits[] = {
0xf0, 0x0f, 0x00, 0x58, 0x15, 0x00, 0xac, 0x2a, 0x00, 0x16, 0x50, 0x00,
0x2b, 0xa0, 0x00, 0x55, 0x40, 0x01, 0xa3, 0xc0, 0x00, 0x45, 0x41, 0x01,
0x83, 0xc2, 0x00, 0x05, 0x45, 0x01, 0x03, 0xca, 0x00, 0x05, 0x74, 0x01,
0x0a, 0xa8, 0x00, 0x14, 0x58, 0x00, 0xe8, 0x2f, 0x00, 0x50, 0x15, 0x00,
0xa0, 0x0a, 0x00};

6
src/tk/bitmaps/gray25
View file

@ -1,6 +0,0 @@
#define gray25_width 16
#define gray25_height 16
static char gray25_bits[] = {
0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22,
0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88,
0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88};

6
src/tk/bitmaps/gray50
View file

@ -1,6 +0,0 @@
#define gray50_width 16
#define gray50_height 16
static char gray50_bits[] = {
0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa,
0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa,
0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa};

9
src/tk/bitmaps/hourglass
View file

@ -1,9 +0,0 @@
#define hourglass_width 19
#define hourglass_height 21
static char hourglass_bits[] = {
0xff, 0xff, 0x07, 0x55, 0x55, 0x05, 0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01,
0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01, 0xc2, 0x0a, 0x03, 0x46, 0x05, 0x01,
0x82, 0x0a, 0x03, 0x06, 0x05, 0x01, 0x02, 0x03, 0x03, 0x86, 0x05, 0x01,
0xc2, 0x0a, 0x03, 0x66, 0x15, 0x01, 0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01,
0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01, 0xa2, 0x2a, 0x03, 0xff, 0xff, 0x07,
0xab, 0xaa, 0x02};

5
src/tk/bitmaps/info
View file

@ -1,5 +0,0 @@
#define info_width 8
#define info_height 21
static char info_bits[] = {
0x3c, 0x2a, 0x16, 0x2a, 0x14, 0x00, 0x00, 0x3f, 0x15, 0x2e, 0x14, 0x2c,
0x14, 0x2c, 0x14, 0x2c, 0x14, 0x2c, 0xd7, 0xab, 0x55};

9
src/tk/bitmaps/queen
View file

@ -1,9 +0,0 @@
#define queen_width 19
#define queen_height 22
static char queen_bits[] = {
0x00, 0x02, 0x00, 0x00, 0x02, 0x00, 0x80, 0x0f, 0x00, 0x00, 0x02, 0x00,
0x00, 0x02, 0x00, 0xf0, 0x7a, 0x00, 0xfc, 0xff, 0x01, 0x0c, 0x87, 0x01,
0x06, 0x07, 0x03, 0x06, 0x07, 0x03, 0x06, 0x07, 0x03, 0x06, 0x07, 0x03,
0x06, 0x07, 0x03, 0x0c, 0x87, 0x01, 0x0c, 0x87, 0x01, 0x0c, 0x87, 0x01,
0x18, 0xc7, 0x00, 0x18, 0xc7, 0x00, 0x18, 0xe7, 0x00, 0x30, 0x67, 0x00,
0xfc, 0xff, 0x01, 0xfc, 0xff, 0x01};

9
src/tk/bitmaps/questhead
View file

@ -1,9 +0,0 @@
#define questhead_width 20
#define questhead_height 22
static char questhead_bits[] = {
0xf8, 0x1f, 0x00, 0xac, 0x2a, 0x00, 0x56, 0x55, 0x00, 0xeb, 0xaf, 0x00,
0xf5, 0x5f, 0x01, 0xfb, 0xbf, 0x00, 0x75, 0x5d, 0x01, 0xfb, 0xbe, 0x02,
0x75, 0x5d, 0x05, 0xab, 0xbe, 0x0a, 0x55, 0x5f, 0x07, 0xab, 0xaf, 0x00,
0xd6, 0x57, 0x01, 0xac, 0xab, 0x00, 0xd8, 0x57, 0x00, 0xb0, 0xaa, 0x00,
0x50, 0x55, 0x00, 0xb0, 0x0b, 0x00, 0xd0, 0x17, 0x00, 0xb0, 0x0b, 0x00,
0x58, 0x15, 0x00, 0xa8, 0x2a, 0x00};

10
src/tk/bitmaps/question
View file

@ -1,10 +0,0 @@
#define question_width 17
#define question_height 27
static char question_bits[] = {
0xf0, 0x0f, 0x00, 0x58, 0x15, 0x00, 0xac, 0x2a, 0x00, 0x56, 0x55, 0x00,
0x2b, 0xa8, 0x00, 0x15, 0x50, 0x01, 0x0b, 0xa0, 0x00, 0x05, 0x60, 0x01,
0x0b, 0xa0, 0x00, 0x05, 0x60, 0x01, 0x0b, 0xb0, 0x00, 0x00, 0x58, 0x01,
0x00, 0xaf, 0x00, 0x80, 0x55, 0x00, 0xc0, 0x2a, 0x00, 0x40, 0x15, 0x00,
0xc0, 0x02, 0x00, 0x40, 0x01, 0x00, 0xc0, 0x02, 0x00, 0x40, 0x01, 0x00,
0xc0, 0x02, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0xc0, 0x02, 0x00,
0x40, 0x01, 0x00, 0xc0, 0x02, 0x00, 0x00, 0x01, 0x00};

5
src/tk/bitmaps/warning
View file

@ -1,5 +0,0 @@
#define warning_width 6
#define warning_height 19
static char warning_bits[] = {
0x0c, 0x16, 0x2b, 0x15, 0x2b, 0x15, 0x2b, 0x16, 0x0a, 0x16, 0x0a, 0x16,
0x0a, 0x00, 0x00, 0x1e, 0x0a, 0x16, 0x0a};

84
src/tk/button.lsp
View file

@ -1,84 +0,0 @@
;;;;
;;;; Buttons, Check button and radio buttons bindings and procs
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 22-Nov-1993 16:00
;;;;
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
;; Class bindings for various flavors of button widgets. tk::window
;; keeps track of the button containing the mouse, and tk::relief
;; saves the original relief of the button so it can be restored when
;; the mouse button is released.
(in-package "TK")
(let ((Button-bindings '(("<Any-Enter>" . (tk-butEnter %W))
("<Any-Leave>" . (tk-butLeave %W))
("<1>" . (tk-butDown %W))
("<ButtonRelease-1>" . (tk-butUp %W)))))
(def-bindings "Button" Button-bindings)
(def-bindings "Checkbutton" Button-bindings)
(def-bindings "Radiobutton" Button-bindings))
;; The procedure below is invoked when the mouse pointer enters a
;; button widget. It records the button we're in and changes the
;; state of the button to active unless the button is disabled.
(defun tk-butEnter (w)
(unless (equal (tk-get w "-state") "disabled")
(unless tk-strictMotif (tk-setq w "-state" "active"))
(setq tk::window w)))
;; The procedure below is invoked when the mouse pointer leaves a
;; button widget. It changes the state of the button back to
;; inactive.
(defun tk-butLeave (w)
(unless (equal (tk-get w "-state") "disabled")
(unless tk-strictMotif (tk-setq w "-state" "normal"))
(setq tk::window "")))
;; The procedure below is invoked when the mouse button is pressed in
;; a button/radiobutton/checkbutton widget. It records information
;; (a) to indicate that the mouse is in the button, and
;; (b) to save the button's relief so it can be restored later.
(defun tk-butDown (w)
(setq tk::buttonWindow w)
(setq tk::relief (tk-get w "-relief"))
(unless (equal (tk-get w "-state") "disabled")
(tk-setq w "-relief" "sunken")))
;; The procedure below is invoked when the mouse button is released
;; for a button/radiobutton/checkbutton widget. It restores the
;; button's relief and invokes the command as long as the mouse
;; hasn't left the button.
(defun tk-butUp (w)
(when (equal w tk::buttonWindow)
(tk-setq w "-relief" tk::relief)
(when (and (equal w tk::window)
(not (equal (tk-get w "-state") "disabled")))
(funcall w "invoke"))
(setq tk::buttonWindow '())))

157
src/tk/dialog.lsp
View file

@ -1,157 +0,0 @@
;;;;
;;;; Dialog box creation utility
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 4-Aug-1993 11:05
;;;; Last file update: 5-Feb-1995 16:38
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
(provide "dialog")
(defvar dialog-old-focus "none")
(defvar dialog-old-grab ())
(defvar button-pressed NIL)
;;
;; make-dialog
;;
;; This procedure displays a dialog box following the spcifications given in
;; arguments. Arguments are given as keywords.
;;
;; window (.dialog) Window name to use for dialog top-level.
;; title ("Dialog") Title to display in dialog's decorative frame.
;; text ("") Message to display in dialog.
;; bitmap ("") Bitmap to display in dialog (empty string means none).
;; default (-1) Index of button that is to display the default ring
;; (-1 means none).
;; grabbing (NIL) Indicates if make-dialog must wait that a button be
;; pressed before returning
;; buttons ('()) A list of couples indicating the button text and its
;; associated action (a lambda)
;;
;; If grabbing is set, this procedure returns the button pressed index.
;;
(defun make-dialog (&key ((window w) ".dialog")
(title "Dialog")
(text "")
(bitmap "")
(default -1)
((grab grabbing) NIL)
(buttons '()))
(catch-errors (destroy w))
;; 1. Create the top-level window and divide it into top and bottom parts.
(let ((w.top (& w ".top"))
(w.bot (& w ".bot"))
(w.msg (& w ".msg"))
(w.bmp (& w ".bmp")))
(toplevel w "-class" "Dialog")
(wm "title" w title)
(wm "iconname" w "Dialog")
(pack (frame w.top "-relief" "raised" "-bd" 1)
(frame w.bot "-relief" "raised" "-bd" 1)
"-fill" "both")
;; 2. Fill the top part with bitmap and message.
(pack (message w.msg "-aspect" 1000 "-text" text
"-font" "-Adobe-Times-Medium-R-Normal-*-180-*")
"-in" w.top
"-side" "right"
"-expand" T
"-fill" "both"
"-padx" "5m"
"-pady" "5m")
(unless (equal bitmap "")
(pack (label w.bmp "-bitmap" bitmap "-fg" "red")
"-in" w.top
"-side" "left"
"-padx" "5m"
"-pady" "5m"))
;; 3. Create a row of buttons at the bottom of the dialog.
(do ((i 0 (+ i 1)) (but buttons (cdr but)))
((null but) '())
(let ((name (& w ".button" i)))
(button name "-text" (caar but)
"-command" `(progn
(focus dialog-old-focus)
(setq button-pressed ,i)
(destroy (string->widget ,(& w)))
(apply ,(cadar but) '())))
(if (equal i default)
(let ((default (& w ".default")))
(frame default "-relief" "ridge" "-bd" 3)
(raise name default)
(pack default "-in" w.bot
"-side" "left"
"-expand" T
"-padx" 20
"-pady" 8)
(pack name "-in" default
"-padx" 5
"-pady" 5
"-ipadx" 2
"-ipady" 2)
(bind w "<Return>" (tk-get (string->widget name) "-command")))
(pack name "-in" w.bot
"-side" "left"
"-expand" 1
"-padx" 20
"-pady" 8
"-ipadx" 2
"-ipady" 2)))))
;; 4. Center window
(center-window w)
;; 5. Set focus to the new window
(setq dialog-old-focus (get-focus))
(focus w)
(when grabbing
(setq dialog-old-grab (funcall grab "current" *root*))
(funcall grab "set" w)
(tkwait "variable" "button-pressed")
(if (not (null dialog-old-grab))
(funcall grab dialog-old-grab)))
button-pressed)
(defun center-window (w)
;; Withdraw the window, then update all the geometry information
;; so we know how big it wants to be, then center the window in the
;; display and de-iconify it.
(wm "withdraw" w)
(update "idletasks")
(let ((x (- (/ (parse-integer (winfo "screenwidth" w)) 2)
(/ (parse-integer (winfo "reqwidth" w)) 2)
(winfo "vrootx" (eval (winfo "parent" w)))))
(y (- (/ (parse-integer (winfo "screenheight" w)) 2)
(/ (parse-integer (winfo "reqheight" w)) 2)
(parse-integer (winfo "vrooty" (eval (winfo "parent" w)))))))
(wm "geom" w (& "+" (floor x) "+" (floor y)))
(wm "deiconify" w)))

278
src/tk/editor.lsp
View file

@ -1,278 +0,0 @@
;;;; e d i t o r . l s p -- A small editor to create enhanced
;;;; text (used for Help page construction)
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;; Creation date: 6-Dec-1993 17:25
;;;; Last file update: 17-Oct-1994 18:41
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
(provide "editor")
;;;;
;;;; Font definition
;;;;
(defvar STF-signature "STF-0.1")
(defvar normal-font "*-Courier-Medium-R-Normal-*-120-*")
(defvar all-fonts `(
(normal ,normal-font)
(fixed "fixed")
(big "-*-times-*-r-*-*-*-240-*-*-*-*-*-*")
(roman-12 "-*-times-*-r-*-*-*-120-*-*-*-*-*-*")
(roman-14 "-*-times-*-r-*-*-*-140-*-*-*-*-*-*")
(roman-16 "-*-times-*-r-*-*-*-160-*-*-*-*-*-*")
(roman-18 "-*-times-*-r-*-*-*-180-*-*-*-*-*-*")
(italic-12 "-*-times-*-i-*-*-*-120-*-*-*-*-*-*")
(italic-14 "-*-times-*-i-*-*-*-140-*-*-*-*-*-*")
(italic-16 "-*-times-*-i-*-*-*-160-*-*-*-*-*-*")
(italic-18 "-*-times-*-i-*-*-*-180-*-*-*-*-*-*")
(bold-12 "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
(bold-14 "-*-helvetica-bold-r-*-*-*-140-*-*-*-*-*-*")
(bold-16 "-*-helvetica-bold-r-*-*-*-160-*-*-*-*-*-*")
(bold-18 "-*-helvetica-bold-r-*-*-*-180-*-*-*-*-*-*")
(bold-italic-12 "-*-helvetica-bold-o-*-*-*-120-*-*-*-*-*-*")
(bold-italic-14 "-*-helvetica-bold-o-*-*-*-140-*-*-*-*-*-*")
(bold-italic-16 "-*-helvetica-bold-o-*-*-*-160-*-*-*-*-*-*")
(bold-italic-18 "-*-helvetica-bold-o-*-*-*-180-*-*-*-*-*-*")
(tty-12 "-adobe-courier-medium-*-*-*-*-120-*-*-*-*-*-*")
(tty-14 "-adobe-courier-medium-*-*-*-*-140-*-*-*-*-*-*")
(tty-16 "-adobe-courier-medium-*-*-*-*-160-*-*-*-*-*-*")
(tty-18 "-adobe-courier-medium-*-*-*-*-180-*-*-*-*-*-*")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Fonts utilities
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun unset-tags (editor-window start end)
(dolist (tag all-fonts)
(funcall editor-window "tag" "remove" (car tag) start end)))
(defun set-font (editor-window font start end)
;; Be sure this tag exists
(funcall editor-window "tag" "conf" font "-font" (cadr (assoc font all-fonts)))
;; Delete all the tags associated to this range
(unset-tags editor-window start end)
;; Set a new tag for this character range
(funcall editor-window "tag" "add" font start end))
(defun set-underline (editor-window start end)
(funcall editor-window "tag" "conf" "underline" "-underline" T)
(funcall editor-window "tag" "add" "underline" start end))
(defun fontify-selection (editor-window font)
(setq editor-window (string->widget editor-window))
(catch-errors
(set-font editor-window
font
(funcall editor-window "index" "sel.first")
(funcall editor-window "index" "sel.last"))))
(defun underline-selection (editor-window value)
(setq editor-window (string->widget editor-window))
(catch-errors
(let ((start (funcall editor-window "index" "sel.first"))
(end (funcall editor-window "index" "sel.last")))
;; Remove all underlining information in this area
(funcall editor-window "tag" "remove" "underline" start end)
;; Set underline if value is T
(when value (set-underline editor-window start end)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Scheme Text Format (STF) management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-STF (editor-window)
(list STF-signature
(funcall editor-window "get" "1.0" "end")
(let ((l '()))
(dolist (t (cons `(underline NIL) all-fonts))
(let ((tags (funcall editor-window "tag" "range" (car t))))
(unless (null tags)
(setq l (cons (list (car t) tags) l)))))
l)))
(defun set-STF (editor-window STF)
(let ((text (cadr STF)) (fmts (caddr STF)))
;; First insert new text
(funcall editor-window "delete" "1.0" "end")
(funcall editor-window "insert" "1.0" text)
(funcall editor-window "mark" "set" "insert" "1.0")
;; And now enhence it
(dolist (t fmts)
(do ((l (cadr t) (cddr l)))
((null l))
(if (equal (car t) "underline")
(set-underline editor-window (car l) (cadr l))
(set-font editor-window (car t) (car l) (cadr l))))))
(update))
(defun write-file (editor-window file)
(setq editor-window (string->widget editor-window))
(with-open-file (s file :direction :output)
(format s ";;;; ~S\n" STF-signature)
(format s "~S\n" (get-STF editor-window))))
(defun write-file-ascii (editor-window file)
(setq editor-window (string->widget editor-window))
(with-open-file (s file :direction :output)
(format s "~A" (funcall editor-window "get" "1.0" "end"))))
(defun read-file (editor-window file)
(setq editor-window (string->widget editor-window))
(with-open-file (s file)
(let ((first-line (read-line s)))
(if (string= first-line (format NIL ";;;; ~S" STF-signature))
;; File is a STF file
(set-STF editor-window (read s))
;; File must be read as a "normal" file
(progn
(funcall editor-window "delete" "1.0" "end")
(do ((l first-line (read-line s nil nil)))
((null l))
(funcall editor-window "insert" "end" l)
(funcall editor-window "insert" "end" #\newline))
(funcall editor-window "mark" "set" "insert" "1.0")))))))
(defun get-filename (toplevel) ; return the content of the file name entry
(let ((entry (string->widget (& toplevel ".bt.e"))))
(funcall entry "get")))
(defun set-filename (toplevel filename)
(let ((entry (string->widget (& toplevel ".bt.e"))))
(funcall entry "delete" 0 "end")
(funcall entry "insert" 0 filename)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Interface
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun make-editor (name &rest exit_code)
(let* ((top (toplevel name))
(menu-bar (frame (& name ".mb") "-bd" 2 "-relief" "groove"))
(bottom (frame (& name ".bt")))
(text-area (frame (& name ".ta")))
(exit_code (if (null exit_code) `(destroy ,top) (car exit_code)))
(the-editor ()))
;;
;; Window manager management
;;
(wm "maxsize" name 1000 800)
(wm "protocol" name "WM_DELETE_WINDOW" exit_code)
;;
;; Text area frame
;;
(pack (scrollbar (& text-area ".sc") "-orient" "vert"
"-bd" 2
"-relief" "groove"
"-command" (format NIL "~A \"yview\""
(& text-area ".ed")))
"-side" "left" "-fill" "y")
(pack (text (& text-area ".ed") "-padx" 4
"-pady" 4
"-bd" 2
"-wrap" "word"
"-relief" "groove"
"-yscroll" (format NIL "~A \"set\""
(& text-area ".sc")))
"-side" "right" "-expand" T "-fill" "both")
(setq the-editor (& text-area ".ed"))
;;
;; Menu Creation
;;
(let* ((File (menubutton (& menu-bar ".file")
"-text" "File"
"-padx" 10
"-menu" (& menu-bar ".file.m")))
(m (string->widget (menu (& menu-bar ".file.m")))))
(funcall m "add" "command"
"-label" " Read "
"-command" `(read-file ,the-editor (get-filename ,top)))
(funcall m "add" "command"
"-label" " Save "
"-command" `(write-file ,the-editor (get-filename ,top)))
(funcall m "add" "command"
"-label" " Save Ascii "
"-command" `(write-file-ascii ,the-editor (get-filename ,top)))
(funcall m "add" "separator")
(funcall m "add" "command" "-label" " Quit " "-command" exit_code)
(pack File "-side" "left"))
(let* ((Font (menubutton (& menu-bar ".font")
"-text" "Font"
"-padx" 10
"-menu" (& menu-bar ".font.m")))
(m (string->widget (menu (& menu-bar ".font.m")))))
(dolist (font all-fonts)
(funcall m "add" "command"
"-label" (car font)
"-font" (cadr font)
"-command" `(fontify-selection ,the-editor
',(car font))))
(funcall m "add" "separator")
(funcall m "add" "command"
"-label" "Underline"
"-command" `(underline-selection ,the-editor T))
(funcall m "add" "command"
"-label" "No underline"
"-command" `(underline-selection ,the-editor NIL))
(pack Font "-side" "left"))
;;
;; Bottom frame
;;
(pack (label (& bottom ".l") "-text" "File name" "-padx" 10) "-side" "left")
(pack (entry (& bottom ".e") "-relief" "ridge") "-side" "left" "-expand" T "-fill" "x")
;;
;; Pack everybody
;;
(pack menu-bar "-fill" "x")
(pack text-area "-expand" T "-fill" "both")
(pack bottom "-fill" "x" "-ipady" 4 "-ipadx" 10)))
;; A simple editor accessible from prompt
(defun ed (&rest file)
(require "editor")
(let ((editor-name (gensym ".editor")))
(make-editor editor-name)
(unless (null file)
(read-file (& editor-name ".ta.ed") (car file))
(set-filename editor-name (car file)))))

130
src/tk/entry.lsp
View file

@ -1,130 +0,0 @@
;;;;
;;;; Entries bindings and procs
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 2-Jun-1994 12:42
;;;;
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
;; ----------------------------------------------------------------------
;; Class bindings for entry widgets.
;; ----------------------------------------------------------------------
;; Button 1 bindings
(def-bindings "Entry" '(
;; Button 1 bindings
("<1>" . (progn
(%W "icursor" '@%x)
(%W "select" "from" '@%x)
(when(equal (tk-get %W "-state") "normal")
(focus %W))))
("<B1-Motion>" . (%W "select" "to" '@%x))
;; Button 2 bindings
("<2>" . (catch-errors
(%W "insert" "insert" (selection "get"))
(tk-entrySeeCaret %W)))
("<Shift-2>" . (%W "scan" "mark" %x))
("<Shift-B2-Motion>" . (%W "scan" "dragto" %x))
;; Button 3 bindings
("<3>" . (%W "select" "adjust" '@%x))
;; Special keys bindings
("<Control-a>" . (progn
(%W "icursor" 0)
(tk-entrySeeCaret %W)))
("<Control-b>" . (tk-backwardChar %W))
("<Control-c>" . (%W "delete" 0 "end"))
("<Control-d>" . (progn
(%W "delete" "insert")
(tk-entrySeeCaret %W)))
("<Control-e>" . (progn
(%W "icursor" "end")
(tk-entrySeeCaret %W)))
("<Control-f>" . (tk-forwardChar %W))
("<Control-g>" . (%W "delete" 0 "end"))
("<Control-h>" . (tk-entryBackspace %W))
("<Control-k>" . (progn
(%W "delete" "insert" "end")
(tk-entrySeeCaret %W)))
("<Control-w>" . (catch-errors
(setq tk::kill-buffer
(%W "delete" 'sel.first 'sel.last))
(%W "delete" 'sel.first 'sel.last)
(tk-entrySeeCaret %W)))
("<Control-y>" . (progn
(%W "insert" "insert" tk::kill-buffer)
(tk-entrySeeCaret %W)))
("<Delete>" . (tk-entryBackspace %W))
("<BackSpace>" . (tk-entryBackspace %W))
("<Any-backslash>" . (progn
(%W "insert" "insert" "\\")
(tk-entrySeeCaret %W)))
("<Any-quotedbl>" . (progn
(%W "insert" "insert" "\"")
(tk-entrySeeCaret %W)))
("<Any-KeyPress>" . (unless (equal "\\%A" "\\0")
(%W "insert" "insert" "%A")
(tk-entrySeeCaret %W)))
))
*lib-bindings*)
;; Entries utility functions
(defun tk-entryIndex (w pos)
(parse-integer (funcall w "index" pos)))
(defun tk-forwardChar (w)
(funcall w "icursor" (+ (tk-entryIndex w "insert") 1))
(tk-entrySeeCaret w))
(defun tk-backwardChar (w)
(funcall w "icursor" (- (tk-entryIndex w "insert") 1))
(tk-entrySeeCaret w))
(defun tk-entryBackspace (w)
(let ((x (- (tk-entryIndex w "insert") 1)))
(if (>= x 0) (progn (funcall w "delete" x) (tk-entrySeeCaret w)))))
;; The procedure below is invoked after insertions. If the caret is not
;; visible in the window then the procedure adjusts the entry's view to
;; bring the caret back into the window again.
(defun tk-entrySeeCaret (w)
(let ((c (tk-entryIndex w "insert"))
(left (tk-entryIndex w "@0"))
(width (format NIL "@~A" (- (parse-integer (winfo "width" w)) 5))))
(when (>= left c)
(funcall w "view" (- c (if (> c 0) 1 0 ))))
(do ((right (tk-entryIndex w width) (tk-entryIndex w width)))
((or (>= right c) (>= left c)))
(setq left (+ left 1))
(funcall w "view" left))))
;;;;;;;
;;tk-bindForTraversal Entry
;;;;;;;

168
src/tk/error.lsp
View file

@ -1,168 +0,0 @@
;;;;
;;;; e r r o r . l s p -- All the stuff going with error messages
;;;; display
;;;;
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 15-Sep-1993 14:11
;;;; Last file update: 5-Feb-1995 16:16
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Data section
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar help-for-stackvue '("STF-0.1" "
ECL/tk stack window help~%~%~%
The ECL/tk stack window permits you to see the evaluation stack.Each line contains the parameters passed to an invocation of the eval procedure (last call to eval is on the first line).~%~%
To inspect an object, you can select it with the mouse (either by dragging the mouse or with a double click to select a whole word) and, once this is done, you can call the inspector by clicking the Inspect button. This will bring an inspector window if it does not exist yet.Otherwise the selected object will be added to the list of inspected objects in your inspector.
" ((bold-italic-12 ("6.4" "6.14")) (italic-12 ("9.3" "9.10")) (roman-18 ("2.0" "3.0")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; report-error
;;;;
;;;; Redefine here report-error. This version of report-error needs Tk
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar %stack '())
(defun %truncate-string (s len)
(if (> (string-length s) len)
(format NIL "~A ..." (substring s 0 (- len 1)))
s))
(defun report-error (head message obj)
(setq %stack (%get-eval-stack)) ;; Take a photo of the stack as soon as possible
(let* ((who (if (null obj) "" (format NIL "~S" obj)))
(msg (%truncate-string (format NIL "~A~%~A~%~A" head message who) 200)))
;; Print message on standard error stream
(format (current-error-port) "~%~A~A~A~%"
head message (if (equal who "")
""
(format NIL ": ~A" who)))
(make-dialog "-window" '.report-error
"-title" "ECL/tk error"
"-text" msg
"-bitmap" "error"
"-grabbing" T
"-default" 0
"-buttons" `((" Dismiss " (lambda () '()))
(" See the stack " (lambda ()
(display-stack
(cddr %stack))))))
(update)))
(defun display-stack (stack)
(catch-errors (destroy ".stackvue"))
;; Build a toplevel
(toplevel ".stackvue")
(wm "title" .stackvue "ECL/tk stack")
;; Dispose items
(label ".stackvue.l" "-text" "Stack content" "-fg" "RoyalBlue")
(frame ".stackvue.f" "-borderwidth" 3 "-relief" "ridge")
(frame ".stackvue.b")
(pack
(button ".stackvue.b.i" "-text" "Inspect"
"-command" "(run-inspect)")
(button ".stackvue.b.h" "-text" "Help"
"-command" "(make-help help-for-stackvue)")
(button ".stackvue.b.q" "-text" "Quit" "-command" "(destroy .stackvue)")
"-side" "left" "-fill" "x" "-expand" T)
(pack .stackvue.l "-side" "top")
(pack .stackvue.f "-side" "top" "-expand" T "-fill" "both")
(pack .stackvue.b "-side" "bottom" "-fill" "x")
(scrollbar ".stackvue.f.sy" "-command" ".stackvue.f.list \"yview\"" "-orient" "vert")
(text ".stackvue.f.list" "-width" 60
"-height" 15
"-yscroll" ".stackvue.f.sy \"set\""
"-font" "fixed"
"-bd" 1
"-relief" "raised"
"-padx" 3
"-wrap" "none")
(pack .stackvue.f.sy "-side" "left" "-fill" "y")
(pack .stackvue.f.list "-expand" "yes" "-fill" "both")
;; Center the window
(center-window .stackvue)
;; Insert all the elements of the stack in the listbox
(do ((stack stack (cdr stack)))
((null stack))
(.stackvue.f.list "insert" "end"
(%truncate-string (format NIL "~%~S" (uncode(car stack)))150)))
;; Insert a marker to delimit bottom of the stack
(.stackvue.f.list "insert" "end" "~%<<< STACK BOTTOM >>>")
(.stackvue.f.list "tag" "add" "bottom" "end linestart" "end")
(.stackvue.f.list "tag" "conf" "bottom" "-font" "8x13bold" "-foreground" "Red")
(setq %stack '()) ;; so it can be GC'ed
(wm "maxsize" .stackvue 1000 1000)
(tk-setq .stackvue.f.list "-state" "disabled"))
(defun run-inspect ()
;; Load inspect if necessary
(require "inspect-main")
(let ((obj '()))
(if (catch-errors (setq obj (selection "get")))
;; No selection available. Open a popup to say that
(make-dialog "-title" "Information"
"-text" "Nothing is selected for inspection"
"-bitmap" "info"
"-default" 0
"-buttons" '((" Dismiss " (lambda () T))))
;; Inspect the content of selection
(inspect (read-from-string obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Misc
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar errorInfo "")
;; For now tkerror does nothing since Tcl_AddErrorInfo simulation is not
;; correct.
(defun tkerror (&rest message)
;; Important note: When a background error occurs, tk try to see if
;; tkerror is bound to something. This is achieved by calling tkerror
;; with an empty message. In this case, nothing is printed
(unless (null message)
(format *standard-error* "**** Tk error (~S) ~S~%" (car message) errorInfo)))

49
src/tk/help.lsp
View file

@ -1,49 +0,0 @@
;;;;
;;;; Help management
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Sep-1993 13:30
;;;; Last file update: 27-Apr-1994 09:36
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(provide "help")
(require "editor")
(defun make-help (STF)
(catch-errors (destroy ".help"))
(toplevel ".help")
(wm "title" .help "ECL help")
(wm "maxsize" .help 800 800)
; Create a dismiss button
(button ".help.b" "-text" "Dismiss" "-command" '(destroy .help))
; Create a text widget with the content of list
(frame ".help.f" "-relief" "sunken" "-bd" 2)
(pack (scrollbar ".help.f.sb"
"-orient" "vertical" "-command" ".help.f.t \"yview\"")
"-side" "left" "-fill" "y")
(pack (text ".help.f.t"
"-relief" "raised" "-bd" 2 "-padx" 12 "-pady" 12
"-height" 18 "-wrap" "word" "-yscroll" ".help.f.sb \"set\"")
"-fill" "both" "-expand" T)
(set-STF .help.f.t STF)
; Set the text read only
(tk-setq .help.f.t "-state" "disabled")
(pack .help.b "-side" "bottom" "-fill" "x" "-padx" 4 "-pady" 2)
(pack .help.f "-fill" "both" "-expand" T "-padx" 4 "-pady" 2))

84
src/tk/init.lsp
View file

@ -1,84 +0,0 @@
;;;;
;;;; i n i t . l s p -- The file launched at startup
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;; Creation date: ??-Sep-1993 ??:??
;;;; Last file update: 12-Feb-1995 12:00
;;;;
(defvar @undefined (if NIL T))
(defvar *argc* (length *argv*))
(defvar ! system)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Misc
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun widget? (obj)
(and (tk-command? obj) (not (catch (obj "configure")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Autoloads
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(autoload "unix" basename dirname decompose-file-name)
(autoload "process" run-process process?)
(autoload "regexp" string->regexp regexp? regexp-replace regexp-replace-all)
;; martine packages
(autoload "pp" pp)
(autoload "trace" tracef)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; A set of binding to allow building of image files which contain the
;;;; STklos-Tk classes.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar Tk:button NIL)
(defvar Tk:checkbutton NIL)
(defvar Tk:canvas NIL)
(defvar Tk:entry NIL)
(defvar Tk:frame NIL)
(defvar Tk:label NIL)
(defvar Tk:listbox NIL)
(defvar Tk:menu NIL)
(defvar Tk:menubutton NIL)
(defvar Tk:message NIL)
(defvar Tk:scale NIL)
(defvar Tk:scrollbar NIL)
(defvar Tk:radiobutton NIL)
(defvar Tk:toplevel NIL)
(defvar Tk:after NIL)
(defvar Tk:bind NIL)
(defvar Tk:destroy NIL)
(defvar Tk:focus NIL)
(defvar Tk:grab NIL)
(defvar Tk:lower NIL)
(defvar Tk:option NIL)
(defvar Tk:pack NIL)
(defvar Tk:place NIL)
(defvar Tk:raise NIL)
(defvar Tk:selection NIL)
(defvar Tk:tk NIL)
(defvar Tk:tkwait NIL)
(defvar Tk:update NIL)
(defvar Tk:winfo NIL)
(defvar Tk:wm NIL)

531
src/tk/insp-detail.lsp
View file

@ -1,531 +0,0 @@
;******************************************************************************
;
; Project : STk-inspect, a graphical debugger for STk.
;
; File name : inspect-detail.stk
; Creation date : Aug-30-1993
; Last update : Sep-17-1993
;
;******************************************************************************
;
; This file implements the different kinds of "Detailers".
;
;******************************************************************************
(in-package "TK")
(provide "inspect-detail")
;---- detailer widget
(define DETAILER_WIDGET_NAME ".detailer")
(define detailed-objects-list ())
(defun detail-tl-wid (obj) (widget DETAILER_WIDGET_NAME (object-symbol obj)))
(defun detail-tl-str (obj) (& DETAILER_WIDGET_NAME (object-symbol obj)))
(defun detail-l-wid (obj) (widget (detail-tl-str obj) ".f1.l"))
(defun detail-l-str (obj) (& (detail-tl-str obj) ".f1.l"))
(defun detail-e-wid (obj) (widget (detail-tl-str obj) ".f1.e"))
(defun detail-e-str (obj) (& (detail-tl-str obj) ".f1.e"))
(defun detail-m-wid (obj) (widget (detail-tl-str obj) ".menu.command.m"))
(defun detail-m-str (obj) (& (detail-tl-str obj) ".menu.command.m"))
(defun detailed? (obj) (member obj detailed-objects-list))
(defun detail (obj)
(if (member (inspect::typeof (inspect::eval obj))
'(list pair vector closure widget))
(unless (detailed? obj) (detail-object obj))
(error "The object ~s can not be detailed" obj)))
(defun detail-object (obj)
(setq detailed-objects-list (cons obj detailed-objects-list))
(unless (object-infos obj)
(add-object-infos obj)
(if (symbolp obj) (trace-var obj `(update-object ',obj))))
(let ((obj-val (inspect::eval obj)))
(case (inspect::typeof obj-val)
((list pair vector) (detail-VPL obj))
((closure) (detail-procedure obj))
((widget) (when (= (winfo "exists" (detail-tl-wid obj-val)) 0)
(detail-widget obj))))))
(defun undetail (obj)
(if (detailed? obj) (undetail-object obj)))
(defun undetail-object (obj)
(let ((top (detail-tl-wid obj)))
(setq detailed-objects-list (list-remove obj detailed-objects-list))
(if (inspected? obj) ((inspect-m-wid obj) "enable" "Detail"))
(if (viewed? obj) ((view-m-wid obj) "enable" "Detail"))
(unless (or (inspected? obj) (viewed? obj))
(remove-object-infos obj)
(if (symbolp obj) (untrace-var obj)))
;; If toplevel exists (i.e. it is not a <Destroy> event) destroy it
(if (= (winfo "exists" top) 1)
(destroy top))))
(defun detail-display (obj)
(case (inspect::typeof (inspect::eval obj))
((vector pair list) (detail-VPL-display obj))
((closure) (detail-procedure-display obj))
((widget) (detail-widget-display obj))))
;---- Detailer menu -----------------------------------------------------------
(defun detail-menu-Eval (entry obj)
(eval-string (format NIL "(setq ~a ~a)" obj (entry "get"))))
(defun detail-menu-Quote (entry obj)
(eval-string (format NIL "(setq ~a '~a)" obj (entry "get"))))
(defun detail-menu-Inspect (key)
(let ((obj (find-object-infos key)))
(inspect obj)
((widget (detail-tl-str obj) ".menu.command.m") "disable" "Inspect")
(if (viewed? obj) ((view-w-wid obj) "disable" "Inspect"))))
(defun detail-menu-Undetail (key) (undetail (find-object-infos key)))
(defun detail-menu-View (key)
(let ((obj (find-object-infos key)))
(view obj)
((widget (detail-tl-str obj) ".menu.command.m") "disable" "View")
(if (inspected? obj) ((inspect-m-wid obj) "disable" "View"))))
;---- VPL menu ----------------------------------------------------------------
(defun get-VPL-index (obj)
(let ((s (tk-get (VPL-l-wid obj) "-text")))
(string->number (substring s 6 (string-length s)))))
(defun get-VPL-value (obj) ((VPL-e-wid obj) "get"))
(defun set-VPL-index&value (obj index)
(tk-setq (VPL-l-wid obj) "-text" (& "Value " index))
(let ((value-w (VPL-e-wid obj)))
(value-w "delete" 0 "end")
(value-w "insert" 0 (->object ((VPL-vlb-wid obj) "get" index)))))
(defun VPL-menu-Eval (obj)
(define index (get-VPL-index obj))
((VPL-vlb-wid obj) "delete" index)
((VPL-vlb-wid obj) "insert" index
(->object (eval-string (get-VPL-value obj))))
(modify-VPL obj))
(defun VPL-menu-Quote (obj)
(define index (get-VPL-index obj))
((VPL-vlb-wid obj) "delete" index)
((VPL-vlb-wid obj) "insert" index (get-VPL-value obj))
(modify-VPL obj))
;---- VPL detailer ------------------------------------------------------------
(defun VPL-l-wid (obj) (widget (detail-tl-str obj) ".value.l"))
(defun VPL-l-str (obj) (& (detail-tl-str obj) ".value.l"))
(defun VPL-e-wid (obj) (widget (detail-tl-str obj) ".value.e"))
(defun VPL-e-str (obj) (& (detail-tl-str obj) ".value.e"))
(defun VPL-ilb-wid (obj) (widget (detail-tl-str obj) ".list.lb1"))
(defun VPL-ilb-str (obj) (& (detail-tl-str obj) ".list.lb1"))
(defun VPL-vlb-wid (obj) (widget (detail-tl-str obj) ".list.lb2"))
(defun VPL-vlb-str (obj) (& (detail-tl-str obj) ".list.lb2"))
(defun create-detail-toplevel-widget (obj)
(define w (create-toplevel-widget (detail-tl-str obj)))
(define id-w (widget w ".id"))
(define menu-w (widget w ".menu"))
(set-id-label1 id-w "Object" 6)
(set-id-label2 id-w "Value" 6)
((widget menu-w ".help.m") "add" "command" "-label" "Detailer"
"-command" "(make-help Detailer-help)")
(pack (menubutton (& menu-w ".command") "-text" "Command") "-side" "left")
(define cmd-w (eval (menu (& menu-w ".command.m"))))
(tk-setq (widget menu-w ".command") "-menu" cmd-w)
(cmd-w "add" "command" "-label" "Inspect"
"-command" `(detail-menu-Inspect ',(object-symbol obj)))
(if (inspected? obj) (cmd-w "disable" "Inspect"))
(cmd-w "add" "command" "-label" "Undetail"
"-command" `(detail-menu-Undetail ',(object-symbol obj)))
(cmd-w "add" "command" "-label" "View"
"-command" `(detail-menu-View ',(object-symbol obj)))
(if (viewed? obj) (cmd-w "disable" "View"))
(if (modifiable-object? obj)
(begin
(bind (widget w ".id.f2.e") "<Return>"
`(detail-menu-Eval %W ',obj))
(bind (widget w ".id.f2.e") "<Shift-Return>"
`(detail-menu-Quote %W ',obj)))
(begin
(set-id-value id-w (format NIL "~S" (inspect::eval obj)))
(inspect::shadow-entry (widget w ".id.f2.e"))))
(bind w "<Destroy>" `(detail-menu-Undetail ',obj))
w)
(defun detail-VPL (obj)
(define w (create-detail-toplevel-widget obj))
((widget w ".menu.help.m") "add" "command")
(tk-setq (widget w ".id.f1.l2") "-width" 20)
(wm "maxsize" w SCREEN_WIDTH SCREEN_HEIGHT)
(pack (frame (& w ".value")) "-side" "top" "-fill" "x" "-padx" 4 "-pady" 2)
(pack (label (& w ".value.l") "-text" "Value 0") "-side" "left")
(pack (entry (& w ".value.e") "-relief" "sunken" "-bd" 2) "-fill" "x")
(pack (frame (& w ".list") "-relief" "sunken" "-bd" 2)
"-fill" "both" "-expand" "yes" "-padx" 4 "-pady" 2)
(pack (scrollbar (& w ".list.vsb") "-orient" "vertical")
(listbox (& w ".list.lb1") "-relief" "raised" "-bd" 2 "-geometry" "4x8")
"-side" "left" "-fill" "y")
(pack (listbox (& w ".list.lb2") "-relief" "raised" "-bd" 2)
"-fill" "both" "-expand" "yes")
(tk-listbox-single-select (& w ".list.lb1") (& w ".list.lb2"))
(if (modifiable-object? obj)
(begin
(bind (widget w ".value.e") "<Return>" `(VPL-menu-Eval ',obj))
(bind (widget w ".value.e") "<Shift-Return>" `(VPL-menu-Quote ',obj)))
(inspect::shadow-entry (widget w ".value.e")))
(bind (widget w ".list.lb1") "<Button-1>" `(VPL-select ',obj %y))
(bind (widget w ".list.lb2") "<Button-1>" `(VPL-select ',obj %y))
(tk-setq (widget w ".list.vsb") "-command" (& "scroll-VPL " w))
(tk-setq (widget w ".list.lb2") "-yscroll" (& w ".list.vsb \"set\""))
(detail-VPL-display obj))
(defun VPL-select (obj y)
(let ((index-w (VPL-ilb-wid obj))
(value-w (VPL-vlb-wid obj))
(entry-w (VPL-e-wid obj))
(index ()))
(value-w "select" "from" (value-w "nearest" y))
(setq index (value-w "curselection"))
(tk-setq (VPL-l-wid obj) "-text" (& "Value " index))
(let ((state (tk-get entry-w "-state")))
(tk-setq entry-w "-state" "normal")
(entry-w "delete" 0 "end")
(entry-w "insert" 0 (->object (value-w "get" index)))
(tk-setq entry-w "-state" state))
(focus entry-w)))
(defun scroll-VPL (w x &rest param)
((widget w ".list.lb1") "yview" x)
((widget w ".list.lb2") "yview" x))
(defun select-VPL-value (w index)
(let ((index-l (widget w ".value.l"))
(value-e (widget w ".value.e")))
(tk-setq index-l "-text" index)
(value-e "delete" 0 "end")
(value-e "insert" 0 (->object ((widget w ".list.lb2") "get" index)))
(focus value-e)))
;---- VPL display
(defun detail-VPL-display (obj)
(define id-w (& (detail-tl-str obj) ".id"))
(set-id-object id-w (->object obj))
(set-id-value id-w (->object (inspect::eval obj)))
(case (inspect::typeof (inspect::eval obj))
((list) (detail-VPL-display-list obj))
((pair) (detail-VPL-display-pair obj))
((vector) (detail-VPL-display-vector obj)))
(let ((index (get-VPL-index obj)))
(if (< index ((VPL-ilb-wid obj) "size"))
(set-VPL-index&value obj index)
(set-VPL-index&value obj 0))))
(defun detail-VPL-display-list (obj)
(define w (detail-tl-wid obj))
(wm "title" w "List detailer")
((widget w ".menu.help.m") "entryconfig" 2 "-label" "List detailer"
"-command" "(make-help List-detailer-help)")
(let ((obj-val (inspect::eval obj))
(index-w (VPL-ilb-wid obj))
(value-w (VPL-vlb-wid obj))
(index 0))
(index-w "delete" 0 "end")
(value-w "delete" 0 "end")
(until (null obj-val)
(index-w "insert" "end" index)
(value-w "insert" "end" (->object (car obj-val)))
(setq obj-val (cdr obj-val))
(setq index (+ index 1)))))
(defun detail-VPL-display-pair (obj)
(define w (detail-tl-wid obj))
(wm "title" w "Pair detailer")
((widget w ".menu.help.m") "entryconfig" 2 "-label" "Pair detailer"
"-command" "(make-help Pair-detailer-help)")
(let ((obj-val (inspect::eval obj))
(index-w (VPL-ilb-wid obj))
(value-w (VPL-vlb-wid obj))
(index 0))
(index-w "delete" 0 "end")
(value-w "delete" 0 "end")
(while (pair? obj-val)
(index-w "insert" "end" index)
(value-w "insert" "end" (->object (car obj-val)))
(setq obj-val (cdr obj-val))
(setq index (+ index 1)))
(index-w "insert" "end" (& "." index))
(value-w "insert" "end" (->object obj-val))))
(defun detail-VPL-display-vector (obj)
(define w (detail-tl-wid obj))
(wm "title" w "Vector detailer")
((widget w ".menu.help.m") "entryconfig" 2 "-label" "Vector detailer"
"-command" "(make-help Vector-detailer-help)")
(let* ((obj-val (inspect::eval obj))
(length (vector-length obj-val))
(index-w (VPL-ilb-wid obj))
(value-w (VPL-vlb-wid obj)))
(index-w "delete" 0 "end")
(value-w "delete" 0 "end")
(for ((index 0 (+ index 1)))
(< index length)
(index-w "insert" "end" index)
(value-w "insert" "end" (->object (vector-ref obj-val index))))))
;---- VPL modify
(defun modify-VPL (obj)
(case (inspect::typeof (inspect::eval obj))
((list) (modify-VPL-list obj))
((pair) (modify-VPL-pair obj))
((vector) (modify-VPL-vector obj))))
(defun modify-VPL-list (obj)
(let* ((value-w (VPL-vlb-wid obj))
(cmd (format NIL "(setq ~S '(" obj))
(size (value-w "size")))
(for ((i 0 (+ i 1)))
(< i size)
(setq cmd (string-append cmd (->object (value-w "get" i)) " ")))
(setq cmd (string-append cmd "))"))
(eval-string cmd)))
(defun modify-VPL-pair (obj)
(let* ((value-w (VPL-vlb-wid obj))
(cmd (format NIL "(setq ~S '(" obj))
(size (value-w "size"))
(size-1 (- size 1)))
(for ((i 0 (+ i 1)))
(< i size-1)
(setq cmd (string-append cmd (->object (value-w "get" i)) " ")))
(setq cmd (string-append cmd ". " (->object (value-w "get" size-1)) "))"))
(eval-string cmd)))
(defun modify-VPL-vector (obj)
(let* ((value-w (VPL-vlb-wid obj))
(cmd (format NIL "(setq ~S '#(" obj))
(size (value-w "size")))
(for ((i 0 (+ i 1)))
(< i size)
(setq cmd (string-append cmd (->object (value-w "get" i)) " ")))
(setq cmd (string-append cmd "))"))
(eval-string cmd)))
;---- Procedure detailer ------------------------------------------------------
(defun inspect::pretty-print (body) (pp (uncode body) NIL))
(defun detail-procedure-set (obj)
(define text-w (widget (detail-tl-str obj) ".body.t"))
(eval-string (format NIL "(setq ~a ~a)" obj (text-w "get" "1.0" "end"))))
(defun detail-procedure (obj)
(define w (create-detail-toplevel-widget obj))
(wm "title" w "Procedure detailer")
(wm "maxsize" w SCREEN_WIDTH SCREEN_HEIGHT)
((widget w ".menu.help.m") "add" "command" "-label" "Procedure detailer"
"-command" "(make-help Procedure-detailer-help)")
(pack (label (& w ".menu.set") "-text" "Set") "-side" "left")
(bind (widget w ".menu.set") "<ButtonPress-1>" `(detail-procedure-set ',obj))
(pack (frame (& w ".body") "-relief" "sunken" "-bd" 2)
"-fill" "both" "-expand" "yes" "-padx" 4 "-pady" 2)
(pack (scrollbar (& w ".body.vsb")
"-orient" "vertical"
"-command" (format NIL "~a \"yview\"" (& w ".body.t")))
"-side" "left" "-fill" "y")
(pack (text (& w ".body.t")
"-relief" "raised" "-bd" 2 "-width" 60 "-height" 16
"-yscroll" (format NIL "~a \"set\"" (& w ".body.vsb")))
"-fill" "both" "-expand" "yes")
(detail-procedure-display obj))
(defun detail-procedure-display (obj)
(define obj-val (inspect::eval obj))
(define id-w (& (detail-tl-str obj) ".id"))
(set-id-object id-w (->object obj))
(set-id-value id-w (->object obj-val))
(define body (procedure-body obj-val))
(define text-w (widget (detail-tl-str obj) ".body.t"))
(tk-setq text-w "-state" "normal")
(text-w "delete" "1.0" "end")
(text-w "insert" "1.0" (inspect::pretty-print body))
(unless (symbolp obj)
(inspect::shadow-entry text-w)))
;---- Widget detailer ---------------------------------------------------------
(defun detail-widget (obj)
(define w (create-detail-toplevel-widget obj))
(wm "title" w "Widget detailer")
(tk-setq (widget w ".id.f1.l2") "-width" 40)
((widget w ".menu.help.m") "add" "command" "-label" "Widget detailer"
"-command" "(make-help Widget-detailer-help)")
(pack (menubutton (& w ".menu.bindings") "-text" "Bindings") "-side" "left")
(tk-setq (widget w ".menu.bindings") "-menu" (menu (& w ".menu.bindings.m")))
(detail-widget-create-options obj)
(detail-widget-display obj))
(defun detail-widget-create-options (obj)
(define w-str (detail-tl-str obj))
(catch-errors (destroy (& w-str ".options")))
(pack (frame (& w-str ".options") "-relief" "raised" "-bd" 2)
"-fill" "both" "-expand" "yes" "-padx" 4 "-pady" 2)
(pack (frame (& w-str ".options.class"))
"-side" "top" "-fill" "x" "-padx" 4 "-pady" 4)
(pack (label (& w-str ".options.class.l1")
"-text" "Class" "-width" 16 "-anchor" "e")
"-side" "left")
(pack (label (& w-str ".options.class.l2")
"-relief" "groove" "-bd" 2 "-anchor" "w" "-font" ITALIC-MEDIUM_FONT)
"-fill" "x")
(let ((options-infos ((eval obj) "config"))
(i 1))
(for-each
(lambda (infos)
(if (= 5 (length infos))
(let ((option-w (& w-str ".options.f" i))
(s (symbol->string (car infos))))
(pack (frame option-w) "-side" "top" "-fill" "x" "-padx" 4)
(pack (label (& option-w ".l")
"-text" (substring s 1 (string-length s))
"-width" 16 "-anchor" "e")
"-side" "left")
(pack (entry (& option-w ".e") "-relief" "sunken" "-bd" 2) "-fill" "x")
(bind (& option-w ".e") "<Return>" `(WID-eval-option ',obj %W))
(bind (& option-w ".e") "<Shift-Return>"`(WID-quote-option ',obj %W))
(setq i (+ i 1)))))
options-infos))
(pack (frame (& w-str ".options.children"))
"-side" "top" "-fill" "x" "-padx" 4 "-pady" 4)
(pack (label (& w-str ".options.children.1")
"-text" "Children" "-width" 16 "-anchor" "e")
"-side" "left")
(pack (entry (& w-str ".options.children.e")
"-relief" "groove" "-bd" 2 "-state" "disabled" "-font" MEDIUM_FONT)
"-fill" "x")
(update "idletasks")
(define req-h (winfo "reqheight" w-str))
(wm "minsize" w-str 0 req-h)
(wm "maxsize" w-str SCREEN_WIDTH req-h))
(defun WID-bindings-menu-str (obj) (& (detail-tl-str obj) ".menu.bindings.m"))
(defun WID-bindings-menu-wid (obj)
(widget (detail-tl-str obj) ".menu.bindings.m"))
(defun binding->string (binding)
(let ((binding (if (string? binding) binding (symbol->string binding))))
(substring binding 1 (- (string-length binding) 1))))
(defun WID-bindings-menu-add (obj binding)
(if (catch-errors ((WID-bindings-menu-wid obj) "index" binding))
((WID-bindings-menu-wid obj) "add" "command"
"-label" (symbol->string binding)
"-command" `(show-binding ',(object-symbol obj)
,(symbol->string binding)))))
(defun show-binding (key binding)
(let* ((obj (find-object-infos key))
(obj-val (inspect::eval obj))
(name (string-lower (binding->string binding)))
(body (bind obj-val binding)))
(if (null body) (setq body (bind (winfo "class" obj-val) binding)))
((WID-bindings-menu-wid obj) "disable" binding)
(define w (& (detail-tl-str obj) "._" name))
(create-toplevel-widget w)
(wm "title" w "Widget binding")
(wm "maxsize" w SCREEN_WIDTH SCREEN_HEIGHT)
(set-id-label1 (& w ".id") "Widget" 6)
(set-id-object (& w ".id") (->object obj))
(set-id-label2 (& w ".id") "Binding" 6)
(set-id-value (& w ".id") binding)
(inspect::shadow-entry (string->widget (& w ".id.f2.e")))
(pack (button (& w ".menu.dismiss")
"-text" "Dismiss"
"-relief" "flat"
"-command" `(progn
((WID-bindings-menu-wid ,obj-val)
"enable" ',binding)
(destroy ,w)))
"-side" "left")
(pack (button (& w ".menu.set")
"-text" "Set binding"
"-relief" "flat"
"-command" `(bind ,obj-val ,binding ((widget ,w ".body.t")
"get" "1.0" "end")))
"-side" "left")
(pack (frame (& w ".body") "-relief" "sunken" "-bd" 2)
"-fill" "both" "-expand" "yes" "-padx" 4 "-pady" 2)
(pack (scrollbar (& w ".body.vsb") "-orient" "vertical")
"-side" "left" "-fill" "y")
(pack (text (& w ".body.t") "-relief" "raised" "-bd" 2 "-width" 60 "-height" 8)
"-fill" "both" "-expand" "yes")
((widget w ".body.t") "insert" "1.0" (inspect::pretty-print body))))
(defun detail-widget-display (obj)
(define obj-val (inspect::eval obj))
(define w-str (detail-tl-str obj))
(define id-w (widget w-str ".id"))
(set-id-object id-w (->object obj))
(set-id-value id-w (->object obj-val))
(tk-setq (widget w-str ".options.class.l2") "-text" (winfo "class" obj-val))
(define children-w (widget w-str ".options.children.e"))
(tk-setq children-w "-state" "normal")
(children-w "delete" 0 "end")
(children-w "insert" 0 (winfo "children" obj-val))
(tk-setq children-w "-state" "disabled")
(let ((options-infos (obj-val "config"))
(i 1))
(for-each
(lambda (infos)
(if (= 5 (length infos))
(let ((option-w (widget w-str ".options.f" i ".e")))
(option-w "delete" 0 "end")
(option-w "insert" 0 (nth 4 infos))
(setq i (+ i 1)))))
options-infos))
(define menu-w (WID-bindings-menu-wid obj))
(menu-w "delete" 0 "last")
(for-each (lambda (binding) (WID-bindings-menu-add obj binding))
(bind obj-val))
(menu-w "add" "separator")
(for-each (lambda (binding) (WID-bindings-menu-add obj binding))
(bind (winfo "class" obj-val))))
(defun WID-eval-option (obj window)
(let ((parent (winfo "parent" window)))
(eval-string
(format NIL "(tk-setq ~a "-~a" ~s)"
obj
(tk-get (widget parent ".l") "-text")
(eval-string (window "get"))))))
(defun WID-quote-option (obj window)
(let ((parent (winfo "parent" window)))
(eval-string
(format NIL "(tk-setq ~a "-~a" ~s)"
obj
(tk-get (widget parent ".l") "-text")
(window "get")))))

358
src/tk/insp-help.lsp
View file

@ -1,358 +0,0 @@
;******************************************************************************
;
; Project : STk-inspect, a graphical debugger for STk
;
; File name : inspect-help.stk
; Creation date : Sep-16-1993
; Last update : Sep-17-1993
;
;******************************************************************************
;
; This file contains help variables.
;
;******************************************************************************
(in-package "TK")
(provide "inspect-help")
(define STk-inspect-help '("STF-0.1" "
STk-inspect\n\n
STk-inspect is a graphical inspector for STk (the Scheme/Tk based language).
It is the firt step toward a more general debugger . For now, it only permits to visualize and modify STk objects.
Original code written by Eric Fintzel (fintzel@kaolin.unice.fr)
Hacked for version 2 by Erick Gallesio (eg@unice.fr)
" ((bold-italic-12 ("5.0" "5.11" "5.41" "5.44")) (roman-18 ("2.0" "2.11")) (fixed ("9.39" "9.62" "10.40" "10.51")) (normal ("2.11" "5.0")))))
;---- Help for (inspect,help) "General inspector"
(define General-Inspector-help '("STF-0.1" "
General inspector
The General inspector is the simplest tool to trace STk objects. It allows you to watch and modify every kind of object.
To inspect an object
You can use the STk
(inspect object)
command. For instance, if you want to inspect the variable my-variable, just type:
STk> (inspect 'my-variable)
You can also select the Inspect option in an other STk-inspect tool (detailer, viewer,...).
To uninspect an object
You can use the STk
(uninspect object)
command, or you can select the Uninspect option in the Icon menu associated with the object line inspector.
Screen organization
The General inspector is a toplevel window divided in 2 areas: a menu bar and a list of all inspected objects.
Menu area
Menu area comports two buttons:
Command menu
The Uninspect all option uninspects all inspected objects and destroy the General inspector window.
The Undebug option destroys all the STk-inspect toplevel windows.
Help menu
The STk-inspect option gives a general help about STk-inspect.
The General inspector option gives this help.
Inspected objects area
Each line of the list concerns one object, a line is divided in 3 fields:
The Object field contains the inspected object.
The Value field contains the value of the object (the result of the object evaluation). You can modify the object by editing this field. A <Return> validation affects to the object the result of the field contents evaluation, while a <Shift-Return> validation affects to the object the field contents without evaluation.
The Icon provides actions on the object.
" ((bold-italic-12 ("7.0" "7.20" "18.0" "18.22" "26.0" "26.19" "38.13" "38.24")) (italic-12 ("16.69" "16.89" "24.31" "24.40" "28.65" "28.73" "28.80" "28.84" "33.9" "34.0" "34.13" "34.26" "35.13" "35.20" "37.9" "38.0" "39.13" "39.30" "44.12" "44.19" "46.12" "46.18" "48.12" "48.16")) (roman-18 ("2.0" "2.17")) (roman-12 ("7.20" "8.0" "30.0" "30.9" "41.0" "41.22")) (fixed ("11.8" "11.24" "13.59" "13.70" "14.10" "14.37" "22.8" "22.26" "46.147" "46.155" "46.242" "46.257")) (underline ("2.0" "3.0" "7.0" "7.20" "18.0" "18.22" "26.0" "26.19" "33.9" "34.0" "37.9" "38.0")))))
;---- Help for (detail,help) "Detailer"
(define Detailer-help '("STF-0.1" "
Detailer
A detailer is a STk-inspect tool which allows you to see STk objects with more details.
For instance, a list detailer shows you the structure of a list where you can edit each element of the list; a procedure detailer permits you to edit the body of a procedure; a widget detailer allows you to access directly the whole option fields of a widget; and so on...
For now, there are detailers for lists, pairs vectors, procedures and widgets.
To detail an object
You can use the STk
(detail object)
command. For example, if you want to detail the list my-list, type:
STk> (detail my-list)
You can also select the Detail option in an other STk-inspect tool (inspector, viewer, ...).
To undetail an object
You can use the STk
(undetail object)
command or you can select the Undetail option in the Command menu of the object detailer window.
" ((bold-italic-12 ("10.0" "10.19" "22.0" "22.21")) (italic-12 ("6.16" "6.29" "6.111" "6.130" "6.177" "6.192" "8.33" "8.77" "16.53" "16.60" "20.24" "20.30" "20.68" "20.77" "20.79" "20.90" "22.21" "23.0" "28.30" "28.38" "28.53" "28.65")) (roman-18 ("2.0" "2.8")) (fixed ("14.8" "14.23" "18.8" "19.0" "26.8" "26.25")) (underline ("2.0" "2.8" "10.0" "10.19" "22.0" "23.0")))))
;---- Help for (detail,help) "List detailer"
(define List-detailer-help '("STF-0.1" "
List detailer
A list detailer is a STk-inspect tool which shows you the structure of a list.
The list detailer window is divided in 3 areas:
the Id area, a menu bar and the elements list.
Id area
This area identifies the list you detail, it contains 2 fields:
The object field contains the object detailed.
The Value field contains the value of the object (a list resulting of the object evaluation). You can modify the object by editing this field. A <Return> validation affects to the object the result of the field contents evaluation, while a <Shift-Return> validation affects to the object the field contents without evaluation.
After a modification, if the object type is no more a list, the detailer is adapted.
Menu bar
Two sub-menus are provided:
Command menu
The Inspect option calls the General inspector for the detailed object.
The Undetail option destroys the list detailer window.
The View option calls the Viewer for the detailed object.
Help menu
The STk-inspect option gives a general help about STk-inspect.
The Detailer option gives a general help about detailers tools.
The List detailer option gives this help.
Elements list
This area displays all the elements of the detailed list (with indexes). You can select a particular element with mouse button 1, its value will appear on the Value <index> entry, and you can modify it (validation of your entry can be done using the current way: <Return> and <Shift-Return>)).
" ((tty-12 ("16.154" "16.162" "16.249" "16.264" "37.160" "37.174" "37.264" "37.272" "37.277" "37.292")) (bold-italic-12 ("10.0" "10.7" "21.0" "22.0" "35.0" "35.13")) (italic-12 ("8.4" "8.11" "8.15" "8.24" "8.32" "8.45" "14.12" "14.18" "16.12" "16.17" "25.8" "25.20" "26.12" "26.21" "27.12" "27.20" "28.12" "28.16" "30.8" "31.0" "31.12" "31.23" "32.12" "32.20" "33.12" "33.25")) (roman-18 ("2.0" "2.13")) (underline ("2.0" "2.13" "10.0" "10.7" "21.0" "22.0" "25.8" "25.20" "30.8" "31.0" "35.0" "35.13")))))
;---- Help for (detail,help) "Pair detailer"
(define Pair-detailer-help '("STF-0.1" "
Pair detailer
A pair detailer is a STk-inspect tool which shows you the structure of a pair.
The pair detailer window is divided in 3 areas:
the Id area, a menu bar and the elements list.
Id area
This area identifies the pair you detail, it contains 2 fields:
The object field contains the object detailed.
The Value field contains the value of the object (a pair resulting of the object evaluation). You can modify the object by editing this field. A <Return> validation affects to the object the result of the field contents evaluation, while a <Shift-Return> validation affects to the object the field contents without evaluation.
After a modification, if the object type is no more a pair, the detailer is adapted.
Menu bar
Two sub-menus are provided:
Command menu
The Inspect option calls the General inspector for the detailed object.
The Undetail option destroys the pair detailer window.
The View option calls the Viewer for the detailed object.
Help menu
The STk-inspect option gives a general help about STk-inspect.
The Detailer option gives a general help about detailers tools.
The List detailer option gives this help.
Elements list
This area displays all the elements of the detailed list (with indexes). Note that the last element has a pointed index. You can select a particular element with mouse button 1, its value will appear on the Value <index> entry, and you can modify it (validation of your entry can be done using the current way: <Return> and <Shift-Return>)).
" ((tty-12 ("16.154" "16.162" "16.249" "16.264" "37.207" "37.221" "37.311" "37.319" "37.324" "37.339")) (bold-italic-12 ("10.0" "10.7" "21.0" "22.0" "35.0" "35.13")) (italic-12 ("8.4" "8.11" "8.15" "8.24" "8.32" "8.45" "14.12" "14.18" "16.12" "16.17" "25.8" "25.20" "26.12" "26.21" "27.12" "27.20" "28.12" "28.16" "30.8" "31.0" "31.12" "31.23" "32.12" "32.20" "33.12" "33.25")) (roman-18 ("2.0" "2.13")) (underline ("2.0" "2.13" "10.0" "10.7" "21.0" "22.0" "25.8" "25.20" "30.8" "31.0" "35.0" "35.13"))))
)
;---- Help for (detail,help) "Vector detailer"
(define Vector-detailer-help '("STF-0.1" "
Vector detailer
A vector detailer is a STk-inspect tool which shows you the structure of a vector.
The vector detailer window is divided in 3 areas:
the Id area, a menu bar and the elements list.
Id area
This area identifies the vector you detail, it contains 2 fields:
The object field contains the object detailed.
The Value field contains the value of the object (a vector resulting of the object evaluation). You can modify the object by editing this field. A <Return> validation affects to the object the result of the field contents evaluation, while a <Shift-Return> validation affects to the object the field contents without evaluation.
After a modification, if the object type is no more a vector, the detailer is adapted.
Menu bar
Two sub-menus are provided:
Command menu
The Inspect option calls the General inspector for the detailed object.
The Undetail option destroys the vector detailer window.
The View option calls the Viewer for the detailed object.
Help menu
The STk-inspect option gives a general help about STk-inspect.
The Detailer option gives a general help about detailers tools.
The List detailer option gives this help.
Elements list
This area displays all the elements of the detailed vector (with indexes). Note that the last element has a pointed index. You can select a particular element with mouse button 1, its value will appear on the Value <index> entry, and you can modify it (validation of your entry can be done using the current way: <Return> and <Shift-Return>)).
" ((tty-12 ("16.156" "16.164" "16.251" "16.266" "37.209" "37.223" "37.313" "37.321" "37.326" "37.341")) (bold-italic-12 ("10.0" "10.7" "21.0" "22.0" "35.0" "35.13")) (italic-12 ("8.4" "8.11" "8.15" "8.24" "8.32" "8.45" "14.12" "14.18" "16.12" "16.17" "25.8" "25.20" "26.12" "26.21" "27.12" "27.20" "28.12" "28.16" "30.8" "31.0" "31.12" "31.23" "32.12" "32.20" "33.12" "33.25")) (roman-18 ("2.0" "3.0")) (underline ("2.0" "3.0" "10.0" "10.7" "21.0" "22.0" "25.8" "25.20" "30.8" "31.0" "35.0" "35.13"))))
)
;---- Help for (detail,help) "Procedure detailer"
(define Procedure-detailer-help '("STF-0.1" "
Procedure detailer
A procedure detailer is a STk-inspect tool which allows you to see and edit the body of a procedure.
The procedure detailer window is divided in 3 areas:
the Id area, a menu bar and the body area.
Id area
This area identifies the procedure you detail, it contains 2 fields:
The object field contains the object detailed.
The Value field contains the value of the object (a procedure resulting of the object evaluation). You can modify the object by editing this field. A <Return> validation affects to the object the result of the field contents evaluation, while a <Shift-Return> validation affects to the object the field contents without evaluation.
After a modification, if the object type is no more a procedure, the detailer is adapted.
Menu bar
Two sub-menus are provided:
Command menu
The Inspect option calls the General inspector for the detailed object.
The Undetail option destroys the procedure detailer window.
The View option calls the Viewer for the detailed object.
Help menu
The STk-inspect option gives a general help about STk-inspect.
The Detailer option gives a general help about detailers tools.
The List detailer option gives this help.
Body area
This area displays the procedure body, and allows you to edit it." ((tty-12 ("16.156" "16.164" "16.251" "16.266")) (bold-italic-12 ("10.0" "10.7" "21.0" "22.0" "35.0" "37.0")) (italic-12 ("8.4" "8.11" "8.15" "8.24" "8.32" "8.41" "14.12" "14.18" "16.12" "16.17" "25.8" "25.20" "26.12" "26.21" "27.12" "27.20" "28.12" "28.16" "30.8" "31.0" "31.12" "31.23" "32.12" "32.20" "33.12" "33.25")) (roman-18 ("2.0" "3.0")) (normal ("37.0" "37.65")) (underline ("2.0" "3.0" "10.0" "10.7" "21.0" "22.0" "25.8" "25.20" "30.8" "31.0" "35.0" "37.0"))))
)
;---- Help for (detail,help) "Widget detailer"
(define Widget-detailer-help '("STF-0.1" "
Widget detailer
A widget detailer is a STk-inspect tool which allows you to see and edit the characteristics of a widget.
The widget detailer window is divided in 3 areas:
the Id area, a menu bar and the option area.
Id area
This area identifies the widget you detail, it contains 2 fields:
The object field contains the object detailed.
The Value field contains the widget name of the object.
After a modification, if the object type is no more a widget, the detailer is adapted.
Menu bar
Three sub-menus are provided:
Command menu
The Inspect option calls the General inspector for the detailed object.
The Undetail option destroys the widget detailer window.
The View option calls the Viewer for the detailed object.
Bindings menu
This menu contains all the bindings associated with the widget (the widget bindings are listed before the widget class bindings). You can select a binding to edit it.
Help menu
The STk-inspect option gives a general help about STk-inspect.
The Detailer option gives a general help about detailers tools.
The Widget detailer option gives this help.
Option area
This area displays all the options of the detailed widget. You can edit an option using the current way <Return> and <Shift-Return>" ((tty-12 ("40.104" "40.113" "40.117" "40.131")) (bold-italic-12 ("10.0" "10.7" "21.0" "22.0" "38.0" "40.0")) (italic-12 ("8.4" "8.11" "8.15" "8.24" "8.32" "8.43" "14.12" "14.18" "16.12" "16.17" "25.8" "25.20" "26.12" "26.21" "27.12" "27.20" "28.12" "28.16" "30.8" "31.0" "33.8" "34.0" "34.12" "34.23" "35.12" "35.20" "36.12" "36.27")) (roman-18 ("2.0" "3.0")) (normal ("31.0" "33.0" "40.0" "40.104" "40.113" "40.117")) (underline ("2.0" "3.0" "10.0" "10.7" "21.0" "22.0" "25.8" "25.20" "30.8" "31.0" "33.8" "34.0" "38.0" "40.0"))))
)
;---- Help for (view,help) "Viewer"
(define Viewer-help '("STF-0.1" "
Viewer
A viewer is a STk-inspect tool which gives you a graphical representation of STk objects.
All object types can be viewed; particular viewer are provided for procedures and widgets.
To view an object
You can use the STk
(view object)
command. For example, if you want to view the list my-list, type:
(view 'my-list)
You can also select the View option in an other STk-inspect tool.
To unview an object
You can use the STk
(unview object)
command. Or you can select the Unview option in the Command menu of the object viewer window." ((tty-12 ("12.9" "13.0" "14.51" "14.59" "16.8" "17.0" "24.8" "24.24")) (bold-italic-12 ("8.0" "8.17" "20.0" "21.0")) (italic-12 ("6.67" "6.77" "6.82" "6.89" "18.24" "18.28" "26.31" "26.37" "26.52" "26.59")) (roman-18 ("2.0" "2.6")) (underline ("2.0" "2.6" "8.0" "8.17" "20.0" "21.0"))))
)

196
src/tk/insp-main.lsp
View file

@ -1,196 +0,0 @@
;******************************************************************************
;
; Project : STk-inspect, a graphical debugger for STk
;
; File name : inspect-main.stk
; Creation date : Aug-10-1993
; Last update : Sep-17-1993
;
; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;
;******************************************************************************
;
; This file implements the "General inspector".
;
;******************************************************************************
(in-package "TK")
(provide "inspect-main")
(require "inspect-misc")
(require "inspect-view")
(require "inspect-detail")
(require "inspect-help")
(defvar INSPECTOR_WIDGET_NAME ".inspector")
(defvar inspected-objects-list ())
(defun inspected? (obj) (member obj inspected-objects-list))
(defun inspect-frame-wid (obj)
(widget INSPECTOR_WIDGET_NAME ".f1." (object-symbol obj)))
(defun inspect-frame-str (obj)
(& INSPECTOR_WIDGET_NAME ".f1." (object-symbol obj)))
(defun inspect-l-wid (obj) (widget (inspect-frame-str obj) ".l"))
(defun inspect-l-str (obj) (& (inspect-frame-str obj) ".l"))
(defun inspect-e-wid (obj) (widget (inspect-frame-str obj) ".e"))
(defun inspect-e-str (obj) (& (inspect-frame-str obj) ".e"))
(defun inspect-mb-wid (obj) (widget (inspect-frame-str obj) ".mb"))
(defun inspect-mb-str (obj) (& (inspect-frame-str obj) ".mb"))
(defun inspect-m-str (obj) (& (inspect-frame-str obj) ".mb.m"))
(defun inspect-m-wid (obj) (widget (inspect-frame-str obj) ".mb.m"))
;---- Inspector menu
(defun create-inspect-menu (obj)
(let ((w (eval (menu (inspect-m-str obj)))))
(funcall w "add" "command" "-label" "Uninspect"
"-command" `(inspect-menu-Uninspect ',(object-symbol obj)))
(funcall w "add" "command" "-label" "Detail"
"-command" `(inspect-menu-Detail ',(object-symbol obj)))
(if (detailed? obj) ((inspect-m-wid obj) "disable" "Detail"))
(funcall w "add" "command" "-label" "View"
"-command" `(inspect-menu-View ',(object-symbol obj)))
(if (viewed? obj) ((inspect-m-wid obj) "disable" "View")))
)
(defun inspect-menu-Eval (obj)
(set obj (eval (funcall (inspect-e-wid obj) "get"))))
(defun inspect-menu-Quote (obj)
(set obj (funcall (inspect-e-wid obj) "get")))
(defun inspect-menu-Uninspect (key)
(uninspect (find-object-infos key)))
(defun inspect-menu-Detail (key)
(let ((obj (find-object-infos key)))
(detail obj)
(funcall (inspect-m-wid obj) "disable" "Detail")
(if (viewed? obj) (funcall (view-m-wid obj) "disable" "Detail"))))
(defun inspect-menu-View (key)
(let ((obj (find-object-infos key)))
(view obj)
(funcall (inspect-m-wid obj) "disable" "View")
(if (detailed? obj) (funcall (detail-m-wid obj) "disable" "View"))))
(defun create-inspector ()
(let ((w (toplevel INSPECTOR_WIDGET_NAME)))
(wm "title" w "General inspector")
(wm "maxsize" w SCREEN_WIDTH SCREEN_HEIGHT)
(define menu-w (create-menu-widget (& INSPECTOR_WIDGET_NAME ".menu")))
(pack menu-w "-side" "top" "-fill" "x" "-padx" 4 "-pady" 2)
(funcall (widget menu-w ".help.m") "add" "command" "-label" "General inspector"
"-command" "(make-help General-Inspector-help)")
(pack (menubutton (& INSPECTOR_WIDGET_NAME ".menu.command") "-text" "Command")
"-side" "left")
(define cmd-w (eval (menu (& INSPECTOR_WIDGET_NAME ".menu.command.m"))))
(cmd-w "add" "command" "-label" "Uninspect all"
"-command" "(destroy-inspector)")
(cmd-w "add" "command" "-label" "Undebug" "-command" "(undebug)")
(tk-setq (widget INSPECTOR_WIDGET_NAME ".menu.command") "-menu" cmd-w)
(pack (frame (& INSPECTOR_WIDGET_NAME ".caption"))
"-side" "top" "-fill" "x" "-padx" 4)
(pack (label (& INSPECTOR_WIDGET_NAME ".caption.l1")
"-text" "Objects" "-width" 20)
"-side" "left")
(pack (label (& INSPECTOR_WIDGET_NAME ".caption.l2")
"-text" "Values" "-width" 40)
"-side" "left" "-padx" 4)
(pack (frame (& INSPECTOR_WIDGET_NAME ".f1"))
"-fill" "both" "-expand" "yes" "-padx" 4 "-pady" 2))
)
(defun destroy-inspector ()
(mapcar #'uninspect-object inspected-objects-list))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; inspect
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun inspect (obj)
(when (= (winfo "exist" INSPECTOR_WIDGET_NAME) 0) (create-inspector))
;; Kludge to avoid problems . Should be modified (eg)
(let ((obj-val (inspect::eval obj)))
(when (equal (inspect::typeof obj-val) "widget")
(setq obj obj-val)))
(unless (inspected? obj)
(inspect-object obj)
(let ((obj-val (format NIL "~S" (inspect::eval obj))))
(pack (frame (inspect-frame-str obj)) "-side" "top" "-fill" "x")
(pack (menubutton (inspect-mb-str obj)
"-relief" "raised" "-bd" 2 "-bitmap" BITMAP_MENU)
"-side" "right")
(pack (label (inspect-l-str obj) "-relief" "groove" "-bd" 2
"-anchor" "w" "-text" (format NIL "~S" obj)
"-width" 20 "-font" MEDIUM_FONT)
"-side" "left")
(pack (entry (inspect-e-str obj) "-relief" "sunken" "-bd" 2 "-width" 40)
"-fill" "x" "-expand" "yes" "-padx" 4)
(create-inspect-menu obj)
(tk-setq (inspect-mb-wid obj) "-menu" (inspect-m-wid obj))
(let ((E (inspect-e-wid obj)))
(E "insert" 0 obj-val)
;; If obj is a symbol, lets the entry modifiable. Otherwise let it as is
(if (modifiable-object? obj)
(begin
(bind E "<Return>" `(inspect-menu-Eval ',obj))
(bind E "<Shift-Return>" `(inspect-menu-Quote ',obj)))
(inspect::shadow-entry E)))))
;; Destroy Event -> set the list of inspected object to '()
(bind INSPECTOR_WIDGET_NAME "<Destroy>" '(setq inspected-objects-list '()))
;; Allow resizing only in width
(update "idletasks")
(let ((req-h (winfo "reqheight" INSPECTOR_WIDGET_NAME)))
(wm "minsize" INSPECTOR_WIDGET_NAME 0 req-h)
(wm "maxsize" INSPECTOR_WIDGET_NAME SCREEN_WIDTH req-h)
(wm "geometry" INSPECTOR_WIDGET_NAME
(& (winfo "width" INSPECTOR_WIDGET_NAME) "x" req-h))))
(defun inspect-object (obj)
(setq inspected-objects-list (cons obj inspected-objects-list))
(unless (object-infos obj)
(add-object-infos obj)
(if (symbolp obj) (trace-var obj `(update-object ',obj)))))
(defun inspect-display (obj)
(let ((entry-w (inspect-e-wid obj)))
(entry-w "delete" 0 "end")
(entry-w "insert" 0 (->object (eval obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; uninspect
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun uninspect (obj)
(when (inspected? obj) (uninspect-object obj))
(update "idletasks")
(when (= (winfo "exist" INSPECTOR_WIDGET_NAME) 1)
(let ((req-h (winfo "reqheight" INSPECTOR_WIDGET_NAME)))
(wm "minsize" INSPECTOR_WIDGET_NAME 0 req-h)
(wm "maxsize" INSPECTOR_WIDGET_NAME SCREEN_WIDTH req-h)
(wm "geometry" INSPECTOR_WIDGET_NAME
(& (winfo "width" INSPECTOR_WIDGET_NAME) "x" req-h)))))
(defun uninspect-object (obj)
(setq inspected-objects-list (list-remove obj inspected-objects-list))
(destroy (inspect-frame-wid obj))
(when (null inspected-objects-list) (destroy INSPECTOR_WIDGET_NAME))
(if (detailed? obj) (funcall (detail-m-wid obj) "enable" "Inspect"))
(if (viewed? obj) (funcall (view-m-wid obj) "enable" "Inspect"))
(unless (or (detailed? obj) (viewed? obj))
(remove-object-infos obj)
(if (symbolp obj) (untrace-var obj))))

296
src/tk/insp-misc.lsp
View file

@ -1,296 +0,0 @@
;******************************************************************************
;
; Project : STk-inspect, a graphical debugger for STk
;
; File name : inspect-misc.stk
; Creation date : Aug-30-1993
; Last update : Sep-17-1993
;
;******************************************************************************
;
; This file contains definitions often used.
;
;******************************************************************************
(in-package "TK")
(provide "inspect-misc")
(defvar BITMAP_MENU (& "@" tk_library "/bitmaps/menu.bm"))
(defvar FIXED_FONT "-adobe-courier-bold-r-*-*-*-140-*-*-*-*-*-*")
(defvar MEDIUM_FONT "-adobe-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*")
(defvar BOLD_FONT "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
(defvar ITALIC-MEDIUM_FONT "-adobe-helvetica-medium-o-*-*-*-120-*-*-*-*-*-*")
(defvar COURIER_BR14 "-adobe-courier-bold-r-*-*-*-140-*-*-*-*-*-*")
(defvar HELVETICA_BR12 "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
(defvar HELVETICA_BO12 "-adobe-helvetica-bold-o-*-*-*-120-*-*-*-*-*-*")
(defvar HELVETICA_MR12 "-adobe-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*")
(defvar HELVETICA_MO12 "-adobe-helvetica-medium-o-*-*-*-120-*-*-*-*-*-*")
(defvar HELVETICA_MO10 "-adobe-helvetica-medium-o-*-*-*-100-*-*-*-*-*-*")
(defvar SCREEN_WIDTH (winfo "vrootwidth" *root*))
(defvar SCREEN_HEIGHT (winfo "vrootheight" *root*))
;******************************************************************************
;
; General definitions and macros extending STk.
;
;******************************************************************************
;---- A special eval
(defun inspect::eval (x)
(if (and (symbolp x) (symbol-bound? x)) (eval x) x))
;---- Predicates
(defmacro not-equal (x y) `(not (equal ,x ,y)))
(defmacro different? (x y) `(not (equal ,x ,y)))
;---- Operators
(defmacro <> (x y)
`(not (= ,x ,y)))
;---- Display
(defun write\n (&rest l)
(until (null l)
(write (car l))
(setq l (cdr l)))
(newline))
(defun display\n (&rest l)
(until (null l)
(display (car l))
(setq l (cdr l)))
(newline))
;---- Control structures
(defmacro for (var test . body)
`(do ,var
((not ,test))
,@body))
;---- Strings
(defun ->string (obj)
(if (widget? obj)
(widget->string obj)
(format NIL "~A" obj)))
(defun ->object (obj)
(if (widget? obj)
(widget->string obj)
(format NIL "~S" obj)))
(defun list->str (l)
(if (null l)
""
(let loop ((l l) (s ""))
(let ((car-l (car l)) (cdr-l (cdr l)) (elem ()))
(if (list? car-l)
(setq elem (string-append "(" (list->str car-l) ")"))
(setq elem (->string car-l)))
(if (null cdr-l)
(string-append s elem)
(loop cdr-l (string-append s elem " ")))))))
;---- Vectors
(defun vector-index (v value)
(let ((length (vector-length v))
(index NIL))
(for ((i (- length 1) (- i 1)))
(>= i 0)
(if (equal (vector-ref v i) value) (setq index i)))
index))
;---- Lists
(defun list-first (obj lst)
(defun _list-first (obj lst index)
(cond ((null lst) NIL)
((equal obj (car lst)) index)
(else (_list-first obj (cdr lst) (+ index 1)))))
(_list-first obj lst 0))
(defmacro list-set! (lst index value)
`(progn
(setq ,lst (list->vector ,lst))
(vector-set! ,lst ,index ,value)
(setq ,lst (vector->list ,lst))))
(defun list-remove (obj lst)
(defun _list-remove (obj lst prev-lst)
(cond ((null lst) prev-lst)
((equal obj (car lst)) (append prev-lst (cdr lst)))
(else (_list-remove obj (cdr lst) (append prev-lst
(list (car lst)))))))
(_list-remove obj lst ()))
;---- Tk goodies
(defmacro widget (&rest etc)
`(string->widget (& ,@etc)))
(defun && (&rest l)
(if (null l)
""
(let loop ((l l) (s ""))
(if (null (cdr l))
(string-append s (->string (car l)))
(loop (cdr l) (string-append s (->string (car l)) " "))))))
(defmacro tki-get (canvas item option)
`(nth 2 (funcall ,canvas 'itemconfigure ,item ,option)))
(defmacro tki-set (canvas item option value)
`(funcall ,canvas 'itemconfigure ,item ,option ,value))
(defmacro @ (x y)
`(& "@" ,x "," ,y))
;******************************************************************************
;
;
;
;******************************************************************************
(define objects-infos-list ())
(defun object-infos (obj) (assoc obj objects-infos-list))
(defun object-type (obj) (nth 1 (object-infos obj)))
(defun object-symbol (obj) (nth 2 (object-infos obj)))
(defun add-object-infos (obj)
(setq objects-infos-list
(cons (list obj (inspect::typeof obj) (gensym "__g"))
objects-infos-list)))
(defun remove-object-infos (obj)
(setq objects-infos-list
(list-remove (object-infos obj) objects-infos-list)))
(defun find-object-infos (key)
(let ((found NIL))
(do ((l objects-infos-list (cdr l)))
((or found (null l)) found)
(when (equal (nth 2 (car l)) key)
(setq found (nth 0 (car l)))))))
(defun detailer-type (obj-type)
(case obj-type
((vector pair list) 'VPL)
((procedure) 'PROCEDURE)
((widget) 'WIDGET)
(else 'UNKNOWN)))
(defun viewer-type (obj-type)
(case obj-type
((procedure) 'PROCEDURE)
((widget) 'WIDGET)
(else 'GENERAL)))
(defun update-object (obj)
(let* ((obj-val (inspect::eval obj))
(old-type (object-type obj))
(obj-type (inspect::typeof obj-val)))
(unless (equal old-type obj-type)
(let ((obj-sym (object-symbol obj)))
(remove-object-infos obj)
(setq objects-infos-list
(cons (list obj obj-type obj-sym) objects-infos-list))))
(if (inspected? obj) (inspect-display obj))
(if (detailed? obj)
(if (equal (detailer-type old-type) (detailer-type obj-type))
(detail-display obj)
(progn
(undetail obj)
(if (different? 'UNKNOWN (detailer-type obj-type))
(detail obj)))))
(if (viewed? obj)
(if (equal (viewer-type old-type) (viewer-type obj-type))
(view-display obj)
(progn
(unview obj)
(view obj))))))
;---- Undebug
(defun undebug ()
(for-each (lambda (obj-infos)
(let ((obj (car obj-infos)))
(if (symbolp obj) (untrace-var obj))))
objects-infos-list)
(destroy INSPECTOR_WIDGET_NAME)
(setq inspected-objects-list ())
(for-each (lambda (obj) (destroy (detail-tl-wid obj))) detailed-objects-list)
(setq detailed-objects-list ())
(for-each (lambda (obj) (destroy (view-tl-wid obj))) viewed-objects-list)
(setq viewed-objects-list ())
(setq objects-infos-list ()))
;---- id widget
(defun create-id-widget (str)
(define wid (frame str))
(pack (frame (& str ".f1")) "-side" "top" "-fill" "x")
(pack (label (& str ".f1.l1") "-anchor" "w") "-side" "left")
(pack (label (& str ".f1.l2")
"-relief" "groove" "-bd" 2 "-anchor" "w" "-font" MEDIUM_FONT)
"-fill" "x" "-expand" "yes")
(pack (frame (& str ".f2")) "-side" "top" "-fill" "x")
(pack (label (& str ".f2.l") "-anchor" "w") "-side" "left")
(pack (entry (& str ".f2.e") "-relief" "sunken" "-bd" 2)
"-fill" "x" "-expand" "yes")
wid)
(defun set-id-label1 (wid text width)
((widget wid ".f1.l1") 'config "-text" text "-width" width))
(defun set-id-label2 (wid text width)
((widget wid ".f2.l") 'config "-text" text "-width" width))
(defun set-id-object (wid text) (tk-setq (widget wid ".f1.l2") "-text" text))
(defun get-id-object (wid) (tk-get (widget wid ".f1.l2") "-text"))
(defun set-id-value (wid text)
((widget wid ".f2.e") "delete" 0 "end")
((widget wid ".f2.e") "insert" 0 text))
(defun get-id-value (wid) ((widget wid ".f2.e") 'get))
;---- menu widget
(defun create-menu-widget (str)
(define wid (frame str "-relief" "raised" "-bd" 2))
(pack (menubutton (& str ".help") "-text" "Help") "-side" "right")
(tk-setq (widget str ".help") "-menu" (menu (& str ".help.m")))
((widget str ".help.m") "add" "command" "-label" "STk-inspect"
"-command" '(make-help STk-inspect-help))
wid)
;---- toplevel widget
(defun create-toplevel-widget (str)
(define wid (toplevel str))
(pack (create-id-widget (& str ".id")) "-side" "top" "-fill" "x" "-padx" 4 "-pady" 2)
(pack (create-menu-widget (& str ".menu"))
"-side" "top" "-fill" "x" "-padx" 4 "-pady" 2)
wid)
(defun inspect::shadow-entry (e)
(tk-setq e "-state" "disabled")
(tk-setq e "-bd" 1)
(tk-setq e "-bg" "grey50")
(tk-setq e "-fg" "grey95"))
(defun modifiable-object? (obj)
(and (symbolp obj) (symbol-bound? obj) (not (widget? (inspect::eval obj)))))

493
src/tk/insp-view.lsp
View file

@ -1,493 +0,0 @@
;******************************************************************************
;
; Project : STk-inspect, a graphical debugger for STk.
;
; File name : inspect-view.stk
; Creation date : Aug-30-1993
; Last update : Sep-17-1993
;
; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;
;******************************************************************************
;
; This file implements the different sort of "Viewers".
;
;******************************************************************************
(in-package "TK")
(provide "inspect-view")
(defun view-tl-wid (obj) (widget VIEW_WIDGET_NAME (object-symbol obj)))
(defun view-tl-str (obj) (& VIEW_WIDGET_NAME (object-symbol obj)))
(defun view-l-wid (obj) (widget (view-tl-str obj) ".id.f1.l2"))
(defun view-l-str (obj) (& (view-tl-str obj) ".id.f1.l2"))
(defun view-e-wid (obj) (widget (view-tl-str obj) ".id.f2.e"))
(defun view-e-str (obj) (& (view-tl-str obj) ".id.f2.e"))
(defun view-m-wid (obj) (widget (view-tl-str obj) ".menu.command.m"))
(defun view-m-str (obj) (& (view-tl-str obj) ".menu.command.m"))
(defun view-c-wid (obj) (widget (view-tl-str obj) ".f3.c"))
(defun view-c-str (obj) (& (view-tl-str obj) ".f3.c"))
;---- Viewer menu -------------------------------------------------------------
(defun view-menu-Eval (obj)
(set obj (eval (funcall (view-e-wid obj) "get")))))
(defun view-menu-Quote (obj)
(set obj (funcall (view-e-wid obj) "get")))
(defun view-menu-Inspect (key)
(let ((obj (find-object-infos key)))
(inspect obj)
(funcall (widget (view-tl-str obj) ".menu.command.m") "disable" "Inspect")
(if (detailed? obj) (funcall (detail-m-wid obj) "disable" "Inspect"))))
(defun view-menu-Detail (key)
(let ((obj (find-object-infos key)))
(detail obj)
(funcall (widget (view-tl-str obj) ".menu.command.m") "disable" "Detail")
(if (inspected? obj) (funcall (inspect-m-wid obj) "disable" "Detail"))))
(defun view-menu-Unview (key)
(unview (find-object-infos key)))
;---- Viewer ------------------------------------------------------------------
(define VIEW_WIDGET_NAME ".viewer")
(define viewed-objects-list ())
(defun viewed? (obj) (member obj viewed-objects-list))
(defun view (obj)
(unless (viewed? obj) (view-object obj)))
(defun view-object (obj)
(setq viewed-objects-list (cons obj viewed-objects-list))
(unless (object-infos obj)
(add-object-infos obj)
(if (symbolp obj) (trace-var obj `(update-object ',obj))))
(view-create obj))
(defun unview (obj)
(when (viewed? obj) (unview-object obj)))
(defun unview-object (obj)
(let ((top (view-tl-wid obj)))
(setq viewed-objects-list (list-remove obj viewed-objects-list))
(if (inspected? obj) (funcall (inspect-m-wid obj) "enable" "View"))
(if (detailed? obj) (funcall (detail-m-wid obj) "enable" "View"))
(unless (or (inspected? obj) (detailed? obj))
(remove-object-infos obj)
(if (symbolp obj) (untrace-var obj)))
;; If toplevel exists (i.e. it is not a <Destroy> event) destroy it
(if (= (winfo "exists" top) 1)
(destroy top))))
(defun view-create (obj)
(let ((obj-val (inspect::eval obj)))
(case (inspect::typeof obj-val)
((widget) (when (= (winfo "exists" (view-tl-wid obj-val)) 0)
(view-widget-create obj-val)))
((closure) (view-procedure-create obj))
(else (view-object-create obj)))))
(defun view-display (obj)
(case (object-type obj)
((widget) (view-widget-display (inspect::eval obj)))
((closure) (view-procedure-display obj))
(else (view-object-display obj))))
;---- Object/Procedure viewer -------------------------------------------------
(define CAR_COLOR "gray90")
(define CDR_COLOR "gray70")
(define ARROW_COLOR "black")
(define TEXT_COLOR "black")
(defun highlightItem (canvas color1 color2)
(let ((item (car (funcall canvas "find" "withtag" "current"))))
(if (equal (tki-get canvas item "-fill") color1)
(tki-set canvas item "-fill" color2)
(tki-set canvas item "-fill" color1))))
(defun find-car/cdr (fct count l)
(defun _find-car/cdr (fct count l path)
(if (not (consp l))
(if (null path)
NIL
(_find-car/cdr fct count (caar path) (cdr path)))
(if (equal 0 count)
(fct l)
(_find-car/cdr fct (- count 1) (cdr l) (cons l path)))))
(_find-car/cdr fct count l ()))
(defun double1OnCar (obj)
(let* ((canvas (view-c-wid obj))
(item (car (funcall canvas "find" "withtag" "current")))
(cars (funcall canvas "find" "withtag" 'CAR)))
(view (find-car/cdr car (list-first item cars) (inspect::eval obj)))))
(defun double1OnCdr (canvas obj)
(let ((item (car (funcall canvas "find" "withtag" "current")))
(cdrs (funcall canvas "find" "withtag" 'CDR)))
(view (find-car/cdr cdr (list-first item cdrs) (inspect::eval obj)))))
(defun text-width (text font)
(canvas ".text-width")
(define bbox
(.text-width "bbox" (.text-width "create" "text" 0 0 "-text" text "-font" font)))
(destroy .text-width)
(- (caddr bbox) (car bbox)))
(defun view-create-toplevel (obj)
(define w (create-toplevel-widget (view-tl-str obj)))
(define id-w (widget w ".id"))
(set-id-label1 id-w "Object" 6)
(set-id-label2 id-w "Value" 6)
(define menu-w (widget w ".menu"))
(funcall (widget w ".menu.help.m") "add" "command" "-label" "Viewer"
"-command" '(make-help Viewer-help))
(pack (menubutton (& menu-w ".command") "-text" "Command") "-side" "left")
(define cmd-w (eval (menu (& menu-w ".command.m"))))
(tk-setq (widget menu-w ".command") "-menu" cmd-w)
(cmd-w "add" "command" "-label" "Inspect"
"-command" `(view-menu-Inspect ',(object-symbol obj)))
(if (inspected? obj) (cmd-w "disable" "Inspect"))
(cmd-w "add" "command" "-label" "Detail"
"-command" `(view-menu-Detail ',(object-symbol obj)))
(if (detailed? obj) (cmd-w "disable" "Detail"))
(cmd-w "add" "command" "-label" "Unview"
"-command" `(view-menu-Unview ',(object-symbol obj)))
(if (modifiable-object? obj)
(begin
(bind (widget w ".id.f2.e") "<Return>" `(view-menu-Eval ',obj))
(bind (widget w ".id.f2.e") "<Shift-Return>" `(view-menu-Quote ',obj)))
(begin
(funcall (view-e-wid obj) "insert" 0 (format NIL "~S" (inspect::eval obj)))
(inspect::shadow-entry (widget w ".id.f2.e"))))
(pack (frame (& w ".f3") "-relief" "sunken" "-bd" 2)
"-fill" "both" "-expand" "yes" "-padx" 4 "-pady" 2)
(pack (scrollbar (& w ".f3.vsb") "-orient" "vertical")
"-side" "left" "-fill" "y")
(pack (scrollbar (& w ".f3.hsb") "-orient" "horizontal")
"-side" "bottom" "-fill" "x")
(pack (canvas (view-c-str obj) "-relief" "raised" "-bd" 2)
"-fill" "both" "-expand" "yes")
(tk-setq (widget w ".f3.vsb") "-command" (& (view-c-str obj) " \"yview\""))
(tk-setq (widget w ".f3.hsb") "-command" (& (view-c-str obj) " \"xview\""))
(tk-setq (view-c-wid obj) "-yscroll" (& w ".f3.vsb \"set\""))
(tk-setq (view-c-wid obj) "-xscroll" (& w ".f3.hsb \"set\""))
(bind w "<Destroy>" `(view-menu-Unview ',(object-symbol obj)))
w)
(defun view-object/procedure-create (obj)
(let ((w (view-create-toplevel obj))
(c (view-c-wid obj))
(c-name (widget-name c)))
(declare (special w))
(wm "title" w "Object viewer")
(wm "maxsize" w SCREEN_WIDTH SCREEN_HEIGHT)
(funcall c "bind" 'CAR "<Enter>" `(highlightItem ,c-name CAR_COLOR "red"))
(funcall c "bind" 'CAR "<Leave>" `(highlightItem ,c-name CAR_COLOR "red"))
(funcall c "bind" 'CAR "<Double-1>" `(double1OnCar ',obj))
(funcall c "bind" 'CDR "<Enter>" `(highlightItem ,c-name CDR_COLOR "blue"))
(funcall c "bind" 'CDR "<Leave>" `(highlightItem ,c-name CDR_COLOR "blue"))
(funcall c "bind" 'CDR "<Double-1>" `(double1OnCdr ,c-name ',obj))
w))
(defun view-object-create (obj)
(let ((w (view-object/procedure-create obj)))
(declare (special w))
(view-object-display obj)))
(defun view-object-display (obj)
(wm "title" (view-tl-wid obj) "Object viewer")
(define obj-val (inspect::eval obj))
(tk-setq (view-l-wid obj) "-text" (->object obj))
(funcall (view-e-wid obj) "delete" 0 "end")
(funcall (view-e-wid obj) "insert" 0 (->object obj-val))
(view-object/procedure-display (view-c-wid obj) obj-val))
(defun view-procedure-create (obj)
(let ((w (view-object/procedure-create obj)))
(declare (special w))
(view-procedure-display obj)))
(defun view-procedure-display (obj)
(wm "title" (view-tl-wid obj) "Procedure viewer")
(define obj-val (inspect::eval obj))
(tk-setq (view-l-wid obj) "-text" (->object obj))
(funcall (view-e-wid obj) "delete" 0 "end")
(funcall (view-e-wid obj) "insert" 0 (->object obj-val))
(view-object/procedure-display (view-c-wid obj) (procedure-body obj-val)))
(defun view-object/procedure-display (c obj-val)
(define grid-h 60) ; horizontal spacing between grid lines
(define grid-v 40) ; vertical spacing between grid lines
(define cons-h 40) ; horizontal size of cons cell
(define cons-v 20) ; vertical size of cons cell
(define cons-h/2 (quotient cons-h 2))
(define cons-v/2 (quotient cons-v 2))
(define arrow-space 2) ; space between arrow and box
(defun x-h (x) (* x grid-h))
(defun y-v (y) (* y grid-v))
(define font "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
(defun draw-cons-cell (x y)
(let ((h (x-h x)) (v (y-v y)))
(c "create" 'rectangle h v (+ h cons-h/2 1) (+ v cons-v)
"-fill" CAR_COLOR "-tag" 'CAR)
(c "create" 'rectangle (+ h cons-h/2) v (+ h cons-h) (+ v cons-v)
"-fill" CDR_COLOR "-tag" 'CDR)))
(defun car-arrow-pos (x y d)
(let ((h (x-h x)) (v (y-v y)))
(list (+ h (quotient cons-h 4)) (+ v cons-v/2) (+ h (quotient cons-h 4))
(+ v cons-v/2 (- (* d grid-v) (+ cons-v/2 arrow-space))))))
(defun draw-car-arrow (x y d) ; draw arrow downwards 'd' grid squares
(let ((pos (car-arrow-pos x y d)))
(if (and (= x 0) (= y 0))
(eval `(funcall ,c "create" "line" ,@pos "-arrow" "last" "-arrowshape" "8 8 3"))
(eval `(funcall ,c "create" "line" ,@pos "-arrow" "last" "-arrowshape" "8 8 3"
"-tag" 'CAR_ARROW)))))
(defun draw-car-text (x y d text)
(let ((pos (car-arrow-pos x y d)))
(if (<= (text-width text font) grid-h)
(c "create" "text" (caddr pos) (cadddr pos)
"-anchor" "n" "-font" font "-text" text "-tag" 'CAR_TEXT)
(let* ((text-l (label (& c "." (gensym "__g"))
:relief "groove" "-bd" 2
:text text "-anchor" "w" "-font" font))
(item (c "create" 'window (caddr pos) (+ 2 (cadddr pos))
"-window" text-l "-anchor" "n" "-width" (- grid-h 2)
"-tags" 'LONG_CAR_TEXT)))
(bind text-l "<Enter>"
`(funcall ,(widget-name c) 'itemconfig ,item
"-width" ,(+ 3 (text-width text font))))
(bind text-l "<Leave>"
`(funcall ,(widget-name c) 'itemconfig ,item
"-width" ,(- grid-h 2)))))))
(defun cdr-arrow-pos (x y d)
(let ((h (x-h x)) (v (y-v y)))
(list (+ h (quotient (* cons-h 3) 4)) (+ v cons-v/2)
(+ h (quotient (* cons-h 3) 4)
(- (* d grid-h) (+ (quotient (* cons-h 3) 4) arrow-space)))
(+ v cons-v/2))))
(defun draw-cdr-arrow (x y d) ; draw arrow to the right 'd' grid squares
(let ((pos (cdr-arrow-pos x y d)))
(eval `(funcall ,c "create" "line" ,@pos "-arrow" "last" "-arrowshape" "8 8 3"
"-tag" 'CDR_ARROW))))
(defun draw-cdr-text (x y d text)
(let ((pos (cdr-arrow-pos x y d)))
(c "create" "text" (caddr pos) (cadddr pos)
"-anchor" "w" "-font" font "-text" text "-tag" 'CDR_TEXT)))
(defun draw-nil (x y) ; draw nil in cdr of cons cell
(let ((h (x-h x)) (v (y-v y)))
(c "create" "line" (+ h cons-h/2) v (+ h cons-h) (+ v cons-v))
(c "create" "line" (+ h cons-h/2) (+ v cons-v -1) (+ h cons-h) (- v 1))))
(defun object-length (obj-val)
(cond ((null obj-val) 0)
((consp obj-val) (+ 1 (object-length (cdr obj-val))))
(else (+ 1 (quotient (text-width (->object obj-val) font)
grid-h)))))
(defun initial-profile () 0)
(defun car-profile (p) (if (consp p) (car p) p))
(defun cdr-profile (p) (if (consp p) (cdr p) p))
(defun make-profile (len p)
(defun fit1 (len p)
(if (> len 1)
(let ((p* (fit1 (- len 1) (cdr-profile p))))
(cons (car-profile p*) p*))
(fit2 (+ (car-profile p) 1) p)))
(defun fit2 (y p)
(if (consp p)
(cons (max y (car-profile p)) (fit2 y (cdr-profile p)))
(max y p)))
(fit1 len p))
(defun draw-list (lst x y p)
(draw-cons-cell x y)
(let* ((tail (cdr lst))
(tail-p (cdr-profile p))
(new-p (cond ((null tail)
(draw-nil x y)
tail-p)
((consp tail)
(draw-cdr-arrow x y 1)
(draw-list tail (+ x 1) y tail-p))
(else
(draw-cdr-arrow x y 1)
(draw-cdr-text x y 1 (->object tail))
tail-p))))
(draw-object (car lst) x y (cons (car-profile p) new-p))))
(defun draw-object (obj-val x y p)
(if (consp obj-val)
(let* ((len (object-length obj-val))
(new-p (make-profile len p))
(yy (car-profile new-p)))
(draw-car-arrow x y (- yy y))
(draw-list obj-val x yy new-p))
(let ((text (->object obj-val)))
(draw-car-arrow x y 1)
(draw-car-text x y 1 text)
(make-profile 1 p))))
(c "delete" "all")
(draw-object obj-val 0 0 (initial-profile))
(adjust-scrollregion c 20))
;---- Widget viewer -----------------------------------------------------------
(define show-widget
(let ((bg-color ())
(box-color ()))
(lambda (obj item press)
(let* ((canv-w (view-c-wid (inspect::eval obj)))
(tags (funcall canv-w 'gettags item))
(wid (inspect::eval (nth 1 tags))))
(if press
(progn
(setq box-color (tki-get canv-w item "-fill"))
(setq bg-color (tk-get wid "-bg"))
(tki-set canv-w item "-fill" "magenta")
(tk-setq wid "-bg" "magenta"))
(progn
(tki-set canv-w item "-fill" box-color)
(tk-setq wid "-bg" bg-color)))))))
(defun inspect-sub-widget (obj who)
(catch-errors
(inspect (inspect::eval (nth 1 (funcall (view-c-wid obj) 'gettags who))))))
(defun view-widget-create (obj)
(define w (view-create-toplevel obj))
(define obj-val (inspect::eval obj))
(wm "maxsize" w SCREEN_WIDTH SCREEN_HEIGHT)
(pack (frame (& w ".menu.level")) "-side" "left")
(pack (label (& w ".menu.level.l") "-text" "Level") "-side" "left")
(pack (entry (& w ".menu.level.e") "-relief" "sunken" "-bd" 2 "-width" 4)
"-side" "left")
(funcall (widget w ".menu.level.e") "insert" 0 9999)
(bind (widget (view-tl-str obj) ".menu.level.e") "<Return>"
`(view-widget-modify-level ',(object-symbol obj)))
(define c (view-c-wid obj))
(c "bind" '|CLASS| "<Double-1>"
`(inspect-sub-widget ,(widget-name obj-val)
"current"))
(c "bind" '|CLASS_NAME| "<Double-1>"
`(inspect-sub-widget ,(widget-name obj-val)
(car (funcall ,(widget-name c) "find" "below" "current"))))
(c "bind" '|CLASS| "<ButtonPress-1>"
`(show-widget ,(widget-name obj-val) "current" T))
(c "bind" '|CLASS| "<ButtonRelease-1>"
`(show-widget ,(widget-name obj-val) "current" NIL))
(c "bind" '|CLASS_NAME| "<ButtonPress-1>"
`(show-widget ,(widget-name obj-val)
(car (funcall ,(widget-name c) "find" "below" "current")) T))
(c "bind" '|CLASS_NAME| "<ButtonRelease-1>"
`(show-widget ,(widget-name obj-val)
(car (funcall ,(widget-name c) "find" "below" "current")) NIL))
(view-widget-display obj))
(defun view-widget-set-level (obj level)
(funcall (widget (view-tl-str obj) ".menu.level.e") "delete" 0 "end")
(funcall (widget (view-tl-str obj) ".menu.level.e") "insert" 0 level))
(defun view-widget-get-level (obj)
(let ((level (funcall (widget (view-tl-str obj) ".menu.level.e") 'get)))
(if (equal "" level) 9999 (string->number level))))
(defun view-widget-modify-level (key)
(let ((obj (find-object-infos key)))
(unless (view-widget-get-level obj) (view-widget-set-level obj 9999))
(view-widget-clear obj)
(view-widget-display obj)))
(defun get-children (wid)
(let ((children (winfo 'children wid)))
(if (listp children) children (list children))))
(defun view-widget-clear (obj) (funcall (view-c-wid obj) "delete" "all"))
(defun view-widget-display (obj)
(wm "title" (view-tl-wid obj) "Widget viewer")
(define obj-wid obj)
(define canv (view-c-wid obj))
(define h-grid 60)
(define v-grid 40)
(define h-box 80) (define h-box/2 (/ h-box 2))
(define v-box 20) (define v-box/2 (/ v-box 2))
(define y-global 40)
(define level (view-widget-get-level obj))
(define level-min level)
(defun _display (wid x level)
(let* ((name (winfo 'name wid))
(class (winfo 'class wid))
; (children (winfo 'children wid))
(children (get-children wid))
(y y-global))
(funcall canv "create" 'rectangle (- x h-box/2) (- y v-box) (+ x h-box/2) y
"-fill" "gray90" "-tags" (format NIL "CLASS ~a" (->string wid)))
(funcall canv "create" "text" x (- y v-box/2)
"-anchor" "center" "-text" class "-font" HELVETICA_MO12
"-tags" "CLASS_NAME")
(funcall canv "create" "text" (+ x h-box/2 10) (- y v-box/2)
"-anchor" "w" "-text" name "-font" HELVETICA_BR12)
(if (null children)
(setq level-min (min level level-min))
(if (> level 0)
(let ((y-child y))
(for-each
(lambda (child)
(setq y-global (+ y-global v-grid))
(setq y-child y-global)
(_display child (+ x h-grid) (- level 1)))
children)
(funcall canv "create" "line" x y x (- y-child v-box/2)))
(progn
(setq level-min 0)
(funcall canv "create" "line" x y x (+ y v-box/2) "-stipple" "gray50"))))
(unless (equal obj-wid wid)
(funcall canv "create" "line"
(- x h-box/2) (- y v-box/2) (- x h-grid) (- y v-box/2)))))
(set-id-object (& (view-tl-str obj) ".id") (format NIL "~S" obj))
(set-id-value (& (view-tl-str obj) ".id") (format NIL "~S" (inspect::eval obj)))
(funcall (view-c-wid obj) "delete" "all")
(_display obj-wid 0 level)
(view-widget-set-level obj (- level level-min))
(adjust-scrollregion canv 20))
(defun adjust-scrollregion (canv offset)
(multiple-value-bind (x1 y1 x2 y2)
(funcall canv "bbox" "all")
(tk-setq canv "-scrollregion"
(&& (- x1 offset) (- y1 offset)
(+ x2 offset) (+ y2 offset))))
(funcall canv "xyview" 0)
(funcall canv "yview" 0))
(defun view-widget (obj)
(view-widget-create obj)
(view-widget-display obj))

52
src/tk/listbox.lsp
View file

@ -1,52 +0,0 @@
;;;;
;;;; Listboxes bindings and procs
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 22-Nov-1993 16:04
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
;; ----------------------------------------------------------------------
;; Class bindings for listbox widgets.
;; ----------------------------------------------------------------------
(def-bindings "Listbox" '(
("<1>" . (%W "select" "from" (%W "nearest" %y)))
("<B1-Motion>" . (%W "select" "to" (%W "nearest" %y)))
("<2>" . (%W "scan" "mark" %x %y))
("<Shift-B2-Motion>" . (%W "scan" "dragto" %x %y))
("<3>" . (%W "select" "adjust" (%W 'nearest %y)))
))
;; The procedure below may be invoked to change the behavior of
;; listboxes so that only a single item may be selected at once.
;; The arguments give one or more windows whose behavior should
;; be changed; if one of the arguments is "Listbox" then the default
;; behavior is changed for all listboxes.
(defun tk-listbox-single-select (&rest args)
(let ((new-binding '(%W "select" "from" (%W "nearest" %y))))
(for-each (lambda (w)
(bind w "<B1-Motion>" new-binding)
(bind w "<3>" new-binding))
args)))

280
src/tk/menu.lsp
View file

@ -1,280 +0,0 @@
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 25-Nov-1993 15:54
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
;; ----------------------------------------------------------------------
;; Class bindings for menubutton widgets. Variables used:
;; tk::posted - keeps track of the menubutton whose menu is
;; currently posted (or empty string, if none).
;; tk::inMenuButton- if non-null, identifies menu button
;; containing mouse pointer.
;; tk::relief - keeps track of original relief of posted
;; menu button, so it can be restored later.
;; tk::dragging - if non-null, identifies menu button whose
;; menu is currently being dragged in a tear-off
;; operation.
;; curr-focus - records old focus window so focus can be
;; returned there after keyboard traversal
;; to menu.
;; ----------------------------------------------------------------------
(def-bindings "Menubutton" '(
("<Any-Enter>" . (progn
(setq tk::inMenuButton %W)
(unless (equal (tk-get %W "-state") "disabled")
(unless tk-strictMotif
(tk-setq %W "-state" "active")))))
("<Any-Leave>" . (progn
(setq tk::inMenuButton '())
(when (equal (tk-get %W "-state") "active")
(tk-setq %W "-state" "normal"))))
("<1>" . (tk-mbButtonDown %W))
("<Any-ButtonRelease-1>" . (if (and (equal %W tk::posted)
(equal %W tk::inMenuButton))
(funcall (string->widget (tk-get %W "-menu")) "activate" 0)
(tk-mbUnpost)))
;; The binding below is trickier than it looks. It's important to check
;; to see that another menu is posted in the "if" statement below.
;; The check is needed because some window managers (e.g. mwm in
;; click-to-focus mode) cause a button-press event to be preceded by
;; a B1-Enter event; we don't want to process that B1-Enter event (if
;; we do, the grab may get mis-set so that the menu is non-responsive).
("<B1-Enter>" . (progn
(setq tk::inMenuButton %W)
(when (and (not (equal (tk-get %W "-state") "disabled"))
tk::posted)
(unless tk-strictMotif
(tk-setq %W "-state" "active"))
(tk-mbPost %W))))
("<2>" . (unless (or tk::posted
(equal (tk-get %W "-state") "disabled"))
(setq tk::dragging %W)
(tk-execute-menu %W |%X| |%Y|)))
("<B2-Motion>" . (unless (equal tk::dragging "")
(tk-execute-menu %W |%X| |%Y|)))
("<ButtonRelease-2>" . (setq tk::dragging ""))
))
;; ----------------------------------------------------------------------
;; Class bindings for menu widgets. tk-priv(x) and tk-priv(y) are used
;; to keep track of the position of the mouse cursor in the menu window
;; during dragging of tear-off menus. tk-priv(window) keeps track of
;; the menu containing the mouse, if any.
;; ----------------------------------------------------------------------
(def-bindings "Menu" '(
("<Any-Enter>" . (progn
(setq tk::window %W)
(%W "activate" "@%y")))
("<Any-Leave>" . (progn
(setq tk::window '())
(%W "activate" "none")))
("<Any-Motion>" . (when (equal tk::window %W)
(%W "activate" "@%y")))
("<1>" . (unless (equal curr-grab "") (grab curr-grab)))
("<ButtonRelease-1>" . (tk-invokeMenu %W))
("<2>" . (progn
(setq tk::x %x)
(setq tk::y %y)))
("<B2-Motion>" . (unless tk::posted
(%W "post" (- %X tk::x) (- %Y tk::y))))
("<B2-Leave>" . ())
("<B2-Enter>" . ())
("<Escape>" . (tk-mbUnpost))
("<Any-KeyPress>" . (tk-traverseWithinMenu %W "%A"))
("<Left>" . (tk-nextMenu -1))
("<Right>" . (tk-nextMenu 1))
("<Up>" . (tk-nextMenuEntry -1))
("<Down>" . (tk-nextMenuEntry 1))
("<Return>" . (tk-invokeMenu %W))
))
;; The procedure below is publically available. It is used to identify
;; a frame that serves as a menu bar and the menu buttons that lie inside
;; the menu bar. This procedure establishes proper "menu bar" behavior
;; for all of the menu buttons, including keyboard menu traversal. Only
;; one menu bar may exist for a given top-level window at a time.
;; Arguments:
;;
;; bar - The path name of the containing frame. Must
;; be an ancestor of all of the menu buttons,
;; since it will be be used in grabs.
;; additional arguments - One or more menu buttons that are descendants
;; of bar. The order of these arguments
;; determines the order of keyboard traversal.
;; If no extra arguments are named then all of
;; the menu bar information for bar is cancelled.
(defvar tk::menusFor '())
(defvar tk::menuBarFor '())
(defun tk-menuBar (w &rest args)
(format T "~S~%" args)
(if (null args)
(cdr (assoc w tk::menusFor))
(let* ((win (winfo "toplevel" w))
(tmp1 (assoc w tk::menusFor))
(tmp2 (assoc win tk::menuBarFor)))
(format T "tmp1 ~S tmp2 ~S win ~S~%" tmp1 tmp2 win)
(if tmp1
(setf (cdr tmp1) args)
(push (cons w args) tk::menusFor))
(if tmp2
(setf (cdr tmp2) w)
(push (cons win w) tk::menuBarFor))
(bind w "<Any-ButtonRelease-1>" '(tk-mbUnpost)))))
;; The procedure below is publically available. It takes any number of
;; arguments that are names of widgets or classes. It sets up bindings
;; for the widgets or classes so that keyboard menu traversal is possible
;; when the input focus is in those widgets or classes.
(defun tk-bindForTraversal (&rest args)
(dolist (w args)
(bind w "<Alt-KeyPress>" '(tk-traverseToMenu %W "%A"))
(bind w "<F10>" (tk-firstMenu %W))))
;; The function below does all of the work of posting a menu (including
;; unposting any other menu that might currently be posted). The "w"
;; argument is the name of the menubutton for the menu to be posted.
;; Note: if w is disabled then the procedure does nothing.
(defun tk-mbPost (w)
(when (equal (tk-get w "-state") "disabled")
(return-from tk-mbPost NIL))
(when (equal tk::posted w)
;;; (grab "-global" curr-grab)
(grab curr-grab)
(return-from tk-mbPost NIL))
(let* ((MenuName (tk-get w "-menu"))
(Menu (string->widget MenuName)))
(when (equal MenuName "")
(return-from tk-mbPost NIL))
;; if a menu is already posted, unpost it
(when tk::posted (tk-mbUnpost))
;; Retain several graphical infos
(setq tk::relief (tk-get w "-relief"))
(setq tk::activeBg (tk-get Menu "-activebackground"))
(setq tk::activeFg (tk-get Menu "-activeforeground"))
(tk-setq w "-relief" "raised")
(setq tk::posted w)
(when (null curr-focus)
(setq curr-focus (get-focus)))
(focus MenuName)
(when tk-strictMotif
(tk-setq Menu "-activebackground" (tk-get Menu "-background"))
(tk-setq Menu "-activeforeground" (tk-get Menu "-foreground")))
(funcall Menu "activate" "none")
(funcall Menu "post" (winfo "rootx" w)
(+ (parse-integer (winfo "rooty" w))
(parse-integer (winfo "height" w))))
(let* ((grb '())
(win (winfo "toplevel" w))
(tmp (assoc win tk::menuBarFor)))
(if tmp
;; menu associated
(progn
(setq grb (cdr tmp))
(unless (member w (cdr (assoc grb tk::menusFor)))
(setq grb w)))
(setq grb w))
;; Retain actual cursor and set it now to an arrow
(setq tk::cursor (tk-get grb "-cursor"))
(tk-setq grb "-cursor" "arrow")
(setq curr-grab grb)
;;; (grab "-global" grb)
(grab grb))))
;; The procedure below does all the work of unposting the menubutton that's
;; currently posted. It takes no arguments. Special notes:
;; 1. It's important to unpost the menu before releasing the grab, so
;; that any Enter-Leave events (e.g. from menu back to main
;; application) have mode NotifyGrab.
;; 2. Be sure to enclose various groups of commands in "catch" so that
;; the procedure will complete even if the menubutton or the menu
;; or the grab window has been deleted.
(defun tk-mbUnpost ()
(when tk::posted
(let ((w tk::posted))
(catch-errors
(let* ((Menu (string->widget (tk-get w "-menu"))))
(funcall Menu "unpost")
(tk-setq Menu "-activebackground" tk::activeBg)
(tk-setq Menu "-activeforeground" tk::activeFg)
(tk-setq w "-relief" tk::relief)))
(catch-errors
(tk-setq curr-grab "-cursor" tk::cursor))
(focus curr-focus)
(grab "release" curr-grab)
(setq curr-focus '())
(setq tk::posted NIL))))
;; Following function executes the menu-button associated menu (if it exists)
(defun tk-execute-menu (w x y)
(let ((widget (string->widget (tk-get w "-menu"))))
(when widget
(funcall widget "post" x y))))
;; The procedure below invokes the active entry in the posted menu,
;; if there is one. Otherwise it does nothing.
(defun tk-invokeMenu (menu)
(let ((i (funcall menu "index" "active")))
(unless (equal i "none")
(tk-mbUnpost)
(update "idletasks")
(funcall menu "invoke" i))))
;; The procedure below is invoked when a button-1-down event is
;; received by a menu button. If the mouse is in the menu button
;; then it posts the button's menu. If the mouse isn't in the
;; button's menu, then it deactivates any active entry in the menu.
;; Remember, event-sharing can cause this procedure to be invoked
;; for two different menu buttons on the same event.
(defun tk-mbButtonDown (w)
(unless (equal (tk-get w "-state") "disabled")
(when (equal tk::inMenuButton w)
(tk-mbPost w))))

101
src/tk/regexp.lsp
View file

@ -1,101 +0,0 @@
;;;;
;;;; r e g e x p . l s p -- Regular expressions
;;;;
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 9-Nov-1994 13:24
;;;; Last file update: 10-Jan-1995 23:47
;;;;
(if (symbol-bound? '%init-regexp)
;; Regexp module is in the core interpreter
(%init-regexp)
;; Try to load regexp module dynamically
(load "sregexp.so"))
(defun replace-string (string ind1 ind2 new)
(string-append (substring string 0 ind1)
new
(substring string ind2 (string-length string))))
(define regexp-replace NIL)
(define regexp-replace-all NIL)
(let ()
;; Utility function
;; Given a string and a set of substitutions, return the substitued string
(defun replace-submodels (string subst match)
(if (= (length match) 1)
;; There is no sub-model
subst
;; There are at least one sub-model to replace
(let Loop ((subst subst))
(let ((pos ((string->regexp "\\\\[0-9]") subst)))
(if pos
;; At least one \x in the substitution string
(let* ((index (+ (caar pos) 1))
(val (string->number (substring subst index (+ index 1)))))
(if (>= val (length match))
(error "regexp-replace: cannot match \\~A in model" val)
;; Build a new subst with the current \x remplaced by
;; its value. Iterate for further \x
(Loop (replace-string subst
(caar pos)
(cadar pos)
(apply substring string
(nth val match))))))
;; No \x in substitution string
subst)))))
;; If there is a match, call replace-submodels; otherwise return string unmodified
;; This function takes an iterator function to allow multiple substitution
;; (iterator function = Identity for regexp-replace)
(setq regexp-replace
(lambda (pat str subst)
(let* ((regexp (cond
((regexp? pat) pat)
((string? pat) (string->regexp pat))
(else (error "regexp-replace: Bad pattern '~1'" pat))))
(match (regexp str)))
(if match
;; There was a match
(replace-string str
(caar match)
(cadar match)
(replace-submodels str subst match))
;; No match, return the original string
str))))
(setq regexp-replace-all
(lambda (pat str subst)
(let* ((regexp (cond
((regexp? pat) pat)
((string? pat) (string->regexp pat))
(else (error "regexp-replace-all: Bad pattern '~1'"
pat))))
(match (regexp str)))
(if match
;; There was a match
(regexp-replace-all
pat
(replace-string str
(caar match)
(cadar match)
(replace-submodels str subst match))
subst)
;; No match, return the original string
str)))))
(provide "regexp")

45
src/tk/scale.lsp
View file

@ -1,45 +0,0 @@
;;;;
;;;; Scale bindings and procs
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 22-Nov-1993 16:06
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
;; ----------------------------------------------------------------------
;; Class bindings for scale widgets. When strict Motif is requested,
;; the bindings use tk::buttons and tk::activeFg to set the
;; "-activeforeground" color to -foreground when the mouse is in the window
;; and restore it when the mouse leaves.
;; ----------------------------------------------------------------------
(def-bindings "Scale"
'(("<Any-Enter>" . (when tk::tk-strictMotif
(setq tk::activeFg
(tk-get %W "-activeforeground"))
(tk-setq %W "-activeforeground"
(tk-get %W "-sliderforeground"))))
("<Any-Leave>" . (when (and tk::tk-strictMotif (= tk::buttons 0))
(tk-setq %W "-activeforeground" tk::activeFg))
)
("<Any-ButtonPress>" . (setq tk::buttons (+ tk::buttons 1)))
("<Any-ButtonRelease>" . (setq tk::buttons (- tk::buttons 1)))
))

47
src/tk/scrollbar.lsp
View file

@ -1,47 +0,0 @@
;;;;
;;;; Scrollbars bindings and procs
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 22-Nov-1993 16:08
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
;; ----------------------------------------------------------------------
;; Class bindings for scrollbar widgets. When strict Motif is requested,
;; the bindings use $tk_priv(buttons) and $tk_priv(activeFg) to set the
;; -activeforeground color to -foreground when the mouse is in the window
;; and restore it when the mouse leaves.
;; ----------------------------------------------------------------------
(def-bindings "Scrollbar" '(
("<Any-Enter>" . (when tk-strictMotif
(setq tk::activeFg
(tk-get %W "-activeforeground"))
(tk-setq %W "-activeforeground"
(tk-get %W "-foreground"))))
("<Any-Leave>" . (when (and tk-strictMotif (= tk::buttons 0))
(tk-setq %W "-activeforeground" tk::activeFg)))
("<Any-ButtonPress>" . (setq tk::buttons (+ tk::buttons 1)))
("<Any-ButtonRelease>" . (setq tk::buttons (- tk::buttons 1)))
))

142
src/tk/text.lsp
View file

@ -1,142 +0,0 @@
;;;;
;;;; Texts bindings and procs (bindings a` la emacs)
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 2-Jun-1994 12:41
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
;; Class bindings for text widgets. tk::selectMode holds one of
;; 'char, 'word, or 'line to indicate which selection mode is active.
(defvar tk::selectMode 'CHAR)
(def-bindings "Text" '(
("<1>" . (progn
(setq tk::selectMode 'CHAR)
(%W "mark" "set" "insert" "@%x,%y")
(%W "mark" "set" "anchor" "@%x,%y")
(if (equal (tk-get %W "-state") "normal")
(focus %W))))
("<Double-1>" . (progn
(setq tk::selectMode 'WORD)
(%W "mark" "set" "insert" "@%x,%y wordstart")
(tk-textSelectTo %W "insert")))
("<Triple-1>" . (progn
(setq tk::selectMode "line")
(%W "mark" "set" "insert" "@%x,%y linestart")
(tk-textSelectTo %W "insert")))
("<B1-Motion>" . (tk-textSelectTo %W "@%x,%y"))
("<Shift-1>" . (progn
; (tk-textResetAnchor %W "@%x,%y")
(tk-textSelectTo %W "@%x,%y")))
("<Shift-B1-Motion>" . (tk-textSelectTo %W "@%x,%y"))
("<2>" . (catch-errors
(%W "insert" "insert" (selection "get"))
(%W "yview" "-pickplace" "insert")))
("<Shift-2>" . (%W "scan" "mark" %y))
("<Shift-B2-Motion>" . (%W "scan" "dragto" %y))
("<Any-backslash>" . (progn
(%W "insert" "insert" "\\")
(%W "yview" "-pickplace" "insert")))
("<Any-quotedbl>" . (progn
(%W "insert" "insert" "\"")
(%W "yview" "-pickplace" "insert")))
("<Any-KeyPress>" . (unless (equal "\\%A" "\\0")
(%W "insert" "insert" "%A")
(%W "yview" "-pickplace" "insert")))
("<Return>" . (progn
(%W "insert" "insert" #\newline)
(%W "yview" "-pickplace" "insert")))
("<BackSpace>" . (progn
(tk-textBackspace %W)
(%W "yview" "-pickplace" "insert")))
("<Delete>" . (progn
(tk-textBackspace %W)
(%W "yview" "-pickplace" "insert")))
("<Control-a>" . (%W "mark" "set" "insert"
(%W "index" "insert linestart")))
("<Control-b>" . (tk-backward-char %W))
("<Control-d>" . (%W "delete" "insert" "insert +1c"))
("<Control-e>" . (%W "mark" "set" "insert" (%W "index" "insert lineend")))
("<Control-f>" . (tk-forward-char %W))
("<Control-k>" . (%W "delete" "insert" "insert lineend"))
("<Control-n>" . (tk-next-line %W))
("<Control-o>" . (progn
(%W "insert" "insert" #\newline)
(tk-backward-char %W)))
("<Control-p>" . (tk-previous-line %W))
("<Control-w>" . (catch-errors
(setq tk::kill-buffer
(%W "get" "sel.first" "sel.last"))
(%W "delete" "sel.first" "sel.last")))
("<Control-y>" . (%W "insert" "insert" tk::kill-buffer))
("<Up>" . (tk-previous-line %W))
("<Down>" . (tk-next-line %W))
("<Left>" . (tk-backward-char %W))
("<Right>" . (tk-forward-char %W))
))
;;tk-bindForTraversal Text
;;
(defun tk-previous-line (w)
(funcall w "mark" "set" "insert" (funcall w "index" "insert -1line"))
(funcall w "yview" "-pickplace" "insert"))
(defun tk-next-line (w)
(funcall w "mark" "set" "insert" (funcall w "index" "insert +1line"))
(funcall w "yview" "-pickplace" "insert"))
(defun tk-forward-char (w)
(funcall w "mark" "set" "insert" (funcall w "index" "insert +1c"))
(funcall w "yview" "-pickplace" "insert"))
(defun tk-backward-char (w)
(funcall w "mark" "set" "insert" (funcall w "index" "insert -1c"))
(funcall w "yview" "-pickplace" "insert"))
;; The procedure below is invoked when dragging one end of the selection.
;; The arguments are the text window name and the index of the character
;; that is to be the new end of the selection.
(defun tk-textSelectTo (w index)
(let ((interval
(case tk::selectMode
(CHAR (if (equal (funcall w "compare" index "<" "anchor") "1")
(cons index "anchor")
(cons "anchor" (funcall w "index"
(format NIL "~A+1c" index)))))
(WORD (cons (funcall w "index" (format NIL "~A wordstart" index))
(funcall w "index" "anchor wordend")))
(LINE (cons (funcall w "index" (format NIL "~A linestart" index))
(funcall w "index" "anchor lineend"))))))
(funcall w "tag" "remove" "sel" "0.0" (car interval))
(funcall w "tag" "add" "sel" (car interval) (cdr interval))
(funcall w "tag" "remove" "sel" (cdr interval) "end")))
;; The procedure below is invoked to backspace over one character in
;; a text widget. The name of the widget is passed as argument.
(defun tk-textBackspace (w)
(funcall w "delete" "insert-1c" "insert"))

128
src/tk/tk-init.lsp
View file

@ -1,128 +0,0 @@
;;;;
;;;; Initialization file for ECL/Tk
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 9-Dec-1994 23:48
;;;;
;;;; Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
;;;;
(in-package "TK")
;; This is my personnal flavour. You'll probably wold like it
;(option "add" "ECL*foreground" "Grey20")
;(option "add" "ECL*background" "DarkSeaGreen3")
;(option "add" "ECL*Scrollbar*foreground" "DarkSeaGreen2")
;(option "add" "ECL*background" "#00feff")
;(option "add" "ECL*Scrollbar*foreground" "#00cdff")
(defstruct widget methods self name)
(defun string->widget (x) (symbol-function (intern x)))
;; Define some variables and utilities
(defmacro tk-get (w option)
`(nth 4 (funcall ,w "configure" ,option)))
(defmacro tk-setq (w option value)
`(funcall ,w "configure" ,option ,value))
(defun do-bindings (class bindings)
(dolist (l bindings) (bind class (car l) (cdr l))))
(defun & (&rest l)
(do ((l l (cdr l))
(res ""
(let ((e (car l)))
(concatenate 'string res
(cond ((stringp e) e)
((symbolp e) (symbol-name e))
((widget-p e) (symbol-name (widget-name e)))
((numberp e) (number->string e)))))))
((null l) res)))
(defun get-focus ()
(let ((f (focus)))
(if (equal f "none") "none" (eval f))))
;; Turn off strict Motif look and feel as a default.
(defvar tk-strictMotif NIL)
;; Following vars are used everywhere. So define them here
(defvar window '())
(defvar relief '())
(defvar buttons 0)
(defvar dragging '())
(defvar curr-focus '())
(defvar curr-grab "")
(defvar inMenuButton '())
(defvar posted NIL)
(defvar selectMode '())
(defvar window '())
(defvar activeBg '())
(defvar activeFg '())
(defvar x 0)
(defvar y 0)
(defvar buttonWindow '())
(defvar cursor "")
(defvar kill-buffer "") ;; One kill buffer shared between all texts.
;;; Scheme compatibility
(defmacro catch-errors (&rest body)
`(catch sys::*quit-tag*
(let ((sys::*break-enable* nil)) ,@body)))
(defvar *lib-bindings*)
(defun def-bindings (class bindings)
(push `(do-bindings ,class ',bindings) *lib-bindings*))
(let ((*default-pathname-defaults*
(concatenate 'string sys:*system-directory* "tk/"))
(*load-verbose* nil)
(*lib-bindings* nil))
(load "error")
(load "button")
(load "entry")
(load "listbox")
(load "menu")
(load "scale")
(load "scrollbar")
(load "text")
(setf (symbol-function 'tk-init)
`(lambda ()
(unless (equal tk_version "3.6")
(error
"wrong version of Tk loaded: need 3.6 (actual version is ~A)"
tk_version))
,@*lib-bindings*
(fmakunbound 'tk-init)
;;; (ecl-menu)
))
)
#|
(autoload "dialog" make-dialog)
(autoload "help" make-help)
(autoload "inspect-main" inspect view detail)
(autoload "editor" make-editor ed)
|#

74
src/tk/unix.lsp
View file

@ -1,74 +0,0 @@
;;;;
;;;; u n i x . l s p -- Some unix stuff
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;; Creation date: 29-Mar-1994 17:36
;;;; Last file update: 2-Nov-1994 16:41
;;;;
;;;; This file implements
;;;; (basename f)
;;;; (dirname f)
;;;; (decompose-file-name f) return f expoded in a list
;;;; (file-is-directory? f)
;;;; (file-is-regular? f)
;;;; (file-is-readable? f)
;;;; (file-is-writable? f)
(define basename '())
(define dirname '())
(define decompose-file-name '())
(let ()
(defun delete-trailing-slashes (s)
(let ((pos (- (string-length s) 1)))
(while (and (>= pos 0) (char=? (string-ref s pos) #\/))
(setq pos (- pos 1)))
(if (= pos -1)
"/"
(substring s 0 (+ pos 1)))))
(defun decompose (name)
(if (equal name "/")
(cons "/" "")
(progn
(let* ((f (delete-trailing-slashes name))
(len (string-length f))
(pos (- len 1)))
;; find last slash
(while (and (>= pos 0) (not (char=? (string-ref f pos) #\/)))
(setq pos (- pos 1)))
(case pos
(-1 (cons "." (substring f 0 len)))
(0 (cons "/" (substring f 1 len)))
(else (cons (delete-trailing-slashes (substring f 0 pos))
(substring f (+ pos 1) len))))))))
(setq basename (lambda (file) (cdr (decompose file))))
(setq dirname (lambda (file) (car (decompose file))))
(setq decompose-file-name (lambda (file)
(letrec ((decomp (lambda (file res)
(if (equal file "/")
(cons file res)
(let ((r (decompose file)))
(decomp (car r)
(cons (cdr r)
res)))))))
(decomp file '())))))
(provide "unix")