Changeset 11920 in project


Ignore:
Timestamp:
09/07/08 23:18:46 (11 years ago)
Author:
kon
Message:

Update to latest (and last I understand) version.

Location:
release/3/PS-tk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/3/PS-tk/PS-tk.scm

    r5038 r11920  
    1 (cond-expand
    2   (chicken
    3     (require-extension posix)
    4       (eval-when (compile)
    5         (declare
    6           (fixnum)
    7           (no-procedure-checks-for-usual-bindings) ) ) )
    8   (else) )
     1(require-extension posix)
     2(eval-when (compile)
     3  (declare
     4    (usual-integrations)
     5    (fixnum)
     6    (no-procedure-checks-for-usual-bindings) ) )
    97
    108; PS/Tk -- A Portable Scheme Interface to the Tk GUI Toolkit
    11 ; Copyright (C) 2006,2007 Nils M Holm
     9; Copyright (C) 2008 Kenneth A Dickey
     10; Copyright (C) 2006-2008 Nils M Holm
    1211; Copyright (C) 2004 Wolf-Dieter Busch
    1312; All rights reserved.
     
    6564;   Kawa, Scsh, Stklos), SRFI-88 keyword auto-detection, some bug fixes.
    6665; - David St-Hilaire: suggested catching unspecific value in form->string.
     66; - Ken Dickey: added Ikarus Scheme
     67; - Ken Dickey: added Larceny Scheme
    6768; Thank you!
    6869;
    6970; Change Log:
     71; 2008-06-22 Added Larceny Scheme support.
     72; 2008-02-29 Added R6RS (Ikarus Scheme) support, added TTK/STYLE.
    7073; 2007-06-27 Renamed source file to pstk.scm.
    7174; 2007-06-27 Re-factored some large procedures, applied some cosmetics.
     
    98101; 2006-12-02 Added PLT/Windows port.
    99102
    100 (define *wish-program* "wish")
     103(define *wish-program* "wish" #;"tclsh")
    101104(define *wish-debug-input* #f)
    102105(define *wish-debug-output* #f)
     
    161164(define ttk/available-themes #f)
    162165(define ttk/set-theme #f)
     166(define ttk/style #f)
    163167
    164168(letrec
     
    187191
    188192   (tk-init-string
    189 "
    190 package require Tk
    191 if {[package version tile] != \"\"} {
    192     package require tile
    193 }
    194 
    195 namespace eval AutoName {
    196     variable c 0
    197     proc autoName {{result \\#\\#}} {
    198         variable c
    199         append result [incr c]
    200     }
    201     namespace export *
    202 }
    203 
    204 namespace import AutoName::*
    205 
    206 proc callToScm {callKey args} {
    207     global scmVar
    208     set resultKey [autoName]
    209     puts \"(call $callKey \\\"$resultKey\\\" $args)\"
    210     flush stdout
    211     vwait scmVar($resultKey)
    212     set result $scmVar($resultKey)
    213     unset scmVar($resultKey)
    214     set result
    215 }
    216 
    217 proc tclListToScmList {l} {
    218     switch [llength $l] {
    219         0 {
    220             return ()
    221         }
    222         1 {
    223             if {[string range $l 0 0] eq \"\\#\"} {
    224                 return $l
    225             }
    226             if {[regexp {^[0-9]+$} $l]} {
    227                 return $l
    228             }
    229             if {[regexp {^[.[:alpha:]][^ ,\\\"\\'\\[\\]\\\\;]*$} $l]} {
    230                 return $l
    231             }
    232             set result \\\"
    233             append result\\
    234                 [string map [list \\\" \\\\\\\" \\\\ \\\\\\\\] $l]
    235             append result \\\"
    236 
    237         }
    238         default {
    239             set result {}
    240             foreach el $l {
    241                 append result \" \" [tclListToScmList $el]
    242             }
    243             set result [string range $result 1 end]
    244             return \"($result)\"
    245         }
    246     }
    247 }
    248 
    249 proc evalCmdFromScm {cmd {properly 0}} {
    250     if {[catch {
    251         set result [uplevel \\#0 $cmd]
    252     } err]} {
    253         puts \"(error \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $err]\\\")\"
    254     } elseif $properly {
    255         puts \"(return [tclListToScmList $result])\"
    256     } else {
    257         puts \"(return \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $result]\\\")\"
    258     }
    259     flush stdout
    260 }
    261 ")
     193     (apply string-append
     194            (apply append
     195                   (map (lambda (s)
     196                          (list s (string #\newline)))
     197'("package require Tk"
     198"if {[package version tile] != \"\"} {"
     199"    package require tile"
     200"}"
     201""
     202"namespace eval AutoName {"
     203"    variable c 0"
     204"    proc autoName {{result \\#\\#}} {"
     205"        variable c"
     206"        append result [incr c]"
     207"    }"
     208"    namespace export *"
     209"}"
     210""
     211"namespace import AutoName::*"
     212""
     213"proc callToScm {callKey args} {"
     214"    global scmVar"
     215"    set resultKey [autoName]"
     216"    puts \"(call $callKey \\\"$resultKey\\\" $args)\""
     217"    flush stdout"
     218"    vwait scmVar($resultKey)"
     219"    set result $scmVar($resultKey)"
     220"    unset scmVar($resultKey)"
     221"    set result"
     222"}"
     223""
     224"proc tclListToScmList {l} {"
     225"    switch [llength $l] {"
     226"        0 {"
     227"            return ()"
     228"        }"
     229"        1 {"
     230"            if {[string range $l 0 0] eq \"\\#\"} {"
     231"                return $l"
     232"            }"
     233"            if {[regexp {^[0-9]+$} $l]} {"
     234"                return $l"
     235"            }"
     236"            if {[regexp {^[.[:alpha:]][^ ,\\\"\\'\\[\\]\\\\;]*$} $l]} {"
     237"                return $l"
     238"            }"
     239"            set result \\\""
     240"            append result\\"
     241"                [string map [list \\\" \\\\\\\" \\\\ \\\\\\\\] $l]"
     242"            append result \\\""
     243""
     244"        }"
     245"        default {"
     246"            set result {}"
     247"            foreach el $l {"
     248"                append result \" \" [tclListToScmList $el]"
     249"            }"
     250"            set result [string range $result 1 end]"
     251"            return \"($result)\""
     252"        }"
     253"    }"
     254"}"
     255""
     256"proc evalCmdFromScm {cmd {properly 0}} {"
     257"    if {[catch {"
     258"        set result [uplevel \\#0 $cmd]"
     259"    } err]} {"
     260"        puts \"(error \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $err]\\\")\""
     261"    } elseif $properly {"
     262"        puts \"(return [tclListToScmList $result])\""
     263"    } else {"
     264"        puts \"(return \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $result]\\\")\""
     265"    }"
     266"    flush stdout"
     267"}")))))
    262268
    263269   (report-error error)
     
    306312
    307313; CHICKEN
    308 ; Prelude: (use posix)
    309    (run-program
    310      (lambda (program)
    311        (let-values
    312          (((in out pid) (process (string-append "exec " program " 2>&1"))))
    313          (list in out))))
     314  (run-program
     315    (lambda (program)
     316      (let-values
     317        (((in out pid)
     318          (process (string-append "/bin/sh -c \"exec "
     319                                  program
     320                                  " 2>&1\""))))
     321        (list in out))))
    314322
    315323   (flush-output-port flush-output)
     
    328336
    329337; GAUCHE
    330 ; Prelude: (use gauche.process)
     338;   ; Prelude: (use gauche.process)
    331339;   (run-program
    332340;     (lambda (program)
     
    385393;   (flush-output-port force-output)
    386394
     395; IKARUS
     396;   (run-program
     397;     (lambda (program)
     398;       (let-values (((pid from to errport) (process program)))
     399;         (let ((utf8-transcoder (make-transcoder (utf-8-codec))))
     400;         (list (transcoded-port to   utf8-transcoder)
     401;               (transcoded-port from utf8-transcoder))))))
     402
    387403; KAWA
    388404;   (run-program
     
    409425;   (flush-output-port force-output)
    410426
     427; LARCENY
     428;   ; Prelude: (requirement (require "Standard/unix"))
     429;   (run-program
     430;     (lambda (program)
     431;       (let* ((in/out/pid (process
     432;                            (string-append "/bin/sh -c \"exec "
     433;                                           program
     434;                                           " 2>&1\"")))
     435;               (in  (car  in/out/pid))
     436;               (out (cadr in/out/pid))
     437;               (utf8-transcoder (make-transcoder (utf-8-codec))))
     438;         (list (transcoded-port in  utf8-transcoder)
     439;               (transcoded-port out utf8-transcoder)))))
     440
    411441; MZSCHEME / Unix
    412442;   (run-program
     
    431461;   (flush-output-port flush-output)
    432462
     463; Scheme 9 from Empty Space
     464;   ; Requires SYS Extension
     465;   (run-program
     466;      (lambda (program)
     467;        (sys:spawn (string-append "exec " program " 2>&1"))))
     468;
     469;   (flush-output-port sys:flush)
     470
    433471; SCHEME48
    434 ; Prelude: ,open posix receiving signals i/o
     472;   ; Prelude: ,open posix receiving signals i/o
    435473;   (run-program
    436474;     (lambda (program)
     
    736774                       (else (string-append " +" result)))))
    737775                 ((and (= (length x) 3)
    738                        (equal? (car x) '@)
     776                       (equal? (car x) (string->symbol "@"))
    739777                       (number? (cadr x))
    740778                       (number? (caddr x)))
     
    958996   (ttk-available-themes
    959997     (lambda ()
    960        (string-split #\space (eval-wish "tile::availableThemes"))))
     998       (string-split #\space (eval-wish "ttk::style theme names"))))
    961999
    9621000   (do-wait-for-window
     
    10441082  (set! tk/windowingsystem (make-wish-func "tk windowingsystem"))
    10451083  (set! ttk/available-themes ttk-available-themes)
    1046   (set! ttk/set-theme (make-wish-func "tile::setTheme"))
     1084  (set! ttk/set-theme (make-wish-func "ttk::style theme use"))
     1085  (set! ttk/style (make-wish-func "ttk::style"))
    10471086  (set! ttk-map-widgets map-ttk-widgets))
  • release/3/PS-tk/PS-tk.setup

    r4937 r11920  
    11(include "setup-header")
    22
    3 (install-dynld+docu PS-tk "1.1")
     3(install-dynld+docu PS-tk "1.2")
Note: See TracChangeset for help on using the changeset viewer.