;;; ========================================================================
;;; Copyright (C) 1998-2001 by Tobias Kunze Briseņo. All Rights Reserved.
;;;
;;; This library and its accompanying code is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU Library
;;; General Public License as published by the Free Software Foundation;
;;; either version 2 of the License, or (at your option) any later version.
;;;
;;; This code is distributed WITHOUT ANY WARRANTY, in particular without
;;; the warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU Library General Public License for more details.
;;;
;;; Suggestions, comments, or bug reports are welcome. Please visit the
;;; project site at
;;; ========================================================================
;;;
;;;
;;; Summary: Mi_D Lisp API
;;;
;;; Description:
;;;
;;; Bugs:
;;;
;;;
;;; $Source: /cvsroot/mi-d/mi_d/include/mi_d.lisp,v $
;;; $Revision: 1.2 $
;;; $Date: 2001/05/05 03:01:02 $
(eval-when (:compile-toplevel :load-toplevel :execute)
#-(or (and excl (or sgi linux))
(and mcl powerpc))
(error "Mi_D is not supported for this machine/Lisp implementation!"))
#+excl
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :foreign))
(defpackage mi_d
(:use :common-lisp #+excl :ff #+mcl :ccl))
(in-package :mi_d)
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :mi_d *features*))
#+mcl
(eval-when (:load-toplevel :compile-toplevel :execute)
(ccl::add-to-shared-library-search-path "Mi_D Library PPC (MCL)"))
(eval-when (:load-toplevel :execute)
(export '(;; Result Codes and Constants
+no-err+ +err+ +out-of-memory+ +out-of-bounds+
+undefined-flag+ +no-such-mapping+ +illegal-value+
+illegal-value+ +environment-changed+
+no-interfaces+ +no-such-interface+
+unknown-selector+
with-result-checked
+max-channels+ +max-interface-name-length+ +max-client-name-length+
+message-buffer-length+ +sysex-buffer-line-length+
+nr-of-info-selectors+
+enc-route-byte+ +enc-lower-status-byte+ +enc-upper-status-byte+
+enc-swapped-status-byte+ +enc-logical-channel-byte+
+enc-opcode-byte+ +enc-data-1-byte+ +enc-data-2-byte+
+enc-route-offs+ +enc-lower-status-offs+ +enc-upper-status-offs+
+enc-swapped-status-offs+ +enc-logical-channel-offs+
+enc-opcode-offs+ +enc-data-1-offs+ +enc-data-2-offs+
+enc-note-off-mask+
;; API
version
open-midi close-midi
update-system-info
print-environment
get-environment-info
check-environment
add-chanmap-mapping
clear-chanmap-mapping
clear-chanmap
add-routemap-mapping
clear-routemap-mapping
clear-routemap
standard-maps
connect
write-message_3c
write-message_el
refcounter refcounterp make-refcounter refcounter-value
write-sysex
write-note_3c
write-note_el
read-messages_3c
read-messages_el
input-message_3c
input-message_el
input-sysex
flush-input
flush-output
all-notes-off
hush
start-timer
stop-timer
get-time
set-time
print-message_3c
print-message_el
print-sysex-data
get-error-string
;; Utils
make-sysex-data
#+mcl oms-open-cur-studio-setup
#+mcl oms-open-midi-setup-dialog
)
:mi_d))
;;;
;;; Defentry
;;; --------
;;; Generic entry point definition workhorse. :compile-time-too encloses the
;;; definition in an eval-when (:compile-toplevel :load-toplevel :execute)
;;; form.
(defmacro defentry (lisp-name c-name args-and-result &key
(compile-time-too nil)
(arg-checking t) (prototype t)
(call-direct t) (callback nil))
(let ((form #+excl
`(defforeign ',lisp-name :entry-point ,c-name
:arguments ',(first args-and-result)
:return-type ,(second args-and-result)
:arg-checking ,arg-checking :prototype ,prototype
:call-direct ,call-direct :callback ,callback)
#+mcl
`(define-entry-point (,lisp-name ("Mi_D Library PPC (MCL)" ,c-name))
,(first args-and-result)
,(second args-and-result))))
#+mcl
`(declare (unused ,arg-checking ,prototype ,call-direct ,callback))
(if compile-time-too
(list 'eval-when '(:compile-toplevel :load-toplevel :execute)
`,form)
form)))
;;;
;;; Signal Utility
;;; --------------
(defentry %get-error-string "mi_dGetErrorString"
#+excl ((fixnum)
:fixnum)
#+mcl (((code :long))
:ptr)
:compile-time-too t)
(defun get-error-string (code)
#+excl (char*-to-string (%get-error-string code))
#+mcl (%get-cstring (%get-error-string code)))
(defun signal-result (var c-fun &optional error-p)
(funcall (if error-p #'error #'warn)
"~a returned ~a" c-fun
(get-error-string var))
nil)
(defmacro with-result-checked (c-fun &optional (error-p t))
(let ((var (gensym)))
`(let* ((,var ,c-fun))
(if (or (not ,var)
(= ,var +no-err+))
t
(signal-result ,var ',c-fun ,error-p)))))
;;; ==========================================================================
;;;
;;; API Result Codes and Constants
;;;
(defconstant +no-err+ 0)
(defconstant +err+ -1)
(defconstant +out-of-memory+ -3)
(defconstant +out-of-bounds+ -100)
(defconstant +undefined-flag+ -102)
(defconstant +no-such-mapping+ -103) ; called "mi_dNullHandle" in C
(defconstant +illegal-value+ -104)
(defconstant +environment-changed+ -110)
(defconstant +no-interfaces+ -111)
(defconstant +no-such-interface+ -112)
(defconstant +unknown-selector+ -113)
;;;
;;; Limits
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +max-channels+ 16) ; Max. Midi Channels
(defconstant +max-client-name-length+ 32) ; Max. Client C String
(defconstant +max-interface-name-length+ 64) ; Max. Interface C String
(defconstant +message-buffer-length+ 80) ; Length of Message Printout
(defconstant +sysex-buffer-line-length+ 68) ; Line Length of Sysex Printout
)
;;;
;;; Pointer Constants (Private)
#+excl
(progn
(defconstant +ptr-to-0+ 0)
(defconstant +ptr-to-1+ 1)
(defconstant +ptr-to-2+ 2)
)
#+mcl
(eval-when (:load-toplevel :compile-toplevel :execute)
(defvar +ptr-to-0+ nil)
(defvar +ptr-to-1+ nil)
(defvar +ptr-to-2+ nil)
(defun %load-+ptrs+ ()
(unless (macptrp +ptr-to-0+) (setf +ptr-to-0+ (%int-to-ptr 0)))
(unless (macptrp +ptr-to-1+) (setf +ptr-to-1+ (%int-to-ptr 1)))
(unless (macptrp +ptr-to-2+) (setf +ptr-to-2+ (%int-to-ptr 2))))
(%load-+ptrs+)
)
;;; ==========================================================================
;;;
;;; Mi_D Version
;;;
;;; Always available and safe to call.
;;;
;;; version
;;; -------
;;; Returns the Mi_D version string and up to five values representing major
;;; version number, minor version number, release number, release status (if
;;; any) and its serial number (if any). Release status may be
;;; :development, :alpha or :beta.
(defentry %version "mi_dVersion"
#+excl (()
:integer)
#+mcl (()
:unsigned-long)
:compile-time-too t)
(defun version ()
(let* ((v (%version))
(major (+ (* (ldb (byte 4 28) v) 10) (ldb (byte 4 24) v)))
(minor (+ (* (ldb (byte 4 20) v) 10) (ldb (byte 4 16) v)))
(rel (+ (* (ldb (byte 4 12) v) 10) (ldb (byte 4 8) v)))
(status (ldb (byte 4 4) v))
(seq (ldb (byte 4 0) v)))
(values (format nil "~d.~d.~d~:[~;~:*~c~:[~;~:*~d~]~]"
major minor rel
(case status (0 nil) (1 #\b) (2 #\a) (3 #\d)
(t (warn "unknown status flag ~d" status)))
(if (zerop seq) nil seq))
major minor rel
(case status
(0 nil) (1 :beta) (2 :alpha) (3 :development) (t status))
(case seq
(0 nil) (t (if (zerop status) nil seq))))))
;;; ==========================================================================
;;;
;;; Opening/Closing MIDI
;;;
;;; Always available and safe to call.
;;;
;;; open-midi
;;; ---------
(defentry %open-midi "mi_dOpen"
#+excl ((string fixnum fixnum fixnum integer integer)
:fixnum)
#+mcl (((n :string) (ml :unsigned-short) (mr :unsigned-short) ;
(mc :unsigned-short) (mm :unsigned-integer)
(qs :unsigned-integer))
:integer)
:call-direct nil
:compile-time-too t)
(defun open-midi (client-name max-lchannels max-routes max-connections
max-mappings queue-size)
(let ((err #+excl
(%open-midi client-name max-lchannels max-routes
max-connections max-mappings queue-size)
#+mcl
(with-cstrs ((s client-name))
(%open-midi s max-lchannels max-routes
max-connections max-mappings queue-size))))
(when (= err +no-err+)
(enable-io-calls))
err))
;;;
;;; close-midi
;;; ----------
(defentry %close-midi "mi_dClose"
#+excl (()
:void)
#+mcl (()
nil)
:compile-time-too t)
(defun close-midi ()
(%close-midi)
(disable-io-calls)
nil)
;;; ==========================================================================
;;;
;;; MIDI environment
;;;
;;; The C side checks whether MIDI is open or not.
;;;
;;; update-system-info
;;; ------------------
(defentry update-system-info "mi_dUpdateSystemInfo"
#+excl (()
:fixnum)
#+mcl (()
:integer))
;;;
;;; print-environment
;;; -----------------
(defentry %print-environment "mi_dPrintEnvironment"
#+excl ((integer fixnum)
:void)
#+mcl (((stream :pointer) (verbosity :integer))
nil)
:compile-time-too t)
;;; FIXME_DOC: stream arg is different from C
(defun print-environment (&optional (stream :stderr) (verbosity 1))
(setf stream (ecase stream (:stdout +ptr-to-1+) (:stderr +ptr-to-2+)))
(ecase verbosity (0) (1) (2))
(%print-environment stream verbosity))
;;;
;;; get-environment-info
;;; --------------------
(defentry %get-environment-info "mi_dGetEnvironmentInfo"
#+excl ((integer fixnum)
:fixnum)
#+mcl (((morsels :pointer) (n :unsigned-integer))
:integer)
:compile-time-too t)
;;;
;;; Info Structure (Private).
#+excl
(def-c-type (info-struct :in-foreign-space) :struct
(param :int)
(val :union
(ui :unsigned-int)
(ptr * :long)) ; actually void*
(err :int))
#+mcl
(eval-when (:load-toplevel :compile-toplevel :execute)
(defrecord (info-struct :pointer) ; we compile with 4-byte ints!
(param :long)
(:variant ((ui :unsigned-long))
((ptr :pointer)))
(err :long))
(defun make-info-struct () (make-record info-struct))
(defmacro info-struct-param (is) `(pref ,is (info-struct.param)))
(defmacro info-struct-val-ui (is) `(pref ,is (info-struct.ui)))
(defmacro info-struct-val-ptr (is) `(pref ,is (info-struct.ptr)))
(defmacro info-struct-err (is) `(pref ,is (info-struct.err)))
)
;;;
;;; Global argument structure used by get-environment-info
#-mcl
(defconstant +info-morsel+ (make-info-struct))
#+mcl
(eval-when (:load-toplevel :compile-toplevel :execute)
(defvar +info-morsel+ nil)
(defun %load-+info-morsel+ ()
(unless (macptrp +info-morsel+) (setf +info-morsel+ (make-info-struct))))
(%load-+info-morsel+)
)
;;;
;;; Environment Info Selectors
(eval-when (:load-toplevel :execute)
(setf
(get :mi_d-max-logical-channels :code) 0
(get :mi_d-max-logical-channels :result-type) :unsigned-int
(get :mi_d-max-routes :code) 1
(get :mi_d-max-routes :result-type) :unsigned-int
(get :mi_d-max-connections :code) 2
(get :mi_d-max-connections :result-type) :unsigned-int
(get :mi_d-max-map-cells :code) 3
(get :mi_d-max-map-cells :result-type) :unsigned-int
(get :mi_d-map-cells-in-use :code) 4
(get :mi_d-map-cells-in-use :result-type) :unsigned-int
(get :mi_d-queue-size :code) 5
(get :mi_d-queue-size :result-type) :unsigned-int
(get :mi_d-nr-of-interfaces :code) 6
(get :mi_d-nr-of-interfaces :result-type) :unsigned-int
(get :mi_d-interface-info :code) 7
(get :mi_d-interface-info :result-type) :mi_dInterface**
(get :mi_d-interface-info :requires) :mi_d-nr-of-interfaces
(get :mi_d-input-interfaces :code) 8
(get :mi_d-input-interfaces :result-type) :mi_dInterface**
(get :mi_d-input-interfaces :requires) :mi_d-max-connections
(get :mi_d-output-interfaces :code) 9
(get :mi_d-output-interfaces :result-type) :mi_dInterface**
(get :mi_d-output-interfaces :requires) :mi_d-max-connections
(get :mi_d-channel-map :code) 10
(get :mi_d-channel-map :result-type) :mi_dMapCell**
(get :mi_d-channel-map :requires) :mi_d-max-logical-channels
(get :mi_d-inv-channel-map :code) 11
(get :mi_d-inv-channel-map :result-type) :mi_dMapCell**
(get :mi_d-inv-channel-map :requires) :mi_d-max-routes
(get :mi_d-route-map :code) 12
(get :mi_d-route-map :result-type) :mi_dMapCell**
(get :mi_d-route-map :requires) :mi_d-max-routes
(get :mi_d-inv-route-map :code) 13
(get :mi_d-inv-route-map :result-type) :mi_dMapCell**
(get :mi_d-inv-route-map :requires) :mi_d-max-connections
))
(defconstant +nr-of-info-selectors+ 14) ; Utility Constant
;;;
;;; Interface Structure (Private)
(eval-when (:compile-toplevel :load-toplevel :execute)
(eval
#+excl
`(def-c-type (interface-struct :in-foreign-space :no-constructor) :struct
(name ,+max-interface-name-length+ :char)
(direction :int))
#+mcl
(defrecord interface-struct
(name (:string +max-interface-name-length+))
(direction :integer))))
;;; These are functions (read-only, i.e., not setf-able)
#+mcl
(defun interface-struct-name (is)
(pref is (interface-struct.name)))
#+mcl
(defun interface-struct-direction (is)
(pref is (interface-struct.direction)))
;;;
;;; MapCell Structure (Private)
#+excl
(def-c-type (map-cell-struct :in-foreign-space :no-constructor) :struct
(val :union
(lchan :unsigned-short)
(rchan :struct
(route :unsigned-short)
(chan :unsigned-short))
(conn :unsigned-short)
(route :unsigned-short))
(next * :long)) ; actually mi_dMapCell*
#+mcl
(progn
(defrecord (%rchan :pointer)
(route :unsigned-short)
(chan :unsigned-short))
(defrecord (map-cell-struct :pointer)
(:variant ((lchan :unsigned-short))
((rchan %rchan :include t))
((conn :unsigned-short))
((route :unsigned-short)))
(next :pointer))
(defmacro map-cell-struct-val-lchan (c)
`(pref ,c (map-cell-struct.lchan)))
(defmacro map-cell-struct-val-rchan-route (c)
`(pref ,c (map-cell-struct.rchan.route)))
(defmacro map-cell-struct-val-rchan-chan (c)
`(pref ,c (map-cell-struct.rchan.chan)))
(defmacro map-cell-struct-val-conn (c)
`(pref ,c (map-cell-struct.conn)))
(defmacro map-cell-struct-val-route (c)
`(pref ,c (map-cell-struct.route)))
(defmacro map-cell-struct-next (c)
`(pref ,c (map-cell-struct.next)))
)
;;;
;;; Generic Reader for Arrays of Pointers (Private).
;;; ACL does not perform a bounds check, so a dimension of 1 is enough.
#+excl
(def-c-type (*ptr-aref :in-foreign-space :no-constructor) 1 * :long)
#+mcl
(defun *ptr-aref (macptr i)
(%get-ptr macptr (* i 4))) ; mac pointers are 4 bytes long
;;; Some selectors require dimension information in order to translate them
;;; to Lisp. Thus, we just get them automatically, no matter whether the
;;; selector has been specified in selectors or not. (This differs from the
;;; C side behaviour.)
(defun get-environment-info (&rest selectors)
(loop
for sel in selectors
with vals = nil
do (push (get-info-morsel sel) vals)
finally (return (apply 'values (nreverse vals)))))
(defun get-info-morsel (selector &optional (info +info-morsel+))
(setf (info-struct-param info) (get selector :code)
(info-struct-val-ui info) 0
;;(info-struct-val-ptr info) 0 ; don't. this fucks things up
(info-struct-err info) 0)
(if (/= (%get-environment-info info 1) +no-err+)
(error "environment is unitialized")
(if (/= (info-struct-err info) +no-err+)
(error "(shouldn't) no environment info for selector ~d" selector)
(ecase (get selector :result-type)
(:unsigned-int
(info-struct-val-ui info))
(:mi_dInterface**
(if (not (member selector '(:mi_d-interface-info
:mi_d-input-interfaces
:mi_d-output-interfaces)))
(error "(shouldn't) Warning: undefined selector ~a" selector)
(loop with interfaces = (info-struct-val-ptr info)
for n below (get-info-morsel (get selector :requires))
for ifp = (*ptr-aref interfaces n)
when #-mcl (> ifp 0) #+mcl (not (%null-ptr-p ifp))
collect (cons #+excl (char*-to-string ifp)
#+mcl (%get-cstring ifp)
;;(interface-struct-name ifp)
(interface-struct-direction ifp)))))
(:mi_dMapCell**
(let ((mapcells (info-struct-val-ptr info)))
(cond
((eq selector :mi_d-channel-map)
(loop for n below (get-info-morsel :mi_d-max-logical-channels)
for mcp = (*ptr-aref mapcells n)
when #-mcl (> mcp 0) #+mcl (not (%null-ptr-p mcp))
collect
(list n
(loop while #-mcl (> mcp 0)
#+mcl (not (%null-ptr-p mcp))
collect
(cons (map-cell-struct-val-rchan-route mcp)
(map-cell-struct-val-rchan-chan mcp))
do (setf mcp (map-cell-struct-next mcp))))))
((eq selector :mi_d-inv-channel-map)
(loop for n from (1- (get-info-morsel :mi_d-max-routes))
downto 0
with l = ()
do (loop for m from (1- +max-channels+) downto 0
for mcp = (*ptr-aref
mapcells
(+ (* n +max-channels+) m))
when #-mcl (> mcp 0) #+mcl (not (%null-ptr-p mcp))
do (push
(list
(cons n m)
(loop while #-mcl (> mcp 0)
#+mcl (not (%null-ptr-p mcp))
collect (map-cell-struct-val-lchan mcp)
do (setf mcp
(map-cell-struct-next mcp))))
l))
finally (return l)))
((eq selector :mi_d-route-map)
(loop for n below (get-info-morsel :mi_d-max-routes)
for mcp = (*ptr-aref mapcells n)
when #-mcl (> mcp 0) #+mcl (not (%null-ptr-p mcp))
collect
(list n
(loop while #-mcl (> mcp 0)
#+mcl (not (%null-ptr-p mcp))
collect (map-cell-struct-val-conn mcp)
do (setf mcp (map-cell-struct-next mcp))))))
((eq selector :mi_d-inv-route-map)
(loop for n below (get-info-morsel :mi_d-max-connections)
for mcp = (*ptr-aref mapcells n)
when #-mcl (> mcp 0) #+mcl (not (%null-ptr-p mcp))
collect
(list n
(loop while #-mcl (> mcp 0)
#+mcl (not (%null-ptr-p mcp))
collect (map-cell-struct-val-route mcp)
do (setf mcp (map-cell-struct-next mcp))))))
(t
(warn "Undefined selector ~a" selector)
:error)))
)))))
;;;
;;; check-environment
;;; -----------------
(defentry check-environment "mi_dCheckEnvironment"
#+excl (()
:fixnum)
#+mcl (()
:integer))
;;;
;;; add-chanmap-mapping, clear-chanmap-mapping, clear-chanmap
;;; ---------------------------------------------------------
(defentry add-chanmap-mapping "mi_dAddChanmapMapping"
#+excl ((fixnum fixnum fixnum)
:fixnum)
#+mcl (((lchan :unsigned-short) (route :unsigned-short)
(chan :unsigned-short))
:integer))
(defentry clear-chanmap-mapping "mi_dClearChanmapMapping"
#+excl ((fixnum fixnum fixnum)
:fixnum)
#+mcl (((lchan :unsigned-short) (route :unsigned-short)
(chan :unsigned-short))
:integer))
(defentry clear-chanmap "mi_dClearChanmap"
#+excl (()
:void)
#+mcl (()
nil))
;;;
;;; add-routemap-mapping, clear-routemap-mapping, clear-routemap
;;; ------------------------------------------------------------
(defentry add-routemap-mapping "mi_dAddRoutemapMapping"
#+excl ((fixnum fixnum)
:fixnum)
#+mcl (((route :unsigned-short) (conn :unsigned-short))
:integer))
(defentry clear-routemap-mapping "mi_dClearRoutemapMapping"
#+excl ((fixnum fixnum)
:fixnum)
#+mcl (((route :unsigned-short) (conn :unsigned-short))
:integer))
(defentry clear-routemap "mi_dClearRoutemap"
#+excl (()
:void)
#+mcl (()
nil))
;;;
;;; standard-maps
;;; -------------
(defentry standard-maps "mi_dStandardMaps"
#+excl (()
:fixnum)
#+mcl (()
:integer))
;;;
;;; connect
;;; -------
;;; FIXME_DOC: this is different from the C entry point, too. (accepts only
;;; strings for the second argument).
;;;
;;; mi_d:connect Flags
(eval-when (:load-toplevel :execute)
(setf
(get :mi_d-input :value) 1
(get :mi_d-output :value) 2
(get :mi_d-bidirectional :value) 3 ; :mi_d-input OR :mi_d-output
))
(defentry %connect "mi_dConnect"
#+excl ((fixnum string fixnum)
:fixnum)
#+mcl (((conn :unsigned-short) (name :string) (direction :integer))
:integer)
:call-direct nil
:compile-time-too t)
(defun connect (connection interface param)
(when (not interface)
(setf interface ""))
(etypecase interface
(string
(ecase param
((:mi_d-input :mi_d-output :mi_d-bidirectional)
#+excl
(%connect connection interface (get param :value))
#+mcl
(with-cstrs ((s interface))
(%connect connection s (get param :value))))))))
;;; ==========================================================================
;;;
;;; I/O
;;;
;;; I/O entry points are dangerous if called without having MIDI open.
;;; Therefore, we swap their function bodies in and out when opening (or
;;; closing) MIDI.
;;;
;;; MIDI Message Formats
;;; ====================
;;;
;;; Mi_D's API supports two MIDI message formats. Routines ending in "_3c"
;;; pass messages as three (unsigned) char's, i.e. a status byte and two data
;;; bytes, whereas routines ending in "_el" pass the message as one single
;;; unsigned long in encoded format (see below). MIDI sysex data are stored
;;; and sent as strings. Running status is not used.
;;;
;;; Standard MIDI messages are passed as three separate bytes, a status byte
;;; and two data bytes, along with an (unsigned) I/O specification
;;; representing the messages route (system messages) or logical channel
;;; (channel messages). The channel field (the lower 4 bits of the status
;;; byte in channel messages) is ignored on output and cleared on input.
;;;
;;; STANDARD MESSAGES
;;; -----------------------------------------------
;;; 31.. ..24 .... ..16 .... ...8 .... ...0 (bits)
;;;
;;; system messages:
;;; ---- ---- ---- ---- route (unsigned short)
;;; 1--- ---- Status
;;; 0--- ---- Data Byte 1 (default: 0x00)
;;; 0--- ---- Data Byte 2 (default: 0x00)
;;; channel messages:
;;; ---- ---- ---- ---- logical channel (unsigned short)
;;; 1--- 0000 Status
;;; 0--- ---- Data Byte 1 (default: 0x00)
;;; 0--- ---- Data Byte 2 (default: 0x00)
;;;
;;;
;;; Encoded MIDI messages pack the status byte and (up to two) data bytes of
;;; a standard MIDI message into the lower 21 bits of an unsigned long. The
;;; remaining bits (22-31) are used to hold logical channel/routing
;;; information. The nibbles of the status byte are swapped in order to
;;; allow the 4 bits channel information present in the lower nibble of the
;;; status byte of channel messages to form a contiguous field with bits
;;; 22-31. As a result (and assuming 32-bit ints), channel messages have 14
;;; bits (bits 18-31) to represent a logical channel from 0 to 16384 whereas
;;; system messages use up to 10 bits (bits 22-31) to represent (logical)
;;; routes ranging from 0 to 1024.
;;;
;;; ENCODED MESSAGES
;;; -----------------------------------------------
;;; 31.. ..24 .... ..16 .... ...8 .... ...0 (bits)
;;;
;;; system message fields:
;;; ---- ---- -- mi_dEncRouteByte
;;; -- -- mi_dEncLStatusByte
;;; 1- -- mi_dEncUStatusByte
;;; -- --1- -- mi_dEncSwappedStatusByte
;;; -- ---- - mi_dEncData1Byte
;;; --- ---- mi_dEncData2Byte
;;; channel message subfields:
;;; ---- ---- ---- -- mi_dEncLChannelByte
;;; 1- -- mi_dEncOpcodeByte
;;;
;;;
;;; Byte specifications and offsets (Encoded MIDI Messages)
;;; -------------------------------------------------------
;;; NOTE: +enc-upper-status-offs+ and +enc-opcode-offs+ are
;;; intended to shift to and from status-byte-aligned data, i.e.
;;;
;;; (logand (ash #x91 +enc-opcode-offs+) +enc-opcode-byte+)
;;;
;;; evaluates to #x00020000, not #x00004000.
(defconstant +enc-route-byte+ (byte 10 22))
(defconstant +enc-lower-status-byte+ (byte 4 18))
(defconstant +enc-upper-status-byte+ (byte 4 14))
(defconstant +enc-swapped-status-byte+ (byte 8 14))
(defconstant +enc-logical-channel-byte+ (byte 14 18))
(defconstant +enc-opcode-byte+ +enc-upper-status-byte+)
(defconstant +enc-data-1-byte+ (byte 7 7))
(defconstant +enc-data-2-byte+ (byte 7 0))
(defconstant +enc-route-offs+ -22)
(defconstant +enc-lower-status-offs+ -18)
(defconstant +enc-upper-status-offs+ -10) ; keep byte-aligned
(defconstant +enc-swapped-status-offs+ -14) ; not byte-aligned
(defconstant +enc-logical-channel-offs+ +enc-lower-status-offs+)
(defconstant +enc-opcode-offs+ +enc-upper-status-offs+)
(defconstant +enc-data-1-offs+ -7)
(defconstant +enc-data-2-offs+ 0)
;;; AND with this mask to turn an encoded note on message into a note off
;;; message with zero velocity.
(defconstant +enc-note-off-mask+ #xfffe3f80)
;;;
;;; Storage for arguments passed by reference (Private).
;;; Some I/O functions place results in locations pointed to by their
;;; arguments. We thus need to pass a Lisp object that can be modified by
;;; foreign code (ACL) or an address in foreign space (MCL).
#+excl
(progn
;;; On SGI's only supports the o32 ABI, so longs and ints are 32, shorts
;;; 16 bits wide.
(defconstant +status+ (make-array 1 :element-type '(unsigned-byte 8)))
(defconstant +data1+ (make-array 1 :element-type '(unsigned-byte 8)))
(defconstant +data2+ (make-array 1 :element-type '(unsigned-byte 8)))
(defconstant +message+ (make-array 1 :element-type '(unsigned-byte 32)))
(defconstant +input+ (make-array 1 :element-type '(unsigned-byte 16)))
(defconstant +time+ (make-array 1 :element-type '(unsigned-byte 32)))
(defconstant +sysex-data+ (make-array 1 :element-type '(unsigned-byte 32)))
(defconstant +sysex-length+ (make-array 1 :element-type '(unsigned-byte 32)))
(defmacro get-+status+ () `(aref +status+ 0))
(defmacro get-+data1+ () `(aref +data1+ 0))
(defmacro get-+data2+ () `(aref +data2+ 0))
(defmacro get-+message+ () `(aref +message+ 0))
(defmacro get-+input+ () `(aref +input+ 0))
(defmacro get-+time+ () `(aref +time+ 0))
(defmacro get-+sysex-data+ () `(aref +sysex-data+ 0))
(defmacro get-+sysex-length+ () `(aref +sysex-length+ 0))
)
#+mcl
(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar %c-args% nil)
(defvar +status+ nil)
(defvar +data1+ nil)
(defvar +data2+ nil)
(defvar +message+ nil)
(defvar +input+ nil)
(defvar +time+ nil)
(defvar +sysex-data+ nil)
(defvar +sysex-length+ nil)
(defun %load-%c-args% ()
(unless (macptrp %c-args%) (setf %c-args% (traps::_newptr 24)))
(if (%null-ptr-p %c-args%)
(warn "Can't allocate 24 bytes for mi_d::%cargs%!")
(setf +status+ (%inc-ptr %c-args% 0) ; byte
+data1+ (%inc-ptr %c-args% 1) ; byte
+data2+ (%inc-ptr %c-args% 2) ; byte + 1 byte padding
+message+ (%inc-ptr %c-args% 4) ; long
+input+ (%inc-ptr %c-args% 8) ; short + 2 bytes padding
+time+ (%inc-ptr %c-args% 12) ; long
+sysex-data+ (%inc-ptr %c-args% 16) ; long
+sysex-length+ (%inc-ptr %c-args% 20) ; long
)))
(%load-%c-args%)
)
(defmacro get-+status+ () `(%get-unsigned-byte +status+))
(defmacro get-+data1+ () `(%get-unsigned-byte +data1+))
(defmacro get-+data2+ () `(%get-unsigned-byte +data2+))
(defmacro get-+message+ () `(%get-unsigned-long +message+))
(defmacro get-+input+ () `(%get-unsigned-word +input+))
(defmacro get-+time+ () `(%get-unsigned-long +time+))
(defmacro get-+sysex-data+ () `(%get-unsigned-long +sysex-data+))
(defmacro get-+sysex-length+ () `(%get-unsigned-long +sysex-length+))
)
;;;
;;; Access a single bytes of a sysex message in foreign space.
;;; In ACL, this is done by defining a foreign type (which in turn defines
;;; an accessor function). In MCL, it's simply %get-unsigned-byte.
#+excl
(def-c-type get-sysex-byte :unsigned-byte)
#+mcl
(defun get-sysex-byte (addr)
(%get-unsigned-byte +ptr-to-0+ addr))
;;;
;;; Write-Message_3c, Write-Message_el
;;; ------------------------------------
(defentry %write-message_3c "mi_dWriteMessage_3c"
#+excl ((fixnum (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
integer)
:fixnum)
#+mcl (((output :integer) (status :byte) (data1 :byte) (data2 :byte)
(time :long))
:integer)
:call-direct nil
:compile-time-too t)
(defentry %write-message_el "mi_dWriteMessage_el"
#+excl ((integer integer)
:fixnum)
#+mcl (((message :long) (time :long))
:integer)
:compile-time-too t)
;;;
;;; Write-Sysex
;;; -----------
;;; If the client wishes to free sysex data after sending it, it is
;;; encouraged to pass a refcounter object whose value field is initialized
;;; to a number that is meaningful to the client, typically 0. write-sysex
;;; increments the counter, schedules the message, and returns immediately,
;;; i.e., the message is written out asynchronously. The counter is
;;; decremented as soon as the message is written out completely. This
;;; mechanism allows the client to write a sysex message to different
;;; destinations and at different times, sharing its data block. After the
;;; counter has been decremented to hold its initial value again it is safe
;;; to deallocate the data.
;;;
;;; On input, sysex data gets copied to Lisp space automatically.
;;;
;;; Sysex Refcounter definition. Construct by calling make-refcounter and
;;; access via refcounter-value. Needs to be in C space.
#+excl
(def-c-type (%refcounter :in-foreign-space) :struct
;; this has to be the first field so that our struct address
;; is equal to the value address
(value :unsigned-long)
(tag :unsigned-long))
#+mcl
(progn
(defrecord (%refcounter :pointer)
(value :long)
(tag :long))
(defun make-%refcounter () (make-record %refcounter))
(defmacro %refcounter-value (rc) `(pref ,rc (%refcounter.value)))
(defmacro %refcounter-tag (rc) `(pref ,rc (%refcounter.tag)))
)
;;; Define this public accessor as a macro to maintain its setf'ability.
(defmacro refcounter-value (refcounter)
`(%refcounter-value ,refcounter))
;;;
;;; Promote refcounters to a true Lisp type.
(defconstant +refcounter-tag+ #x72436e74) ; `rCnt'
(defun refcounterp (obj)
(= (%refcounter-tag obj) +refcounter-tag+))
(deftype refcounter () `(satisfies refcounterp))
(defun make-refcounter (&optional (value 0))
(let ((c (make-%refcounter)))
(setf (%refcounter-value c) value
(%refcounter-tag c) +refcounter-tag+)
c))
(defentry %%write-sysex "mi_dWriteSysex"
#+excl ((fixnum integer (simple-array (unsigned-byte 8)) integer integer)
:fixnum)
#+mcl (((route :unsigned-short) (length :unsigned-integer) (data :pointer)
(time :unsigned-long) (refcounter :pointer))
:integer)
:call-direct nil
:compile-time-too t)
;;;
;;; MCL can't pass arrays to C, so we kludge a macptr here. From looking at
;;; MacsBug it seems as if an array of type (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*))
;;; starts actually 2 bytes before the address, if I eval (%address-of x) at
;;; the toplevel. Inside code, however, the address seems to be right. so,
;;; let's try both possible offsets and grab the LOWEST address that has F0.
#+mcl
(defun mcl-get-sysex-data-address (data)
(unless (typep data '(simple-array (unsigned-byte 8) (*)))
(error "~s is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*))" data))
(let ((ptr (%int-to-ptr (- (%address-of data) 2))))
(unless (= (%get-unsigned-byte ptr) #xF0)
(warn "~s does not seem to be a valid sysex message (no #xF0 tag at ~
address ~s)" data ptr))
ptr))
(defun %write-sysex (route length data time &optional refcounter)
#+mcl (setf data (mcl-get-sysex-data-address data))
(if refcounter
(if (typep refcounter 'refcounter)
(with-result-checked
(%%write-sysex route length data time refcounter))
(progn
(error "~s is not a refcounter" refcounter)
nil))
(with-result-checked
(%%write-sysex route length data time #+excl 0 #+mcl +ptr-to-0+))))
;;;
;;; Write-Note_3c, Write-Note_el
;;; ----------------------------
(defentry %write-note_3c "mi_dWriteNote_3c"
#+excl ((fixnum (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
integer integer)
:fixnum)
#+mcl (((noteOn :unsigned-short) (key :byte) (onVelocity :byte)
(offVelocity :byte) (duration :unsigned-long)
(time :unsigned-long))
:integer)
:call-direct nil
:compile-time-too t)
(defentry %write-note_el "mi_dWriteNote_el"
#+excl ((integer (unsigned-byte 8) integer integer)
:fixnum)
#+mcl (((noteOn :unsigned-short) (offVelocity :byte)
(duration :unsigned-long) (time :unsigned-long))
:integer)
:call-direct nil
:compile-time-too t)
;;;
;;; Read-Messages_3c, Read-Messages_el
;;; ----------------------------------
(defentry %read-messages_3c "mi_dReadMessages_3c"
#+excl (()
:fixnum)
#+mcl (()
:integer)
:compile-time-too t)
(defentry %read-messages_el "mi_dReadMessages_el"
#+excl (()
:fixnum)
#+mcl (()
:integer)
:compile-time-too t)
;;;
;;; Input-Message_3c, Input-Message_el, Input-Sysex
;;; -----------------------------------------------
(defentry %%input-message_3c "mi_dInputMessage_3c"
#+excl ((integer (simple-array (unsigned-byte 16) (1))
(simple-array (unsigned-byte 8) (1))
(simple-array (unsigned-byte 8) (1))
(simple-array (unsigned-byte 8) (1))
(simple-array (unsigned-byte 32) (1)))
:fixnum)
#+mcl (((i :unsigned-integer) (input :pointer) (status :pointer)
(data1 :pointer) (data2 :pointer) (time :pointer))
:integer)
:compile-time-too t)
(defentry %%input-message_el "mi_dInputMessage_el"
#+excl ((integer (simple-array (unsigned-byte 32) (1))
(simple-array (unsigned-byte 32) (1)))
:fixnum)
#+mcl (((i :unsigned-integer) (message :pointer) (time :pointer))
:integer)
:compile-time-too t)
(defentry %%input-sysex "mi_dInputSysex"
#+excl ((integer (simple-array (unsigned-byte 32) (1))
(simple-array (unsigned-byte 32) (1)))
:fixnum)
#+mcl (((i :unsigned-integer) (sysex :pointer) (length :pointer))
:integer)
:compile-time-too t)
(defun %input-message_3c (i)
(when (with-result-checked
(%%input-message_3c i +input+ +status+ +data1+ +data2+ +time+))
(values (get-+input+)
(get-+status+)
(get-+data1+)
(get-+data2+)
(get-+time+))))
(defun %input-message_el (i)
(when (with-result-checked
(%%input-message_el i +message+ +time+))
(values (get-+message+)
(get-+time+))))
;;; BUG: This code could actually check for duplicate messages, which, due
;;; to the way input multicasting works in Mi_D, have to be at successive
;;; indices.
(defun %input-sysex (i)
(when (with-result-checked
(%%input-sysex i +sysex-data+ +sysex-length+))
(loop for n below (get-+sysex-length+)
for base = (get-+sysex-data+) then (incf base)
with sysex = (make-array (get-+sysex-length+)
:element-type '(unsigned-byte 8))
do (setf (aref sysex n) (get-sysex-byte base))
finally (return (values sysex (get-+sysex-length+))))))
;;;
;;; I/O Call Function Body Swapping (Private). Functions starting in `%'
;;; are swapped in and out by open-midi and close-midi, respectively, in
;;; order to prevent crashes caused by calling the (unsafe) I/O entry points
;;; inadvertentlly without MIDI being open.
(defvar io-call-symbols
'(write-message_3c
write-message_el
write-sysex
write-note_3c
write-note_el
read-messages_3c
read-messages_el
input-message_3c
input-message_el
input-sysex))
(defvar io-call-bodies nil)
(eval-when (:load-toplevel :execute)
(setf io-call-bodies
;; argh. entry points are not functions in MCL 4.0...
(list #-mcl (symbol-function '%write-message_3c)
#+mcl #'(lambda (output status data1 data2 time)
(%write-message_3c output status data1 data2 time))
#-mcl (symbol-function '%write-message_el)
#+mcl #'(lambda (message time)
(%write-message_el message time))
(symbol-function '%write-sysex)
#-mcl (symbol-function '%write-note_3c)
#+mcl #'(lambda (noteOn key onVelocity offVelocity duration time)
(%write-note_3c
noteOn key onVelocity offVelocity duration time))
#-mcl (symbol-function '%write-note_el)
#+mcl #'(lambda (noteOn offVelocity duration time)
(%write-note_el noteOn offVelocity duration time))
#-mcl (symbol-function '%read-messages_3c)
#+mcl #'(lambda ()
(%read-messages_3c))
#-mcl (symbol-function '%read-messages_el)
#+mcl #'(lambda ()
(%read-messages_el))
(symbol-function '%input-message_3c)
(symbol-function '%input-message_el)
(symbol-function '%input-sysex))))
(defun io-call-stub (&rest args)
(declare (ignore args))
(warn "MIDI not open."))
(defun enable-io-calls ()
(map nil #'(lambda (sym fun)
(setf (symbol-function sym) fun))
io-call-symbols io-call-bodies))
(defun disable-io-calls ()
(map nil #'(lambda (sym)
(setf (symbol-function sym) #'io-call-stub))
io-call-symbols))
(eval-when (:load-toplevel :execute)
(disable-io-calls))
;;; ==========================================================================
;;;
;;; Flushing
;;;
;;; The C side checks whether MIDI is open or not.
;;;
;;; Flush-Input, Flush-Output
;;; -------------------------
(defentry flush-input "mi_dFlushInput"
#+excl (()
:void)
#+mcl (()
nil))
(defentry flush-output "mi_dFlushOutput"
#+excl (()
:void)
#+mcl (()
nil))
;;;
;;; All-Notes-Off
;;; -------------
(defentry all-notes-off "mi_dAllNotesOff"
#+excl (()
:void)
#+mcl (()
nil))
;;;
;;; Hush
;;; ----
(defentry hush "mi_dHush"
#+excl (()
:void)
#+mcl (()
nil))
;;; ==========================================================================
;;;
;;; Timing Functions
;;;
;;; Timing functions are always accessible.
;;;
;;; Start-Timer, Stop-Timer
;;; -----------------------
(defentry start-timer "mi_dStartTimer"
#+excl (()
:fixnum)
#+mcl (()
:integer))
(defentry stop-timer "mi_dStopTimer"
#+excl (()
:fixnum)
#+mcl (()
:integer))
;;;
;;; Get-Time, Set-Time
;;; ------------------
(defentry get-time "mi_dGetTime"
#+excl (()
:integer)
#+mcl (()
:unsigned-long))
(defentry set-time "mi_dSetTime"
#+excl ((integer)
:fixnum)
#+mcl (((time :unsigned-long))
:integer))
;;; ==========================================================================
;;;
;;; Utility Functions
;;;
;;; Always accessible.
;;;
;;; Print-Message_3c, Print-Message_el, Print-Sysex-Data
;;; ----------------------------------------------------
(defentry %print-message_3c "mi_dPrintMessage_3c"
#+excl ((integer integer fixnum fixnum fixnum fixnum integer)
:fixnum)
#+mcl (((stream :pointer) (buf :pointer) (ioref :unsigned-short)
(status :unsigned-byte) (data1 :unsigned-byte)
(data2 :unsigned-byte) (time :unsigned-long))
nil)
:compile-time-too t)
(defentry %print-message_el "mi_dPrintMessage_el"
#+excl ((integer integer integer integer)
:fixnum)
#+mcl (((stream :pointer) (buf :pointer) (message :unsigned-long)
(time :unsigned-long))
nil)
:compile-time-too t)
(defentry %print-sysex-data "mi_dPrintSysexData"
#+excl ((integer integer integer (simple-array (unsigned-byte 8))
integer)
:fixnum)
#+mcl (((stream :pointer) (buf :pointer) (lines :unsigned-integer)
(data :pointer) (time :unsigned-long))
nil)
:call-direct nil
:compile-time-too t)
;;; FIXME_DOC: string args are booleans in LISP and string gets returned!
(defun print-message_3c (stream string ioref status data1 data2
time)
(setf stream (if stream
(ecase stream (:stdout +ptr-to-1+) (:stderr +ptr-to-2+))
+ptr-to-0+))
(if string
(progn ; for indentation...
#+excl
(let ((s (make-string +message-buffer-length+
:initial-element #\Space)))
(%print-message_3c
stream (string-to-char* s) ioref status data1 data2 time)
s)
#+mcl
(%stack-block ((s +message-buffer-length+))
(%print-message_3c stream s ioref status data1 data2 time)
(%get-cstring s)))
(%print-message_3c stream +ptr-to-0+ ioref status data1 data2 time)))
(defun print-message_el (stream string message time)
(setf stream (if stream
(ecase stream (:stdout +ptr-to-1+) (:stderr +ptr-to-2+))
+ptr-to-0+))
(if string
(progn
#+excl
(let ((s (make-string +message-buffer-length+
:initial-element #\Space)))
(%print-message_el stream (string-to-char* s) message time)
s)
#+mcl
(%stack-block ((s +message-buffer-length+))
(%print-message_el stream s message time)
(%get-cstring s)))
(%print-message_el stream +ptr-to-0+ message time)))
;;;
;;; The Lisp function may well be as fast
;;; FIXME_DOC: lines may be nil (same as 0 in C) even if string is T
(defun print-sysex-data (stream string lines data length)
#+mcl (setf data (mcl-get-sysex-data-address data))
(setf stream (if stream
(ecase stream (:stdout +ptr-to-1+) (:stderr +ptr-to-2+))
+ptr-to-0+))
(setf lines (etypecase lines (number lines) ((eql nil) 0)))
(if string
(let ((len (if (and lines (> lines 0))
(* lines +sysex-buffer-line-length+)
length)))
#+excl
(let ((s (make-string len :initial-element #\Space)))
(%print-sysex-data stream (string-to-char* s) lines data length)
s)
#+mcl
(%stack-block ((s len))
(%print-sysex-data stream s lines data length)
(%get-cstring s)))
(%print-sysex-data stream +ptr-to-0+ lines data length)))
;;;
;;; Get-Error-String
;;; ----------------
;;; Defined above (see signal-result).
;;; ==========================================================================
;;;
;;; Platform-specific Functions
;;;
;;; Always accessible.
;;;
;;; oms-open-cur-studio-setup, oms-open-midi-setup-dialog
;;; -----------------------------------------------------
#+mcl
(progn
(defentry oms-open-cur-studio-setup "mi_dOMSOpenCurStudioSetup"
(()
nil))
(defentry oms-open-midi-setup-dialog "mi_dOMSOpenMIDISetupDialog"
(()
nil))
)
;;; ==========================================================================
;;;
;;; Miscellaneous
;;;
;;;
;;; C Output to the MCL Listener
;;; ----------------------------
;;; Redirect C stdout/stderr to the Lisp listener
#+mcl
(progn
(defpascal %lisp-printer
(:ptr buf :long n :void)
(declare (fixnum n) (optimize (speed 3) (safety 0)))
(loop for i below n
do (write-char (the char (code-char
(the byte (%get-byte buf i)))))))
(defvar %lisp-printer% nil)
;;
;; Get defpascal Routine Descriptor. This has to happen on each restart.
(defun %load-%lisp-printer% ()
(setf %lisp-printer%
(pref (pref %lisp-printer :RoutineDescriptor.RoutineRecords)
:RoutineRecord.ProcDescriptor)))
(defentry %mcl-setup-lisp-printer "mi_dMCLSetupLispPrinter"
(((t :pointer))
nil)
:compile-time-too t)
(defun setup-lisp-printer ()
(require-trap %mcl-setup-lisp-printer %lisp-printer%))
)
;;;
;;; Lisp Utilities
;;; -------------------
;;; Construct a sysex message out of a collection of bytes, characters, or
;;; strings, or lists thereof and surround it with F0/F7 tags.
;;;
;;; Example:
;;;
;;; (make-sysex-data 0 1 '(4 0 1) 6 #(5 4) "/foo.aiff" "change preset" NIL)
;;;
;;; NILs anywhere in the argument list are ignored.
(defun make-sysex-data (&rest args)
(let ((len 2)
(i 0) ; gets pre-incremented during stuffing
msg)
(labels (;; determine length of data
(incflen-aux (a)
(etypecase a
(character (incf len))
((signed-byte 7) (incf len))
((unsigned-byte 7) (incf len))
;; add 1 for trailing '\0'
(string (incf len (+ (length a) 1)))
(cons (incflen a)) ; NIL is *not* consp
(vector (incflen a))
;; ignore NILs
((eql nil) nil)))
(incflen (args)
(if (typep args 'vector)
(loop for a across args do (incflen-aux a))
(loop for a in args do (incflen-aux a))))
;; stuff data
(stuff (byte)
(setf (aref msg (incf i)) byte))
(stuffdata-aux (a)
(etypecase a
((unsigned-byte 8) (stuff a))
(character (stuff (char-code a)))
(string (loop for c across a
do (stuff (char-code c))
finally (stuff 0)))
(cons (stuffdata a))
(vector (stuffdata a))
;; ignore NILs
((eql nil) nil)))
(stuffdata (args)
(if (typep args 'vector)
(loop for a across args do (stuffdata-aux a))
(loop for a in args do (stuffdata-aux a)))))
(incflen args)
;; allocate data
(setf msg (make-array len :element-type '(unsigned-byte 8)
:displaced-to nil :fill-pointer nil))
;; stuff data
(stuffdata args))
;; add tags
(setf (aref msg 0) #xF0 (aref msg (1- len)) #xF7)
msg))
;;; Print bytes of the ( bytes of) data pointed to by .
;;; A line prints 16 message bytes, using 70 bytes of storage (including the
;;; trailing newline.
#|
1 2 3 4 5 6
123456789012345678901234567890123456789012345678901234567890123456789
-------------------------------------------------------------------------------
system exclusive: 0 11 104 25407
| 000000: f000 0104 0001 0605 042f 666f 6f2e 6169 ........./foo.ai
| 000010: 6666 0063 6861 6e67 6520 7072 6573 6574 ff.change preset
| [... (204 Bytes remaining)]
| 000020: 00f7 ..
-------------------------------------------------------------------------------
|#
;;;
#|
(defun %print-sysex-aux (stream data bytes rest indent)
(let ((offs 0) (toprint bytes) (n 0) oldn blank)
(loop while (> toprint 0)
do
;; print lines
(progn
(when indent (format stream indent))
;; offset
(format stream "~6,'0d: " offs)
;; bytes
(setf oldn n) ; cache n
(loop for i below 16
while (< n bytes)
do (progn
(format stream "~2,'0x~:[~; ~]" (elt data n) (oddp i))
(incf n))
finally (setf blank (- 16 i)))
;; padding
(format stream (format nil "~~~d@T"
(- (+ (* blank 3) 2) (floor blank 2))))
;; chars
(setf n oldn) ; restore n
(loop for i below 16
while (< n bytes)
for b = (elt data n)
do (progn
(format stream "~:[.~*~;~c~]"
(< 31 b 127) (code-char b))
(incf n))
finally (decf toprint i))
(format stream "~%")
(incf offs 16)))
;; print remark, if necessary
(when (> rest 0)
(format stream " [... (~d Bytes remaining)]~%" rest)))
(values))
(defun print-sysex-data (stream string lines data length &aux bytes rest)
;; accept only :stdout and :stderr, to be comptible with the C version
(setf stream (when stream
(ecase stream
(:stdout *standard-output*)
(:stderr *error-output*))))
(unless length (setf length (length data)))
(setf lines (etypecase lines (number lines) ((eql nil) 0)))
(setf bytes (if (and (> lines 0)
(< (* lines 16) length))
(* (1- lines) 16) ; reserve last line for remark
length)
rest (- length bytes))
;; if we print to both a string and stream, do string first, then print it
(if string
(let ((str (with-output-to-string (s)
(%print-sysex-aux s data bytes rest nil))))
(when stream
(format stream str))
str)
(when stream
(%print-sysex-aux stream data bytes rest nil))))
|#
;; (print-sysex-data :stdout t 1 #(0 1 2 3 23 91 92 95 91 66) 10)
#|
(print-sysex-data :stdout nil 8
(make-array 256 :element-type '(unsigned-byte 8)
:initial-contents (loop for i below 256 collect i))
nil)
|#
;;; This prints sysex data in a different format than the C function.
;;;
;;; Print a sysex message in standard binary/ascii format, i.e., printing
;;; the example message above yields:
#|
+-Data----------------------------------------------------------------+
| 000000: f000 0104 0001 0605 042f 666f 6f2e 6169 ........./foo.ai |
| 000010: 6666 0063 6861 6e67 6520 7072 6573 6574 ff.change preset |
| 000020: 00f7 .. |
+---------------------------------------------------------------------+
|#
;;;
#|
(defun print-sysex-data (vector &optional (stream *standard-output*))
(let ((offs 0)
(len (length vector)))
(loop while (< offs len)
initially (format stream "~% +-Data~64,1,0,'-<~>+")
do (progn
(loop for i from offs below len
for b = (aref vector i)
repeat 16
initially (format stream "~% | ~6,'0x: " offs)
do (format stream "~:[~; ~]~2,'0x" (evenp i) b))
(loop for i from offs below len
for b = (aref vector i)
repeat 16
initially (format stream "~1,54T")
do (format stream "~:[.~;~c~]"
(<= #x20 b #x7e) (code-char b))
finally (progn
(format stream "~1,71T|")
(setf offs i))))
finally (format stream "~% +~69,1,0,'-<~>+")))
(values))
|#
;;;
;;; Startup and Exit
;;; ----------------
;;; Resurrect pointer, make sure we close MIDI upon exit, deallocate
;;; pointers, etc.
#+excl
(eval-when (:compile-toplevel :load-toplevel :execute)
(excl:advise excl:exit :before exit-advice nil (close-midi)))
#+mcl
(progn
(defun %oms-cleanup ()
(close-midi)
(when (macptrp %lisp-printer%)
;(require-trap #_disposptr %lisp-printer%)
(dispose-record %lisp-printer%)))
(eval-when (:load-toplevel :execute)
(def-load-pointers load-+ptrs+ ()
(%load-+ptrs+))
(def-load-pointers load-+info-morsel+ ()
(%load-+info-morsel+))
(def-load-pointers load-%cargs% ()
(%load-%c-args%))
(def-load-pointers load-%lisp-printer% ()
(%load-%lisp-printer%))
(pushnew #'setup-lisp-printer *lisp-startup-functions*)
(pushnew #'%oms-cleanup *lisp-cleanup-functions*))
)
;;;
;;; EOF