Imported Upstream version 16.6

1 files changed, 140 insertions, 161 deletions

diff --git a/snd-motif.scm b/snd-motif.scm
index a8e5b52..cba0613 100644
--- a/snd-motif.scm
+++ b/snd-motif.scm
@@ -78,7 +78,7 @@
 	  (do ((i 0 (+ i 1)))
 	      ((= i len) new-str)
 	    (let ((c (str i)))
-	      (set! (new-str i) (if (memq c '(#\\ #\/)) #\_ c))))))))
+	      (set! (new-str i) (if (memv c '(#\\ #\/)) #\_ c))))))))
   
   
 ;;; -------- apply func to every widget belonging to w (and w) --------
@@ -164,17 +164,15 @@
 	   ;; (XtGetValues dialog (XmNfileSearchProc 0)) to get the default
 	   (shell (cadr (main-widgets)))
 	   (tags (list "one" "two" "three" "four"))
-	   (colors (list "black" "red" "blue" "orange"))
 	   (pixels (let* ((dpy (XtDisplay shell))
-			  (scr (DefaultScreen dpy))
-			  (cmap (DefaultColormap dpy scr)))
+			  (cmap (DefaultColormap dpy (DefaultScreen dpy))))
 		     (map
 		      (lambda (color)
 			(let ((col (XColor)))
 			  (if (= (XAllocNamedColor dpy cmap color col col) 0)
 			      (snd-error (format #f "can't allocate ~A" color))
 			      (.pixel col))))
-		      colors)))
+		   '("black" "red" "blue" "orange"))))
 	   (rendertable (XmRenderTableAddRenditions 
 			 #f 
 			 (map (lambda (tag pix)
@@ -345,10 +343,7 @@
   (define add-listener-pane 
     (let ((documentation "(add-listener-pane name type args) adds a widget at the top of the listener"))
       (lambda (name type args)
-	(let* ((listener (find-child (cadr (main-widgets)) "lisp-listener"))
-	       ;; this is the listener text widget, hopefully
-	       ;;   its parent is the scrolled window, its parent is the form widget filling the listener pane
-	       (listener-scroll (XtParent listener))
+	(let* ((listener-scroll (XtParent (find-child (cadr (main-widgets)) "lisp-listener")))
 	       (listener-form (XtParent listener-scroll)))
 	  ;; to insert the new widget at the top of the listener pane we need to detach the
 	  ;;   listener scrolled window etc -- assume here that the "args" list does not
@@ -1147,8 +1142,7 @@
 				     ;; this is the procedure to be called when the update is done
 				     (do ((i 0 (+ i 1)))
 					 ((= i (channels updated-snd)))
-				       (make-mark-list updated-snd i))))))
-    )
+				       (make-mark-list updated-snd i)))))))
   
   
 ;;; -------- select-file --------
@@ -1224,9 +1218,7 @@
 			     (XtSetValues (XtNameToWidget new-dialog "OK")
 					  (list XmNarmColor *selection-color*))
 			     new-dialog))))
-	  (if (not help)
-	      (XtUnmanageChild (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON))
-	      (XtManageChild (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON)))
+	  ((if (not help) XtUnmanageChild XtManageChild) (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON))
 	  (let ((patstr (XmStringCreateLocalized filter))
 		(titlestr (XmStringCreateLocalized title)))
 	    (let ((dirstr (XmStringCreateLocalized dir)))
@@ -1530,10 +1522,8 @@
 	  (documentation "(red-pixel) returns a red pixel"))
       (lambda ()
 	(if (not pix)
-	    (let* ((shell (cadr (main-widgets)))
-		   (dpy (XtDisplay shell))
-		   (scr (DefaultScreen dpy))
-		   (cmap (DefaultColormap dpy scr))
+	    (let* ((dpy (XtDisplay (cadr (main-widgets))))
+		   (cmap (DefaultColormap dpy (DefaultScreen dpy)))
 		   (col (XColor)))
 	      (if (= (XAllocNamedColor dpy cmap "red" col col) 0)
 		  (snd-error "can't allocate red!")
@@ -1720,8 +1710,8 @@
     (let ((documentation "(make-channel-drop-site snd) adds a drop site pane to the current channel"))
       (lambda args
 	(let* ((snd (if (pair? args) (car args) (selected-sound)))
-	       (chn (selected-channel snd))
-	       (widget (add-channel-pane snd chn "drop here" xmDrawingAreaWidgetClass
+	       (widget (add-channel-pane snd (selected-channel snd)
+					 "drop here" xmDrawingAreaWidgetClass
 					 (list XmNbackground (white-pixel)
 					       XmNleftAttachment      XmATTACH_FORM
 					       XmNrightAttachment     XmATTACH_FORM
@@ -1791,15 +1781,14 @@
   (define show-disk-space
     (let ((labelled-snds ()))
       (define (kmg num)
-	(cond ((<= num 0)      "disk full!")
+	(cond ((<= num 0)      (copy "disk full!"))
 	      ((<= num 1024)   (format #f "space: ~10DK" num))
 	      ((> num 1048576) (format #f "space: ~6,3FG" (/ num (* 1024.0 1024.0))))
 	      (else            (format #f "space: ~6,3FM" (/ num 1024.0)))))
 		
       (define (show-label data id)
 	(if (sound? (car data))
-	    (let* ((space (kmg (disk-kspace (file-name (car data)))))
-		   (str (XmStringCreateLocalized space)))
+	    (let ((str (XmStringCreateLocalized (kmg (disk-kspace (file-name (car data)))))))
 	      (XtSetValues (cadr data) (list XmNlabelString str))
 	      (XmStringFree str)
 	      (XtAppAddTimeOut (caddr data) 10000 show-label data))))
@@ -1817,8 +1806,7 @@
 			 (unite-button (widgets 6))
 			 (sync-button (widgets 9))
 			 (name-form (XtParent status-area)) ; "snd-name-form"
-			 (space (kmg (disk-kspace (file-name snd))))
-			 (str (XmStringCreateLocalized space)))
+			 (str (XmStringCreateLocalized (kmg (disk-kspace (file-name snd))))))
 		    (set! showing-disk-space #t)
 		    (XtUnmanageChild status-area)
 		    (XtVaSetValues status-area (list XmNrightAttachment XmATTACH_NONE))
@@ -1850,9 +1838,9 @@
     (let ((documentation "(add-amp-controls) adds amplitude sliders to the control panel for each channel in multi-channel sounds"))
       (lambda ()
 	
-	(define (label-name chan) (if (= chan 0) "amp-label" (format #f "amp-label-~D" chan)))
-	(define (number-name chan) (if (= chan 0) "amp-number" (format #f "amp-number-~D" chan)))
-	(define (scroller-name chan) (if (= chan 0) "amp" (format #f "amp-~D" chan)))
+	(define (label-name chan) (if (= chan 0) (copy "amp-label") (format #f "amp-label-~D" chan)))
+	(define (number-name chan) (if (= chan 0) (copy "amp-number") (format #f "amp-number-~D" chan)))
+	(define (scroller-name chan) (if (= chan 0) (copy "amp") (format #f "amp-~D" chan)))
 	
 	(define (amp-callback w c info)
 	  ;; c is (list number-widget snd chan)
@@ -1865,16 +1853,13 @@
 	  (let* ((snd (cadr c))
 		 (amp (scroll->amp snd (.value info)))
 		 (ampstr (XmStringCreateLocalized (format #f "~,3F " amp)))
-		 (top-chn (- (channels snd) 1))
-		 (chn (- top-chn (caddr c)))
+		 (chn (- (channels snd) 1 (caddr c)))
 		 (ctrl (and (.event info) (not (= (logand (.state (.event info)) ControlMask) 0)))))
 	    (XtSetValues (car c) (list XmNlabelString ampstr))
 	    (XmStringFree ampstr)
 	    (if ctrl
-		(let* ((wids (sound-widgets snd))
-		       (ctrls (wids 2))
-		       (snd-amp (find-child ctrls "snd-amp"))
-		       (chns (channels snd)))
+		(let ((snd-amp (find-child ((sound-widgets snd) 2) "snd-amp"))
+		      (chns (channels snd)))
 		  (do ((i 0 (+ i 1)))
 		      ((= i chns))
 		    (let* ((ampscr (find-child snd-amp (scroller-name i)))
@@ -1945,8 +1930,7 @@
 	      (XmStringFree s2)
 	      label))
       
-	  (let* ((wids (sound-widgets snd))
-		 (ctrls (wids 2))
+	  (let* ((ctrls ((sound-widgets snd) 2))
 		 (snd-amp (find-child ctrls "snd-amp"))
 		 (chns (channels snd)))
 	    
@@ -2010,10 +1994,8 @@
 	
 	(define (amp-controls-clear snd)
 	  (if (> (channels snd) 1)
-	      (let* ((wids (sound-widgets snd))
-		     (ctrls (wids 2))
-		     (snd-amp (find-child ctrls "snd-amp"))
-		     (top (- (channels snd) 1)))
+	      (let ((snd-amp (find-child ((sound-widgets snd) 2) "snd-amp"))
+		    (top (- (channels snd) 1)))
 		(do ((i 1 (+ i 1)))
 		    ((= i (channels snd)))
 		  (let ((ampn (find-child snd-amp (number-name i)))
@@ -2139,9 +2121,7 @@
 			       (XtAddEventHandler rename-text LeaveWindowMask #f
 						  (lambda (w context ev flag)
 						    (XtSetValues w (list XmNbackground *basic-color*)))))))
-			 (if (not (XtIsManaged rename-dialog))
-			     (XtManageChild rename-dialog)
-			     (raise-dialog rename-dialog)))
+			 ((if (not (XtIsManaged rename-dialog)) XtManageChild raise-dialog) rename-dialog))
 		       8)))))
   
   
@@ -2174,8 +2154,7 @@
 	  (lambda (color-name)
 	    (let* ((col (XColor))
 		   (dpy (XtDisplay (cadr (main-widgets))))
-		   (scr (DefaultScreen dpy))
-		   (cmap (DefaultColormap dpy scr)))
+		   (cmap (DefaultColormap dpy (DefaultScreen dpy))))
 	      (if (= (XAllocNamedColor dpy cmap color-name col col) 0)
 		  (snd-error (format #f "can't allocate ~A" color-name))
 		  (.pixel col)))))
@@ -2233,46 +2212,46 @@
 	    (if (and tooltip-shell (XtIsManaged tooltip-shell))
 		(XtUnmanageChild tooltip-shell)))
 	  
-	  (define start-tooltip 
-	    (let ((quittime 3000) ; millisecs to show tip (if pointer not already moved out of widget)
-		  (timeout 500))   ; millisecs after mouse enters widget to tip display 
-	      (lambda (ev)
-		(if (and *with-tooltips*
-			 (not tool-proc))
-		    (set! tool-proc (XtAppAddTimeOut 
-				     (car (main-widgets))
-				     timeout 
-				     (lambda (data id)
-				       (if tooltip-shell
-					   (change-label tooltip-label tip)
-					   (begin
-					     (set! tooltip-shell (XtCreatePopupShell 
-								  tip 
-								  overrideShellWidgetClass 
-								  (cadr (main-widgets)) 
-								  (list XmNallowShellResize #t)))
-					     (set! tooltip-label
-						   (XtCreateManagedWidget 
-						    tip
-						    xmLabelWidgetClass 
-						    tooltip-shell
-						    (list XmNrecomputeSize #t
-							  XmNbackground *highlight-color*)))))
-				       (let ((loc (XtTranslateCoords widget (.x ev) (.y ev))))
-					 (XtVaSetValues tooltip-shell (list XmNx (car loc) XmNy (cadr loc))))
-				       (XtManageChild tooltip-shell)
-				       (set! quit-proc (XtAppAddTimeOut
-							(car (main-widgets))
-							quittime
-							(lambda (data id)
-							  (XtUnmanageChild tooltip-shell)
-							  (set! quit-proc #f)))))))))))
-	  
-	  (XtAddEventHandler widget EnterWindowMask #f 
-			     (lambda (w c ev flag)
-			       (if (> (- (cadr (.time ev)) last-time) 50)
-				   (start-tooltip ev))
-			       (set! last-time (cadr (.time ev)))))
+	  (let ((start-tooltip 
+		 (let ((quittime 3000) ; millisecs to show tip (if pointer not already moved out of widget)
+		       (timeout 500))   ; millisecs after mouse enters widget to tip display 
+		   (lambda (ev)
+		     (if (and *with-tooltips*
+			      (not tool-proc))
+			 (set! tool-proc (XtAppAddTimeOut 
+					  (car (main-widgets))
+					  timeout 
+					  (lambda (data id)
+					    (if tooltip-shell
+						(change-label tooltip-label tip)
+						(begin
+						  (set! tooltip-shell (XtCreatePopupShell 
+								       tip 
+								       overrideShellWidgetClass 
+								       (cadr (main-widgets)) 
+								       (list XmNallowShellResize #t)))
+						  (set! tooltip-label
+							(XtCreateManagedWidget 
+							 tip
+							 xmLabelWidgetClass 
+							 tooltip-shell
+							 (list XmNrecomputeSize #t
+							       XmNbackground *highlight-color*)))))
+					    (let ((loc (XtTranslateCoords widget (.x ev) (.y ev))))
+					      (XtVaSetValues tooltip-shell (list XmNx (car loc) XmNy (cadr loc))))
+					    (XtManageChild tooltip-shell)
+					    (set! quit-proc (XtAppAddTimeOut
+							     (car (main-widgets))
+							     quittime
+							     (lambda (data id)
+							       (XtUnmanageChild tooltip-shell)
+							       (set! quit-proc #f))))))))))))
+	    
+	    (XtAddEventHandler widget EnterWindowMask #f 
+			       (lambda (w c ev flag)
+				 (if (> (- (cadr (.time ev)) last-time) 50)
+				     (start-tooltip ev))
+				 (set! last-time (cadr (.time ev))))))
 	  (XtAddEventHandler widget LeaveWindowMask #f 
 			     (lambda (w c ev flag) 
 			       (set! last-time (cadr (.time ev)))
@@ -2328,83 +2307,83 @@
 	  (listener-text ((main-widgets) 4))
 	  (snd-app (car (main-widgets))))
       (lambda ()
-
-	(define start-dialog
-	  (let ((shell (cadr (main-widgets)))
-		(dialog #f)	
-		(find-new #t)
-		(find-text #f))
-	    (lambda ()
-	      (unless dialog
-		(let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
-		      (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
-		      (xfind (XmStringCreate "Find" XmFONTLIST_DEFAULT_TAG)))
-		  (set! dialog (XmCreateMessageDialog shell
-						      "Find"
-						      (list XmNcancelLabelString   xdismiss
-							    XmNokLabelString       xfind
-							    XmNhelpLabelString     xhelp
-							    XmNautoUnmanage        #f
-							    XmNresizePolicy        XmRESIZE_GROW
-							    XmNnoResize            #f
-							    XmNtransient           #f
-							    XmNbackground          *basic-color*)))
-		  (for-each
-		   (lambda (button color)
-		     (XtVaSetValues (XmMessageBoxGetChild dialog button)
-				    (list XmNarmColor   *selection-color*
-					  XmNbackground color)))
-		   (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
-		   (list *highlight-color* *highlight-color* *highlight-color*))
-		  (XtAddCallback dialog XmNcancelCallback (lambda (w context info) (XtUnmanageChild dialog)))
-		  (XtAddCallback dialog XmNhelpCallback (lambda (w context info) (help-dialog "Find" "no help yet")))
-		  (XtAddCallback dialog XmNokCallback (lambda (w context info)
-							(let* ((search-str (XmTextFieldGetString find-text))
-							       (len (length search-str))
-							       (pos (XmTextFindString listener-text
-										      (+ (XmTextGetCursorPosition listener-text)
-											 (if find-new 0 (if find-forward 1 -1)))
-										      search-str
-										      (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
-							  (if (not pos)
-							      (set! pos (XmTextFindString listener-text
-											  (if find-forward 0 (XmTextGetLastPosition listener-text))
-											  search-str
-											  (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
-							  (if (number? pos)
-							      (begin
-								(XmTextSetInsertionPosition listener-text pos)
-								(XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_SELECTED) ; flash the string briefly
-								(XtAppAddTimeOut snd-app 200 
-										 (lambda (context id) 
-										   (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_NORMAL)))))
-							  (set! find-new #f))))
-		  (XmStringFree xhelp)
-		  (XmStringFree xdismiss)
-		  (XmStringFree xfind)
-		  (set! find-text (XtCreateManagedWidget "text" xmTextFieldWidgetClass dialog
-							 (list XmNleftAttachment      XmATTACH_FORM
-							       XmNrightAttachment     XmATTACH_FORM
-							       XmNtopAttachment       XmATTACH_FORM
-							       XmNbottomAttachment    XmATTACH_WIDGET
-							       XmNbottomWidget        (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR)
-							       XmNbackground          *basic-color*)))
-		  (XtAddCallback find-text XmNfocusCallback 
-				 (lambda (w c i)
-				   (XtVaSetValues w (list XmNbackground (WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay shell)))))))
-		  (XtAddCallback find-text XmNlosingFocusCallback (lambda (w c i) (XtSetValues w (list XmNbackground *basic-color*))))
-		  (XtAddCallback find-text XmNvalueChangedCallback (lambda (w c i) (set! find-new #t)))))
-	      (XtManageChild dialog))))
 	
-	(XtAppAddActions snd-app
-			 (list (list "search-forward" 
-				     (lambda args 
-				       (set! find-forward #t)
-				       (start-dialog)))
-			       (list "search-backward"
-				     (lambda args
-				       (set! find-forward #f)
-				       (start-dialog)))))
+	(let ((start-dialog
+	       (let ((shell (cadr (main-widgets)))
+		     (dialog #f)	
+		     (find-new #t)
+		     (find-text #f))
+		 (lambda ()
+		   (unless dialog
+		     (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
+			   (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+			   (xfind (XmStringCreate "Find" XmFONTLIST_DEFAULT_TAG)))
+		       (set! dialog (XmCreateMessageDialog shell
+							   "Find"
+							   (list XmNcancelLabelString   xdismiss
+								 XmNokLabelString       xfind
+								 XmNhelpLabelString     xhelp
+								 XmNautoUnmanage        #f
+								 XmNresizePolicy        XmRESIZE_GROW
+								 XmNnoResize            #f
+								 XmNtransient           #f
+								 XmNbackground          *basic-color*)))
+		       (for-each
+			(lambda (button color)
+			  (XtVaSetValues (XmMessageBoxGetChild dialog button)
+					 (list XmNarmColor   *selection-color*
+					       XmNbackground color)))
+			(list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
+			(list *highlight-color* *highlight-color* *highlight-color*))
+		       (XtAddCallback dialog XmNcancelCallback (lambda (w context info) (XtUnmanageChild dialog)))
+		       (XtAddCallback dialog XmNhelpCallback (lambda (w context info) (help-dialog "Find" "no help yet")))
+		       (XtAddCallback dialog XmNokCallback (lambda (w context info)
+							     (let* ((search-str (XmTextFieldGetString find-text))
+								    (len (length search-str))
+								    (pos (XmTextFindString listener-text
+											   (+ (XmTextGetCursorPosition listener-text)
+											      (if find-new 0 (if find-forward 1 -1)))
+											   search-str
+											   (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
+							       (if (not pos)
+								   (set! pos (XmTextFindString listener-text
+											       (if find-forward 0 (XmTextGetLastPosition listener-text))
+											       search-str
+											       (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
+							       (if (number? pos)
+								   (begin
+								     (XmTextSetInsertionPosition listener-text pos)
+								     (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_SELECTED) ; flash the string briefly
+								     (XtAppAddTimeOut snd-app 200 
+										      (lambda (context id) 
+											(XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_NORMAL)))))
+							       (set! find-new #f))))
+		       (XmStringFree xhelp)
+		       (XmStringFree xdismiss)
+		       (XmStringFree xfind)
+		       (set! find-text (XtCreateManagedWidget "text" xmTextFieldWidgetClass dialog
+							      (list XmNleftAttachment      XmATTACH_FORM
+								    XmNrightAttachment     XmATTACH_FORM
+								    XmNtopAttachment       XmATTACH_FORM
+								    XmNbottomAttachment    XmATTACH_WIDGET
+								    XmNbottomWidget        (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR)
+								    XmNbackground          *basic-color*)))
+		       (XtAddCallback find-text XmNfocusCallback 
+				      (lambda (w c i)
+					(XtVaSetValues w (list XmNbackground (WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay shell)))))))
+		       (XtAddCallback find-text XmNlosingFocusCallback (lambda (w c i) (XtSetValues w (list XmNbackground *basic-color*))))
+		       (XtAddCallback find-text XmNvalueChangedCallback (lambda (w c i) (set! find-new #t)))))
+		   (XtManageChild dialog)))))
+	  
+	  (XtAppAddActions snd-app
+			   (list (list "search-forward" 
+				       (lambda args 
+					 (set! find-forward #t)
+					 (start-dialog)))
+				 (list "search-backward"
+				       (lambda args
+					 (set! find-forward #f)
+					 (start-dialog))))))
 	(XtOverrideTranslations listener-text
 				(XtParseTranslationTable "Ctrl <Key>s: search-forward()
 						        Ctrl <Key>r: search-backward()")))))