238 lines
7.4 KiB
Plaintext
238 lines
7.4 KiB
Plaintext
|
;;;;
|
|||
|
|
;;;; Initialization file for STk
|
|||
|
|
;;;;
|
|||
|
|
;;;; This script is executed for each STk-based application. It arranges class
|
|||
|
|
;;;; bindings for widgets.
|
|||
|
|
;;;;
|
|||
|
|
;;;; Copyright <20> 1993-1996 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: 13-Sep-1996 17:45
|
|||
|
|
;;;;
|
|||
|
|
|
|||
|
|
(unless (equal? *tk-version* "4.1")
|
|||
|
|
(error "wrong version of Tk loaded: need 4.1 (this version is ~A)"
|
|||
|
|
*tk-version*))
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; Utilities
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
(define-macro (tk-get w option)
|
|||
|
|
`(,w 'cget ,option))
|
|||
|
|
|
|||
|
|
(define-macro (tk-set! w option . value)
|
|||
|
|
`(,w 'configure ,option ,@value))
|
|||
|
|
|
|||
|
|
(define (Tk-screen-changed screen)
|
|||
|
|
;; This function is called when the screen is changed. Since I own only
|
|||
|
|
;; one screen, I don't know what I must do here.
|
|||
|
|
screen)
|
|||
|
|
|
|||
|
|
(define-macro (define-binding class event args . body)
|
|||
|
|
(if (null? body)
|
|||
|
|
`(bind ,class ,event "")
|
|||
|
|
`(bind ,class ,event (lambda ,args ,@body))))
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
;; Turn off strict Motif look and feel as a default.
|
|||
|
|
(define *tk-strict-Motif* #f)
|
|||
|
|
|
|||
|
|
;; Following vars are used everywhere. So define them here
|
|||
|
|
(define tk::window #f)
|
|||
|
|
(define tk::button-window '())
|
|||
|
|
(define tk::relief "sunken")
|
|||
|
|
(define tk::select-mode "")
|
|||
|
|
(define tk::mouse-moved #f)
|
|||
|
|
(define tk::press-x 0)
|
|||
|
|
(define tk::press-y 0)
|
|||
|
|
(define tk::x 0)
|
|||
|
|
(define tk::y 0)
|
|||
|
|
(define tk::after-id "")
|
|||
|
|
(define tk::active-bg "")
|
|||
|
|
(define tk::active-fg "")
|
|||
|
|
(define tk::dragging #f)
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define tk::buttons 0)
|
|||
|
|
(define tk::focus '())
|
|||
|
|
(define tk::grab "")
|
|||
|
|
(define tk::inMenuButton '())
|
|||
|
|
(define tk::posted #f)
|
|||
|
|
(define tk::selectMode '())
|
|||
|
|
(define tk::cursor "")
|
|||
|
|
(define tk::kill-buffer "") ;; One kill buffer shared between all texts.
|
|||
|
|
|
|||
|
|
|
|||
|
|
;; add-binding --
|
|||
|
|
;; This procedure adds a binding to a widget. It replaces the Tcl "+" mechanism
|
|||
|
|
;; which is meaningless with closures. Furthermore, this mechanism permits
|
|||
|
|
;; to add the binding BEFORE the old binding
|
|||
|
|
;;
|
|||
|
|
(define (add-binding widget event binding before?)
|
|||
|
|
(let ((old (bind widget event)))
|
|||
|
|
(if (null? old)
|
|||
|
|
(bind widget event binding)
|
|||
|
|
;;; We must find the parameters of the old and given bindings
|
|||
|
|
;;; The new binding is a new closure with the union of these
|
|||
|
|
;;; parameters.
|
|||
|
|
;;; if:
|
|||
|
|
;;; old binding is (lambda (x y) ....)
|
|||
|
|
;;; given binding is (lambda (x t a) ...)
|
|||
|
|
;;; We must construct the binding of the form
|
|||
|
|
;;; (lambda (x y t a)
|
|||
|
|
;;; ((lambda (x y) ....) x y)
|
|||
|
|
;;; ((lambda (x t a) ....) x t a))
|
|||
|
|
(let ((body-old (procedure-body (car old)))
|
|||
|
|
(body-new (procedure-body binding)))
|
|||
|
|
(if (and body-old body-new)
|
|||
|
|
(let ((p-old (cadr body-old))
|
|||
|
|
(p-new (cadr body-new)))
|
|||
|
|
(bind widget
|
|||
|
|
event
|
|||
|
|
(if before?
|
|||
|
|
(eval `(lambda ,(set-union p-old p-new)
|
|||
|
|
(,binding ,@(cadr body-new))
|
|||
|
|
,old))
|
|||
|
|
(eval `(lambda ,(set-union p-old p-new)
|
|||
|
|
,old
|
|||
|
|
(,binding ,@(cadr body-new)))))))
|
|||
|
|
;;
|
|||
|
|
(Error "add-binding: Incorrect binding ~S" binding))))))
|
|||
|
|
|
|||
|
|
;; Tk:cancel-repeat --
|
|||
|
|
;; This procedure is invoked to cancel an auto-repeat action described
|
|||
|
|
;; by tk::after-id. It's used by several widgets to auto-scroll
|
|||
|
|
;; the widget when the mouse is dragged out of the widget with a
|
|||
|
|
;; button pressed.
|
|||
|
|
|
|||
|
|
(define (Tk:cancel-repeat)
|
|||
|
|
(after 'cancel tk::after-id)
|
|||
|
|
(set! tk::after-id ""))
|
|||
|
|
|
|||
|
|
;;;;
|
|||
|
|
;;;; A procedure to forbid remote executution via the send Tk command
|
|||
|
|
;;;;
|
|||
|
|
(define (inhibit-send)
|
|||
|
|
;; Redefine send sommand
|
|||
|
|
(set! send @undefined)
|
|||
|
|
;; Issue a GC so that command is effectively deleted from Tk tables NOW
|
|||
|
|
(gc))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;;
|
|||
|
|
;;;; Define widget which require a lot of initialization as a kind of autoload
|
|||
|
|
;;;; This allows a faster loading for small programs which use only a few widgets
|
|||
|
|
;;;; and decreases memory usage
|
|||
|
|
;;;;
|
|||
|
|
|
|||
|
|
(define-macro (%redefine-Tk-command widget file)
|
|||
|
|
(let ((synonym (string->symbol (format #f "tk:~A" widget))))
|
|||
|
|
`(set! ,widget
|
|||
|
|
(let ((tk-cmd ,widget))
|
|||
|
|
(lambda l
|
|||
|
|
;; Load the library file
|
|||
|
|
(load ,(string-append *STk-library* "/STk/" file ".stk"))
|
|||
|
|
|
|||
|
|
;; Test here that old value is a true closure because when
|
|||
|
|
;; using STklos some Tk commands are already defined as generic.
|
|||
|
|
;; Reloading the file and setting widget and Tk:widget breaks
|
|||
|
|
;; the generic function. Weak but it seems to work
|
|||
|
|
(if (closure? ,widget) (set! ,widget tk-cmd))
|
|||
|
|
(if (closure? ,synonym) (set! ,synonym tk-cmd))
|
|||
|
|
|
|||
|
|
;; Do the job
|
|||
|
|
(apply tk-cmd l))))))
|
|||
|
|
|
|||
|
|
(%redefine-Tk-command button "button")
|
|||
|
|
(%redefine-Tk-command checkbutton "button")
|
|||
|
|
(%redefine-Tk-command radiobutton "button")
|
|||
|
|
(%redefine-Tk-command entry "entry")
|
|||
|
|
(%redefine-Tk-command focus "focus")
|
|||
|
|
(%redefine-Tk-command listbox "listbox")
|
|||
|
|
(%redefine-Tk-command menu "menu")
|
|||
|
|
(%redefine-Tk-command menubutton "menu")
|
|||
|
|
(%redefine-Tk-command scale "scale")
|
|||
|
|
(%redefine-Tk-command scrollbar "scrollbar")
|
|||
|
|
(%redefine-Tk-command text "text")
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;
|
|||
|
|
;; Make synonyms for all Tk-commands to "protect" them against redefinition
|
|||
|
|
;;
|
|||
|
|
(define Tk:button button)
|
|||
|
|
(define Tk:checkbutton checkbutton)
|
|||
|
|
(define Tk:canvas canvas)
|
|||
|
|
(define Tk:entry entry)
|
|||
|
|
(define Tk:frame frame)
|
|||
|
|
(define Tk:image image)
|
|||
|
|
(define Tk:label label)
|
|||
|
|
(define Tk:listbox listbox)
|
|||
|
|
(define Tk:menu menu)
|
|||
|
|
(define Tk:menubutton menubutton)
|
|||
|
|
(define Tk:message message)
|
|||
|
|
(define Tk:scale scale)
|
|||
|
|
(define Tk:scrollbar scrollbar)
|
|||
|
|
(define Tk:radiobutton radiobutton)
|
|||
|
|
(define Tk:text text)
|
|||
|
|
(define Tk:toplevel toplevel)
|
|||
|
|
|
|||
|
|
(define Tk:after after)
|
|||
|
|
(define Tk:bind bind)
|
|||
|
|
(define Tk:bindtags bindtags)
|
|||
|
|
(define Tk:bell bell)
|
|||
|
|
(define Tk:clipboard clipboard)
|
|||
|
|
(define Tk:destroy destroy)
|
|||
|
|
(define Tk:focus focus)
|
|||
|
|
(define Tk:grab grab)
|
|||
|
|
(define Tk:lower lower)
|
|||
|
|
(define Tk:option option)
|
|||
|
|
(define Tk:pack pack)
|
|||
|
|
(define Tk:place place)
|
|||
|
|
(define Tk:raise raise)
|
|||
|
|
(define Tk:selection selection)
|
|||
|
|
(define Tk:tk tk)
|
|||
|
|
(define Tk:tkwait tkwait)
|
|||
|
|
(define Tk:update update)
|
|||
|
|
(define Tk:winfo winfo)
|
|||
|
|
(define Tk:wm wm)
|
|||
|
|
|
|||
|
|
;;;;
|
|||
|
|
;;;; Some autoloads
|
|||
|
|
;;;;
|
|||
|
|
(autoload "palette" Tk:set-palette! Tk:bisque)
|
|||
|
|
(autoload "dialog" STk:make-dialog STk:center-window)
|
|||
|
|
(autoload "listener" listener)
|
|||
|
|
(autoload "help" help STk:show-help-file)
|
|||
|
|
(autoload "menu" Tk:option-menu)
|
|||
|
|
(autoload "fileevent" Tk:fileevent fileevent) ; for backward compatibility
|
|||
|
|
;;;;
|
|||
|
|
;;;; report-error as a kind of autoload (must be a closure, rather than an
|
|||
|
|
;;;; autoload since C error function tests explicitely it is a closure before
|
|||
|
|
;;;; applying its arguments
|
|||
|
|
;;;;
|
|||
|
|
(autoload "error" STk:report-error bgerror *error-info* *error-code*)
|
|||
|
|
(autoload "sterm" sterm)
|
|||
|
|
|
|||
|
|
(define (report-error . args)
|
|||
|
|
(apply STk:report-error args))
|
|||
|
|
|
|||
|
|
;;;;
|
|||
|
|
;;;; Retain now that Tk is fully initialized
|
|||
|
|
;;;;
|
|||
|
|
(set! Tk:initialized? #t)
|