home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / compatibility.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  4.8 KB  |  124 lines
  1. ;;;;
  2. ;;;; c o m p a t i b i l i t y . s t k   --  This file contains function which
  3. ;;;;                         which assume compatibility between
  4. ;;;;                         versions. Loading of this file will 
  5. ;;;;                         lead to print a message 
  6. ;;;;
  7. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  8. ;;;; 
  9. ;;;; Permission to use, copy, and/or distribute this software and its
  10. ;;;; documentation for any purpose and without fee is hereby granted, provided
  11. ;;;; that both the above copyright notice and this permission notice appear in
  12. ;;;; all copies and derived works.  Fees for distribution or use of this
  13. ;;;; software or derived works may only be charged with express written
  14. ;;;; permission of the copyright holder.  
  15. ;;;; This software is provided ``as is'' without express or implied warranty.
  16. ;;;;
  17. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  18. ;;;;    Creation date: 23-Aug-1994 16:53
  19. ;;;; Last file update: 17-Oct-1994 18:26
  20.  
  21. (format #t "
  22. *****
  23. ***** WARNING: Loading compatibility mode 
  24. ***** (You are using something which is obsolete. Avoid to use it 
  25. ***** if you don't want to see this message again)
  26. *****\n")
  27.  
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ;;;;
  31. ;;;; Compatibily macros. Don't use the define-simple-widget and
  32. ;;;; define-composite-widget macros anymore
  33. ;;;;
  34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35.  
  36. (define-macro (define-simple-widget name super slots constructor)
  37.   `(begin
  38.      (say-define (symbol->string ',name))
  39.      (define-class ,name (<Tk-simple-widget> ,@super) 
  40.        ,slots)
  41.      (define-method tk-constructor ((self ,name))
  42.        ,constructor)))
  43.  
  44. (define-macro (define-composite-widget name super slots)
  45.   `(begin
  46.      (say-define (symbol->string ',name))
  47.      (define-class ,name (<Tk-composite-widget> ,@super) 
  48.        ,slots)
  49.      ,name))
  50.  
  51. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52. ;;;;
  53. ;;;; Reading of STF 0.1 files
  54. ;;;;
  55. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56. (define (compatibility-set-STF-0.1! txt STF)
  57.   (define normal-font "*-Courier-Medium-R-Normal-*-120-*")
  58.   (define all-fonts `(
  59.        (normal        ,normal-font)
  60.        (fixed        "fixed")
  61.        (big        "-*-times-*-r-*-*-*-240-*-*-*-*-*-*")
  62.        (roman-12    "-*-times-*-r-*-*-*-120-*-*-*-*-*-*")
  63.        (roman-14    "-*-times-*-r-*-*-*-140-*-*-*-*-*-*")
  64.        (roman-16    "-*-times-*-r-*-*-*-160-*-*-*-*-*-*")
  65.        (roman-18    "-*-times-*-r-*-*-*-180-*-*-*-*-*-*")
  66.        (italic-12    "-*-times-*-i-*-*-*-120-*-*-*-*-*-*")
  67.        (italic-14    "-*-times-*-i-*-*-*-140-*-*-*-*-*-*")
  68.        (italic-16    "-*-times-*-i-*-*-*-160-*-*-*-*-*-*")
  69.        (italic-18    "-*-times-*-i-*-*-*-180-*-*-*-*-*-*")
  70.        (bold-12        "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
  71.        (bold-14        "-*-helvetica-bold-r-*-*-*-140-*-*-*-*-*-*")
  72.        (bold-16        "-*-helvetica-bold-r-*-*-*-160-*-*-*-*-*-*")
  73.        (bold-18        "-*-helvetica-bold-r-*-*-*-180-*-*-*-*-*-*")
  74.        (bold-italic-12    "-*-helvetica-bold-o-*-*-*-120-*-*-*-*-*-*")
  75.        (bold-italic-14    "-*-helvetica-bold-o-*-*-*-140-*-*-*-*-*-*")
  76.        (bold-italic-16    "-*-helvetica-bold-o-*-*-*-160-*-*-*-*-*-*")
  77.        (bold-italic-18    "-*-helvetica-bold-o-*-*-*-180-*-*-*-*-*-*")
  78.        (tty-12        "-adobe-courier-medium-*-*-*-*-120-*-*-*-*-*-*")
  79.        (tty-14        "-adobe-courier-medium-*-*-*-*-140-*-*-*-*-*-*")
  80.        (tty-16        "-adobe-courier-medium-*-*-*-*-160-*-*-*-*-*-*")
  81.        (tty-18        "-adobe-courier-medium-*-*-*-*-180-*-*-*-*-*-*"))
  82.  
  83.   (define (unset-tags editor-window start end)
  84.     (for-each (lambda (tag) 
  85.         (editor-window 'tag 'remove (car tag) start end))
  86.           all-fonts))
  87.   
  88.   (define (set-font editor-window font start end)
  89.     ;; Be sure this tag exists
  90.     (editor-window 'tag 'conf font :font (cadr (assoc font all-fonts)))
  91.     ;; Set a new tag for this character range
  92.     (editor-window 'tag 'add font start end))
  93.   
  94.   (define (set-underline editor-window start end)
  95.     (editor-window 'tag 'conf 'underline :underline #t)
  96.     (editor-window 'tag 'add 'underline start end))
  97.   
  98.   (let ((text (cadr STF)) (fmts (caddr STF)) (editor-window (Id txt)))
  99.     ;; First insert new text
  100.     (editor-window 'delete "1.0" "end")
  101.     (editor-window 'insert "1.0" text)
  102.     (editor-window 'mark 'set 'insert "1.0")
  103.     ;; And now enhence it
  104.     (for-each (lambda (t) 
  105.         (format #t "On y est ~S\n" t)
  106.         (do ((l (cadr t) (cddr l)))
  107.             ((null? l))
  108.           (if (eqv? (car t) 'underline)
  109.               (set-underline editor-window (car l) (cadr l))
  110.               (set-font editor-window (car t) (car l) (cadr l)))))
  111.           fmts)
  112.     
  113.     ;; Now create a STklos object for each tags used. So that next save will 
  114.     ;; be in the new STF format
  115.     (for-each (lambda (t)
  116.         (unless (null? (editor-window 'tag 'ranges (car t)))
  117.             (format #t "Creation du tag ~S\n" (car t))
  118.             (make <Text-tag> :parent txt :Tid (car t) :font (cadr t))))
  119.           all-fonts)))
  120.  
  121.  
  122.  
  123. (provide "compatibility")
  124.