cm 1.0.0 in MCL 3.1 (68k)
Tobias Kunze
t@ulysses.Stanford.EDU
Sun, 12 Jan 1997 14:11:17 -0800
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+)))