cm 1.0.0 in MCL 3.1 (68k)

[Tobias Kunze]

I posted the OLD function instead of the fix yesterday, sorry.
Here's the RIGHT code:

(defun %mm-midi-open-aux (int)
  (catch :midi-open-exit
    (setf %mm-close-stack%
          `(,#'(lambda ()
                 (setf %midi-open-p% nil)
                 (%update-midi-menu)
                 (values +midi-success+))))
    (%mm-sign-in)
    (push #'%mm-sign-out %mm-close-stack%)
    (%mm-add-cm-ports)
    (push #'(lambda ()
              (%mm-remove-cm-ports)
              ;; Make sure the pointers held in %inv-outports% can't be
              ;; accessed any more.
              (setf %inv-outports% nil)
              ;; Fight memory leaks and dispose the block %myports-ptr% points
              ;; to, but never dispose a dead pointer.
              (when  %myports-ptr%
                (#_disposeptr %myports-ptr%)
                (setf %myports-ptr% nil))) %mm-close-stack%)
    ;; Check for the availability of drivers and ports. This function also
    ;; sets the globals $driver-id$ and $serial-port$.
    (%mm-get-driver-and-serial-port int)
    (push #'(lambda () (setf $serial-port$ nil $driver-id$ nil))
          %mm-close-stack%)
    (%mm-connect-data $serial-port$)
    (%midi-start-time)
    ;; make sure %midi-open-p% holds the serial port variable
    (setf %midi-open-p% (verbose-find-port $serial-port$))
    (%update-midi-menu)
    (push #'%update-midi-menu %mm-close-stack%)
    ;; Initialize the c side; but close everything again, if it failed.
    (unless (midi-c-setup)
      (throw :midi-open-exit :cancel-midi-open))
    ;; Now make the data area, jump table, function code segment, and our
    ;; structures ineligible for virtual memory page swapping, because
    ;; they will be accessed at interrupt level (avoid a possible fatal
    ;; double page fault error at paging time).
    (let* ((len (length (ccl::ffenv-entries %ff-env%))))

      (mapcar #'(lambda (x) (#_holdmemory x (#_getptrsize x)))
              (list (cdr (elt (ccl::ffenv-entries %ff-env%)
                              (1- len))) ; data & JT
                    (elt (ccl::ffenv-seg-ptrs %ff-env%) 0) ; code segment
                    %myports-ptr%))     ; structures
      (push #'(lambda ()
                ;; Make data & jump table, code segment, and our structures
                ;; eligible for page swapping again
                (mapcar #'(lambda (x) (#_unholdmemory x (#_getptrsize x)))
                        (list (cdr (elt (ccl::ffenv-entries %ff-env%)
                                        (1- len)))
                              (elt (ccl::ffenv-seg-ptrs %ff-env%) 0)))
                ;; ...but the structures only if their pointer is valid.
                (when %myports-ptr%
                  (#_unholdmemory %myports-ptr% (#_getptrsize %myports-ptr%))))
            %mm-close-stack%))
    (values +midi-success+)))