97 lines
3.4 KiB
Plaintext
97 lines
3.4 KiB
Plaintext
;;;;
|
|
;;;; m e t h o d - e d i t o r . s t k l o s -- Editor for STklos methods and gf
|
|
;;;;
|
|
;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; 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 [eg@unice.fr]
|
|
;;;; Creation date: 24-Sep-1998 16:32
|
|
;;;; Last file update: 3-Sep-1999 19:53 (eg)
|
|
|
|
(require "Tk-classes")
|
|
|
|
;;;
|
|
;;; Utilities
|
|
;;;
|
|
|
|
(define (method->list m)
|
|
(let ((gf (method-generic-function m)))
|
|
(if gf
|
|
(let ((proc (uncode (procedure-body (method-procedure m))))
|
|
(spec (map* class-name (method-specializers m))))
|
|
`(define-method ,(generic-function-name gf) ,(map* list (cdadr proc) spec)
|
|
,@(cddr proc)))
|
|
;; Method with no associated method
|
|
'())))
|
|
|
|
;=============================================================================
|
|
;
|
|
; m e t h o d - e d i t o r
|
|
;
|
|
;=============================================================================
|
|
(define-method method-editor ((m <method>) parent)
|
|
|
|
(define (make-buttons parent edit env)
|
|
(let* ((f (make <Frame> :parent parent :border-width 2 :relief "ridge"))
|
|
(e (make <Button> :parent f :text "Eval" :border-width 0
|
|
:command (lambda ()
|
|
(eval-string (value edit) env))))
|
|
(c (make <Button> :parent f :text "Close" :border-width 0
|
|
:command (lambda () (destroy parent)))))
|
|
(pack c e :side 'left)
|
|
f))
|
|
|
|
(let* ((class (if (is-a? parent <Multiple-window>) <Inner-Window> <Toplevel>))
|
|
(top (make class :title m :parent parent))
|
|
(body (pp (method->list m) 75 #f))
|
|
(env (procedure-environment (method-procedure m)))
|
|
(edit (make <Scheme-Text> :parent top :width 80 :background "white"
|
|
:value body))
|
|
(but (make-buttons top edit env)))
|
|
(pack but :expand #f :fill "x")
|
|
(pack edit :expand #t :fill "both")
|
|
top))
|
|
|
|
|
|
(define-method method-editor ((m <method>)) ; without parent
|
|
(method-editor m *top-root*))
|
|
|
|
;=============================================================================
|
|
;
|
|
; g f - e d i t o r
|
|
;
|
|
;=============================================================================
|
|
(define-method gf-editor ((gf <generic>))
|
|
|
|
(define (make-buttons parent)
|
|
(let* ((f (make <Frame> :parent parent :border-width 2 :relief "ridge"))
|
|
(t (make <Label> :parent f :anchor 'w
|
|
:text (format #f "Methods of `~S'" (generic-function-name gf))))
|
|
(e (make <Button> :parent f :text "Close"
|
|
:command (lambda () (destroy parent)))))
|
|
(pack t :fill 'x :expand #t :side 'left :padx 5)
|
|
(pack e :side 'left)
|
|
f))
|
|
|
|
(let* ((top (make <Toplevel> :title "Generic Function Editor"))
|
|
(win (make <Multiple-Window> :parent top :background "wheat3"))
|
|
(but (make-buttons top)))
|
|
(pack but :side "top" :expand #f :fill 'x)
|
|
(pack win :expand #t :fill "both")
|
|
|
|
(let loop ((x 20) (y 20) (l (generic-function-methods gf)))
|
|
(when (pair? l)
|
|
(let ((ed (method-editor (car l) win)))
|
|
(place ed :x x :y y)
|
|
(loop (+ x 20) (+ y 20) (cdr l)))))))
|
|
|
|
(provide "method-editor")
|