;;; ======================================================================== ;;; 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