123 lines
4.8 KiB

;;;; c o m p a t i b i l i t y . s t k -- This file contains function which
;;;; which assume compatibility between
;;;; versions. Loading of this file will
;;;; lead to print a message
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;; Author: Erick Gallesio []
;;;; Creation date: 23-Aug-1994 16:53
;;;; Last file update: 3-Sep-1999 19:49 (eg)
(format #t "
***** WARNING: Loading compatibility mode
***** (You are using something which is obsolete. Avoid to use it
***** if you don't want to see this message again)
;;;; Compatibily macros. Don't use the define-simple-widget and
;;;; define-composite-widget macros anymore
(define-macro (define-simple-widget name super slots constructor)
(say-define (symbol->string ',name))
(define-class ,name (<Tk-simple-widget> ,@super)
(define-method tk-constructor ((self ,name))
(define-macro (define-composite-widget name super slots)
(say-define (symbol->string ',name))
(define-class ,name (<Tk-composite-widget> ,@super)
;;;; Reading of STF 0.1 files
(define (compatibility-set-STF-0.1! txt STF)
(define normal-font "*-Courier-Medium-R-Normal-*-120-*")
(define 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-*-*-*-*-*-*"))
(define (unset-tags editor-window start end)
(for-each (lambda (tag)
(editor-window 'tag 'remove (car tag) start end))
(define (set-font editor-window font start end)
;; Be sure this tag exists
(editor-window 'tag 'conf font :font (cadr (assoc font all-fonts)))
;; Set a new tag for this character range
(editor-window 'tag 'add font start end))
(define (set-underline editor-window start end)
(editor-window 'tag 'conf 'underline :underline #t)
(editor-window 'tag 'add 'underline start end))
(let ((text (cadr STF)) (fmts (caddr STF)) (editor-window (Id txt)))
;; First insert new text
(editor-window 'delete "1.0" "end")
(editor-window 'insert "1.0" text)
(editor-window 'mark 'set 'insert "1.0")
;; And now enhence it
(for-each (lambda (t)
(format #t "On y est ~S\n" t)
(do ((l (cadr t) (cddr l)))
((null? l))
(if (eqv? (car t) 'underline)
(set-underline editor-window (car l) (cadr l))
(set-font editor-window (car t) (car l) (cadr l)))))
;; Now create a STklos object for each tags used. So that next save will
;; be in the new STF format
(for-each (lambda (t)
(unless (null? (editor-window 'tag 'ranges (car t)))
(format #t "Creation du tag ~S\n" (car t))
(make <Text-tag> :parent txt :Tid (car t) :font (cadr t))))
(provide "compatibility")