BABYL OPTIONS: -*- rmail -*- Version: 5 Labels: Note: This is the header of an rmail file. Note: If you are seeing it in rmail, Note: it means the file has no messages in it.  1, filed,, X-Coding-System: undecided-unix Mail-from: From emarsden@laas.fr Tue Jan 28 04:14:47 2003 Return-Path: Received: from laas.laas.fr (laas.laas.fr [140.93.0.15]) by sarg.ryerson.ca (8.11.2/8.11.2) with ESMTP id h0S9Ejk20172 for ; Tue, 28 Jan 2003 04:14:46 -0500 Received: by laas.laas.fr (8.12.7/8.12.7) with ESMTP id h0S9Eg0i005517; Tue, 28 Jan 2003 10:14:44 +0100 (CET) To: cmwilson@sarg.ryerson.ca Subject: patch: scheme-xp with a modern scsh From: Eric Marsden Organization: LAAS-CNRS http://www.laas.fr/ X-Message-Flags: Insufficient vodka to complete operation X-Eric-Conspiracy: there is no conspiracy X-Attribution: ecm X-URL: http://www.chez.com/emarsden/ Date: Tue, 28 Jan 2003 10:14:42 +0100 Message-ID: Lines: 12 User-Agent: Gnus/5.090004 (Oort Gnus v0.04) Emacs/21.2 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=ASDIC-=-Firewalls-=-Reno-=-TWA-=-smuggle-=-" Sender: Eric Marsden X-Scanned-By: MIMEDefang 2.28 (www . roaringpenguin . com / mimedefang) *** EOOH *** To: cmwilson@sarg.ryerson.ca Subject: patch: scheme-xp with a modern scsh From: Eric Marsden Organization: LAAS-CNRS http://www.laas.fr/ X-Message-Flags: Insufficient vodka to complete operation X-Eric-Conspiracy: there is no conspiracy X-URL: http://www.chez.com/emarsden/ Date: Tue, 28 Jan 2003 10:14:42 +0100 User-Agent: Gnus/5.090004 (Oort Gnus v0.04) Emacs/21.2 Content-Type: multipart/mixed; boundary="=ASDIC-=-Firewalls-=-Reno-=-TWA-=-smuggle-=-" Sender: Eric Marsden X-Scanned-By: MIMEDefang 2.28 (www . roaringpenguin . com / mimedefang) --=ASDIC-=-Firewalls-=-Reno-=-TWA-=-smuggle-=- Hi, I played around with scheme-xp a little recently; very cool stuff!. There have been a few changes to recent versions of scsh that require a few changes to the code (notably the threading and locking); I have appended a not-very-clean patch. --=ASDIC-=-Firewalls-=-Reno-=-TWA-=-smuggle-=- Content-Disposition: attachment; filename=scheme-xp.diff diff -uwr scheme-xp/connection-requests.scm scheme-xp-ecm/connection-requests.scm --- scheme-xp/connection-requests.scm 1999-04-29 21:25:22.000000000 +0200 +++ scheme-xp-ecm/connection-requests.scm 2003-01-26 19:07:38.000000000 +0100 @@ -17,7 +17,7 @@ (define in-path (lambda (fname) - (let loop ((path exec-path-list)) + (let loop ((path (thread-fluid exec-path-list))) (if (null? path) #f (let ((full-name (path-list->file-name @@ -92,26 +92,31 @@ ;;; scshy. +;; if $DISPLAY environment variable is "localhost", we are looking for +;; a FamilyLocal entry in the Xauthority file, and so should be +;; looking for an entry with the current machine's name, rather than +;; an entry for localhost. (define x-authorization + ;; FIXME should really look at $XAUTHORITY environment variable (let ((xauthority-file ".Xauthority") (xauth-prog "xauth")) - (lambda (hostname screen) + (lambda (hostname display screen) (if (let ((xauth (in-path xauth-prog))) (not (and (file-readable? (home-file xauthority-file)) (exists-and-executable? xauth)))) (begin (format #t "~a not found; trying dummy values~%" xauthority-file) (values "" "")) - (let ((screen (number->string screen))) - (let* ((machine (if #f ; fix me -- a portable way? - (string-append hostname "/unix" ":" screen) - (string-append hostname ":" screen))) - (xauth-listing (let ((str (run/string (xauth list ,machine)))) + (let ((display (number->string display))) + (let* ((entry (if (string=? "localhost" hostname) ;; FamilyLocal entry + (string-append (get-hostname) "/unix" ":" display) + (string-append hostname ":" display))) + (xauth-listing (let ((str (run/string (xauth list ,entry)))) (if (string=? str "") (begin (format #t - "host (~a) not in ~a; trying dummy values~%" - machine xauthority-file) - (values "" "")) + "display (~a) not in ~a; trying dummy values~%" + entry xauthority-file) + (list "" "" "")) (let ((list ((infix-splitter) str))) (if (not (>= (length list) 3)) (error "problem parsing xauth information") @@ -128,11 +133,9 @@ (define determine-hostname-display-screen (lambda () (bind ((machine-name display-number screen-number (parse-display-env))) - (values (get-hostname) + (values machine-name ;; (get-hostname) (string->number display-number) - (string->number screen-number) - )))) - + (string->number screen-number))))) ;;;; where it happens @@ -160,7 +163,7 @@ (define make-connection (lambda () (bind ((hostname display-number screen-number (determine-hostname-display-screen)) - (auth-protocol auth-code (x-authorization hostname display-number))) + (auth-protocol auth-code (x-authorization hostname display-number screen-number))) (let* ((xserver-port (+ 6000 display-number)) (xserver (open-xserver-connection hostname xserver-port))) (if (not (xserver? xserver)) diff -uwr scheme-xp/scsh-specific.scm scheme-xp-ecm/scsh-specific.scm --- scheme-xp/scsh-specific.scm 1999-04-28 22:34:59.000000000 +0200 +++ scheme-xp-ecm/scsh-specific.scm 2003-01-26 17:34:34.000000000 +0100 @@ -40,3 +40,12 @@ (map (lambda (c) (number->string (char->ascii c) 2)) (string->list str))))) + + +(define (with-lock lock thunk) + (dynamic-wind + (lambda () + (release-lock lock)) + thunk + (lambda () + (release-lock lock)))) diff -uwr scheme-xp/toys.scm scheme-xp-ecm/toys.scm --- scheme-xp/toys.scm 1999-04-29 22:19:57.000000000 +0200 +++ scheme-xp-ecm/toys.scm 2003-01-26 19:15:36.000000000 +0100 @@ -333,10 +333,8 @@ (loop (read-event connection))) ((button-press-event? event) #t) (else (loop (read-event connection)))))))) - (with-multitasking (lambda () - (spawn connection-thunk)))) - )))))) + (spawn connection-thunk))))))))) ;;;;;;;;;;;;;;;;;;;; @@ -437,14 +435,14 @@ (let draw ((old-x 0) (x 0)) (if (>= x (- window-width size)) (loop (read-event connection)) - (let ((before (time))) + (let ((before 0)) ;; was (time) (copy-area connection clear-pixmap draw-pixmap clear-gc 0 0 old-x y size size) (vector-set! (car rec) 0 x) (poly-fill-rectangle connection draw-pixmap gc rec) (copy-area connection draw-pixmap window gc 0 0 0 0 window-width window-height) - (let ((t (- (time) before))) + (let ((t (- 10 before))) ;; 10 was (time) (when (> t 100) (format #t "possible gc: ~a~%" t))) (draw x (+ x 1))))))) diff -uwr scheme-xp/xprotocol-package.scm scheme-xp-ecm/xprotocol-package.scm --- scheme-xp/xprotocol-package.scm 1999-04-29 22:38:38.000000000 +0200 +++ scheme-xp-ecm/xprotocol-package.scm 2003-01-26 17:56:20.000000000 +0100 @@ -306,7 +306,7 @@ ;;;;;;;;;;;;;;;; (define-structure non-portable non-portable-interface - (open scheme scsh threads defrec-package) + (open scheme scsh locks threads thread-fluids defrec-package) (files scsh-specific)) (define-structure tools tools-interface @@ -348,7 +348,7 @@ (define-structure requests requests-interface ;; will take a little work to squeeze non-portabilities out of connection-requests (open scheme non-portable scsh tools set xserver basic-datatypes - structure-datatypes xserver-read) + thread-fluids structure-datatypes xserver-read) (files connection-requests create-gc-request create-window-request requests)) (define-structure helpers helpers-interface @@ -370,9 +370,9 @@ (files test)) (define-structure toys toys-interface - (open scheme scheme-xp formats threads) + (open scheme scheme-xp formats non-portable locks threads) (files toys)) (define-structure frog (export froggy) - (open scheme scheme-xp scsh defrec-package tools threads sleep fluids random) + (open scheme scheme-xp scsh defrec-package tools locks threads sleep fluids random) (files frog)) --=ASDIC-=-Firewalls-=-Reno-=-TWA-=-smuggle-=- -- Eric Marsden --=ASDIC-=-Firewalls-=-Reno-=-TWA-=-smuggle-=---