mcl 1.3.2 -> System 7-0 crashes

[Karsten Poeck <Karsten_Poeck@ira.uka.de>]

#|

We also have serious problems with MACL 1.3.2 and
system 7.0 (24 bit no virtual memory, no inits or extensions) 
resulting in quiting MACL with error 25
(out of memory)

We managed to identify 2 situations for the crashes

1) Calling window-close as the action of a button 
within a user-defined-dialog when at least 1 
other dialog of this kind is open.

2) Calling choose-new-file-dialog or choose-file dialog
when at least 2 user-defined-dialogs are open

The patch for this crashes just selects the listener
before the call to window-close, choose-new-file-dialog
choose-file-dialog, calls the function and then deselects the listener

poeck@ira.uka.de

|#
;sample code to demonstrate the crashes

(defobject *crash-dialog* *dialog*)

(defobfun (exist *crash-dialog*)(egal)
  (usual-exist egal)
  (add-dialog-items
   (oneof *button-dialog-item*
          :dialog-item-position (make-point 0 0)
          :dialog-item-size (make-point 100 20)
          :dialog-item-text "Crash"
          :dialog-item-action #'(lambda()
                                  (ask my-dialog
                                    (window-close))))))

(progn
  (oneof *crash-dialog*)
  
  (oneof *crash-dialog*)
  
  ;click on the crash button
  )

;--> error 25

or 

(progn
  (oneof *crash-dialog*)
  
  (oneof *crash-dialog*)
  
  (choose-file-dialog)
  )

;--> error 25



;Patch code against the crashes


(defun b=system7-p ()
  (let* ((text (software-version))
         (Position-Macintosh (search "Macintosh" text :test #'string=))
         (Position-Bindestrich (search "-" text :test #'string= :start2
Position-Macintosh))
         (Versionsnummer (subseq text (1+ Position-Bindestrich) (+
Position-Bindestrich 2))))
    (string= Versionsnummer "7")))

(when (b=system7-p)
 
;******************************************************************************
******
  ;                      Patchfunktionen selbst
 
;******************************************************************************
******
  
  (defun patch-dateiauswahl-vorher ()
    (let ((listener (first (windows *listener*))))
      (when listener
        (ask listener (window-select)))))
  
  (defun patch-Dateiauswahl-nachher ()
    (let ((listener (first (windows *listener*))))
      (when listener
        (ask listener (set-window-layer (length (windows)))))))
  
  
  
 
;******************************************************************************
******
  ;                  Patch von `window-close von einigen CLASSIKA-Fenstern
 
;******************************************************************************
******
  
  
  (defobfun (window-close *crash-dialog*) ()
    (patch-dateiauswahl-vorher)
    (usual-window-close)
    (patch-Dateiauswahl-nachher))
  
  
  
 
;******************************************************************************
******
  ;                      Vergewaltigung
choose-file-dialog,choose-new-file-dialog
 
;******************************************************************************
******
  
  (let ((alt (symbol-function 'choose-file-dialog))
        (ccl::*warn-if-redefine-kernel* nil))
    (setf (symbol-function 'choose-file-dialog)
          #'(lambda(&key (directory :pseudo) 
                         (button-string :pseudo)
                         (mac-file-type :pseudo)
                         (mac-file-creator :pseudo))
              (let ((datei
                     (prog2
                      (patch-dateiauswahl-vorher)
                      (apply alt
                             (b=pseudo-properties-loeschen
                              (list :directory directory
                                    :button-string button-string
                                    :mac-file-type mac-file-type
                                    :mac-file-creator mac-file-creator)))
                      (patch-dateiauswahl-nachher))))
                datei))))
  
  (let ((alt (symbol-function 'choose-new-file-dialog))
        (ccl::*warn-if-redefine-kernel* nil))
    (setf (symbol-function 'choose-new-file-dialog)
          #'(lambda(&key (directory :pseudo) 
                         (prompt :pseudo)
                         (button-string :pseudo))
              (let ((datei
                     (prog2
                      (patch-dateiauswahl-vorher)
                      (apply alt
                             (b=pseudo-properties-loeschen
                              (list :directory directory
                                    :button-string button-string
                                    :prompt prompt)))
                      (patch-dateiauswahl-nachher))))
                datei))))
  
  
  (defun  b=pseudo-properties-loeschen (liste)
    (if (null liste)
      nil
      (if (neq :pseudo (second liste))
        (cons (first liste)
              (cons (second liste)
                    (b=pseudo-properties-loeschen (cddr liste))))
        (b=pseudo-properties-loeschen (cddr liste)))))
  
  )