Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.

Dismiss

parsing MIDI events in LISP?

28 views

Skip to first unread message

Graham Grindlay

unread,

May 5, 2003, 9:02:43 PM5/5/03

Hi all,

I am looking for some simple lisp code to parse MIDI files into a list
of events. I'm trying to stay away from Common Music as well as any
platform or environment specific stuff. Does anyone know where I might
find some straight CLISP code to do this?

Thanks,
Graham

www.isomorphous.com

Robert STRANDH

unread,

May 6, 2003, 2:13:58 AM5/6/03

Graham Grindlay <grin...@soe.ucsc.edu> writes:

> Hi all,
>
> I am looking for some simple lisp code to parse MIDI files into a list
> of events. I'm trying to stay away from Common Music as well as any
> platform or environment specific stuff. Does anyone know where I
> might find some straight CLISP code to do this?

I recently wrote a library for doing exactly that. Here is a
preliminary version. My students have a more recent one with some
bugs fixed that I can mail to anyone interested as soon as I get it.
I would appreciate any comments and bug fixes.

;;; (c) copyright 2003 by Robert Strandh (str...@labri.fr)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of version 2 of the GNU Lesser General
;;; Public License as published by the Free Software Foundation.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;;
;;; This file contains library for MIDI and Midifiles. Messages are
;;; represented as CLOS class instances in a class hierarchy that
;;; reflects interesting aspects of the messages themselves.

(defpackage :midi
(:use :common-lisp))

(export (find-symbol "READ-MIDI-FILE" 'midi) 'midi)

(in-package :midi)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File support

(defparameter *midi-input* nil "stream for reading a Midifile")
(defparameter *input-buffer* '() "used for unreading bytes from *midi-input")
(defparameter *midi-output* nil "stream for writing a Midifile")

(defun read-next-byte ()
"read an unsigned 8-bit byte from *midi-input* checking for unread bytes"
(if *input-buffer*
(pop *input-buffer*)
(read-byte *midi-input*)))

(defun unread-byte (byte)
"unread a byte from *midi-input*"
(push byte *input-buffer*))

(defun write-bytes (&rest bytes)
"write an arbitrary number of bytes to *midi-output*"
(mapc #'(lambda (byte) (write-byte byte *midi-output*)) bytes))

(defun read-fixed-length-quantity (nb-bytes)
"read an unsigned integer of nb-bytes bytes from *midi-input*"
(loop with result = 0
for i from 1 to nb-bytes
do (setf result (logior (ash result 8) (read-next-byte)))
finally (return result)))

(defmacro with-midi-input (filename &body body)
"execute body with *midi-input* assigned to a stream from filename"
`(with-open-file (*midi-input* ,filename
:direction :input :element-type '(unsigned-byte 8))
,@body))

(defmacro with-midi-output (filename &body body)
"execute body with *midi-output* assigned to a stream from filename"
`(with-open-file (*midi-output ,filename
:direction :output :element-type '(unsigned-byte 8))
,@body))

(defun read-variable-length-quantity ()
"read a MIDI variable length quantity from *midi-input*"
(loop with result = 0
with byte
do (setf byte (read-next-byte)
result (logior (ash result 7) (logand byte #x7f)))
until (< byte #x80)
finally (return result)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; MIDI file representation

(defclass midifile ()
((format :initarg :format :reader :midifile-format)
(division :initarg :division :reader :midifile-division)
(tracks :initarg :tracks :reader :midifile-tracks))
(:documentation "the class that represents a Midifile in core"))

(defparameter *status* nil "the (possibly running) status while reading an event")

(defun read-message ()
"read a message without time indication from *midi-input*"
(let ((classname-or-subtype (aref *dispatch-table* *status*)))
(unless classname-or-subtype
(write *status* :base 16))
(if (symbolp classname-or-subtype)
(make-instance classname-or-subtype)
(let* ((data-byte (read-next-byte))
(classname (aref classname-or-subtype data-byte)))
(unless classname
(write data-byte :base 16))
(unread-byte data-byte)
(make-instance classname)))))

(defparameter *time* 0 "accumulated time from the start of the track")

(defun read-timed-message ()
"read a message preceded with a delta-time indication"
(let ((delta-time (read-variable-length-quantity))
(status-or-data (read-next-byte)))
(if (>= status-or-data #x80)
(setf *status* status-or-data)
(unread-byte status-or-data))
(let ((message (read-message)))
(fill-message message)
(setf (message-time message) (incf *time* delta-time))
message)))

(defun read-track (format)
"read a track as a list of timed messages, excluding the end-of-track message"
(let ((type (read-fixed-length-quantity 4))
(length (read-fixed-length-quantity 4)))
(declare (ignore type length))
(when (= format 1) (setf *time* 0))
(loop with message = nil
do (setf message (read-timed-message))
until (typep message 'end-of-track-message)
collect message)))

(defun read-midi-file (filename)
"read an entire Midifile from the file with name given as argument"
(with-midi-input filename
(let ((type (read-fixed-length-quantity 4))
(length (read-fixed-length-quantity 4))
(format (read-fixed-length-quantity 2))
(nb-tracks (read-fixed-length-quantity 2))
(division (read-fixed-length-quantity 2)))
(declare (ignore type length))
(make-instance 'midifile
:format format
:division division
:tracks (loop repeat nb-tracks
collect (read-track format))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macro for defining midi messages

(defparameter *dispatch-table* (make-array 256 :initial-element nil)
"given values of status (and perhaps data1), find a class to create")
(defparameter *status-min* (make-hash-table :test #'eq)
"given a class name, find the minimum status value for the type of message")
(defparameter *status-max* (make-hash-table :test #'eq)
"given a class name, find the maximum status value for the type of message")
(defparameter *data-min* (make-hash-table :test #'eq)
"given a class name, find the minimum data1 value for the type of message")
(defparameter *data-max* (make-hash-table :test #'eq)
"given a class name, find the maximum data1 value for the type of message")

(defmacro define-midi-message (name superclasses
&key slots filler writer status-min status-max data-min data-max)
;; assign default values if necessary
(unless status-min
(setf status-min (gethash (car superclasses) *status-min*)))
(unless status-max
(setf status-max (gethash (car superclasses) *status-max*)))
(unless data-min
(setf data-min (gethash (car superclasses) *data-min*)))
(unless data-max
(setf data-max (gethash (car superclasses) *data-max*)))
;; set status values for this class
(setf (gethash name *status-min*) status-min)
(setf (gethash name *status-max*) status-max)
(setf (gethash name *data-min*) data-min)
(setf (gethash name *data-max*) data-max)
;; update the dispatch table
(when status-min
(if data-min
(progn (unless (arrayp (aref *dispatch-table* status-min))
(let ((secondary-dispatch (make-array 256 :initial-element nil)))
(loop for i from status-min to status-max do
(setf (aref *dispatch-table* i) secondary-dispatch))))
(loop for i from data-min to data-max do
(setf (aref (aref *dispatch-table* status-min) i)
name)))
(loop for i from status-min to status-max do
(setf (aref *dispatch-table* i)
name))))
`(progn

(defclass ,name ,superclasses
,slots)

(defmethod fill-message :after ((message ,name))
(with-slots ,(mapcar #'car slots) message
(symbol-macrolet ((next-byte (read-next-byte)))
,filler)))

(defmethod write-message :after ((message ,name))
(with-slots ,(mapcar #'car slots) message
,writer))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; main filler and writer methods

(defmethod fill-message (message)
(declare (ignore message))
nil)

(defmethod write-message (message)
(declare (ignore message))
nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; midi messages

(define-midi-message message ()
:slots ((time :accessor message-time)
(status :reader message-status))
:filler (setf status *status*))

(define-midi-message channel-message (message)
:slots ((channel :reader message-channel))
:filler (setf channel (logand *status* #x0f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; voice messages

(define-midi-message voice-message (channel-message))

(define-midi-message note-off-message (voice-message)
:status-min #x80 :status-max #x8f
:slots ((key :reader message-key)
(velocity :reader message-velocity))
:filler (setf key next-byte
velocity next-byte)
:writer (write-bytes key velocity))

(define-midi-message note-on-message (voice-message)
:status-min #x90 :status-max #x9f
:slots ((key :reader message-key)
(velocity :reader message-velocity))
:filler (setf key next-byte
velocity next-byte)
:writer (write-bytes key velocity))

(define-midi-message polyphonic-key-pressure-message (voice-message)
:status-min #xa0 :status-max #xaf
:slots ((key)
(pressure))
:filler (setf key next-byte
pressure next-byte)
:writer (write-bytes key pressure))

(define-midi-message control-change-message (voice-message)
:status-min #xb0 :status-max #xbf
:data-min #x00 :data-max #x78
:slots ((controller)
(value))
:filler (setf controller next-byte
value next-byte)
:writer (write-bytes controller value))

(define-midi-message program-change-message (voice-message)
:status-min #xc0 :status-max #xcf
:slots ((program))
:filler (setf program next-byte)
:writer (write-bytes program))

(define-midi-message channel-pressure-message (voice-message)
:status-min #xd0 :status-max #xdf
:slots ((pressure))
:filler (setf pressure next-byte)
:writer (write-bytes pressure))

(define-midi-message pitch-bend-message (voice-message)
:status-min #xe0 :status-max #xef
:slots ((value))
:filler (setf value (logior (ash next-byte 8) next-byte))
:writer (write-bytes (ash value -8) (logand value #xf)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; mode messages

(define-midi-message mode-message (channel-message)
:filler next-byte)
; consume data byte

(define-midi-message reset-all-controllers-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x79 :data-max #x79
:filler next-byte ; consume unused byte
:writer (write-bytes #x79 0))

(define-midi-message local-control-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7a :data-max #x7a
:slots ((mode))
:filler (setf mode (if (= next-byte 0) :off :on))
:writer (write-bytes #x7a (if (eq mode :off) 0 127)))

(define-midi-message all-notes-off-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7b :data-max #x7b
:filler next-byte ; consume unused byte
:writer (write-bytes #x7b 0))

(define-midi-message omni-mode-off-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7c :data-max #x7c
:filler next-byte ; consume unused byte
:writer (write-bytes #x7c 0))

(define-midi-message omni-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7d :data-max #x7d
:filler next-byte ; consume unused byte
:writer (write-bytes #x7d 0))

(define-midi-message mono-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7e :data-max #x7e
:slots ((nb-channels))
:filler (setf nb-channels next-byte)
:writer (write-bytes #x7e nb-channels))

(define-midi-message poly-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7f :data-max #x7f
:filler next-byte ; consume unused byte
:writer (write-bytes #x7f 0))

(define-midi-message system-message (message))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system common messages

(define-midi-message common-message (system-message))

(define-midi-message timing-code-message (common-message)
:status-min #xf1 :status-max #xf1
:slots ((code))
:filler (setf code next-byte)
:writer (write-bytes code))

(define-midi-message song-position-pointer-message (common-message)
:status-min #xf2 :status-max #xf2
:slots ((pointer))
:filler (setf pointer (logior (ash next-byte 8) next-byte))
:writer (write-bytes (ash pointer -8) (logand pointer #xf)))

(define-midi-message song-select-message (common-message)
:status-min #xf3 :status-max #xf3
:slots ((song))
:filler (setf song next-byte)
:writer (write-bytes song))

(define-midi-message tune-request-message (common-message)
:status-min #xf6 :status-max #xf6)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system real-time messages

(define-midi-message real-time-message (system-message))

(define-midi-message timing-clock-message (real-time-message)
:status-min #xf8 :status-max #xf8)

(define-midi-message start-sequence-message (real-time-message)
:status-min #xfa :status-max #xfa)

(define-midi-message continue-sequence-message (real-time-message)
:status-min #xfb :status-max #xfb)

(define-midi-message stop-sequence-message (real-time-message)
:status-min #xfc :status-max #xfc)

(define-midi-message active-sensing-message (real-time-message)
:status-min #xfe :status-max #xfe)

;; (define-midi-message tune-request-message (real-time-message)
;; :status-min #xf6 :status-max #xf6)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system exclusive messages

(define-midi-message system-exclusive-message (system-message)
:status-min #xf0 :status-max #xf0
:filler (loop until (= next-byte #xf7))
:writer (write-bytes #xf7))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; midi file messages

(define-midi-message midifile-message (message)
:status-min #xff :status-max #xff
:filler next-byte)

(define-midi-message sequence-number-message (midifile-message)
:data-min #x00 :data-max #x00
:slots ((sequence))
:filler (let ((data2 next-byte))
(setf sequence (if (zerop data2)
0
(logior (ash next-byte 8) next-byte))))
:writer (if (zerop sequence)
(write-bytes 0)
(write-bytes (ash sequence -8) (logand sequence #xf))))

(define-midi-message text-message (midifile-message)
:slots ((text))
:filler (setf text (loop with len = next-byte
with str = (make-string len)
for i from 0 below len
do (setf (aref str i)
(code-char next-byte))
finally (return str)))
:writer (map nil (lambda (char) (write-bytes (char-code char)))
text))
; FIXME

(define-midi-message general-text-message (text-message)
:data-min #x01 :data-max #x01)

(define-midi-message copyright-message (text-message)
:data-min #x02 :data-max #x02)

(define-midi-message sequence/track-name-message (text-message)
:data-min #x03 :data-max #x03)

(define-midi-message instrument-message (text-message)
:data-min #x04 :data-max #x04)

(define-midi-message lyric-message (text-message)
:data-min #x05 :data-max #x05)

(define-midi-message marker-message (text-message)
:data-min #x06 :data-max #x06)

(define-midi-message cue-point-message (text-message)
:data-min #x07 :data-max #x07)

(define-midi-message program-name-message (text-message)
:data-min #x08 :data-max #x08)

(define-midi-message device-name-message (text-message)
:data-min #x09 :data-max #x09)

(define-midi-message channel-prefix-message (midifile-message)
:data-min #x20 :data-max #x20
:slots ((channel))
:filler (progn next-byte (setf channel next-byte)))

(define-midi-message end-of-track-message (midifile-message)
:data-min #x2f :data-max #x2f
:filler next-byte
:writer (write-bytes #x2f 0))

(define-midi-message tempo-message (midifile-message)
:data-min #x51 :data-max #x51
:slots ((tempo :reader message-tempo))
:filler (progn next-byte (setf tempo (read-fixed-length-quantity 3)))
:writer nil)
; FIXME

(define-midi-message smpte-offset-message (midifile-message)
:data-min #x54 :data-max #x54
:slots ((hr) (mn) (se) (fr) (ff))
:filler (progn next-byte (setf hr next-byte mn next-byte se next-byte
fr next-byte ff next-byte))
:writer (write-bytes #x54 hr mn se fr ff))

(define-midi-message time-signature-message (midifile-message)
:data-min #x58 :data-max #x58
:slots ((nn :reader message-numerator)
(dd :reader message-denominator)
(cc) (bb))
:filler (progn next-byte (setf nn next-byte dd next-byte
cc next-byte bb next-byte))
:writer (write-bytes #x58 nn dd cc bb))

(define-midi-message key-signature-message (midifile-message)
:data-min #x59 :data-max #x59
:slots ((sf) (mi))
:filler (progn next-byte (setf sf next-byte mi next-byte))
:writer (write-bytes #x59 sf mi))

(define-midi-message proprietary-event (midifile-message)
:data-min #x7f :data-max #x7f
:slots ((data))
:filler (setf data (loop with len = (read-variable-length-quantity)
with vec = (make-array len :element-type '(unsigned-byte 8))
for i from 0 below len
do (setf (aref vec i) next-byte)
finally (return vec)))
:writer (map nil (lambda (byte) (write-bytes byte))
data))
; FIXME

--
Robert Strandh

---------------------------------------------------------------------
Greenspun's Tenth Rule of Programming: any sufficiently complicated C
or Fortran program contains an ad hoc informally-specified bug-ridden
slow implementation of half of Common Lisp.
---------------------------------------------------------------------

Robert STRANDH

unread,

May 7, 2003, 1:57:30 AM5/7/03

Robert STRANDH <str...@labri.fr> writes:

> I recently wrote a library for doing exactly that. Here is a
> preliminary version. My students have a more recent one with some
> bugs fixed that I can mail to anyone interested as soon as I get it.
> I would appreciate any comments and bug fixes.

Here is a newer version :

;;; (c) copyright 2003 by Mathieu Chabanne, Camille Constant,
;;; Emmanuel Necibar and Stephanie Recco
;;; Corrected and modified when it is mentionned.
;;;

(defpackage :midi
(:use :common-lisp)

(:export "READ-MIDI-FILE"
"MIDIFILE-FORMAT" "MIDIFILE-TRACKS" "MIDIFILE-DIVISION"
"MESSAGE" "NOTE-OFF-MESSAGE" "NOTE-ON-MESSAGE" "TEMPO-MESSAGE"
"KEY-SIGNATURE-MESSAGE" "TIME-SIGNATURE-MESSAGE"
"SMPTE-OFFSET-MESSAGE"
"MESSAGE-CHANNEL" "MESSAGE-KEY" "MESSAGE-TIME"
"MESSAGE-VELOCITY" "MESSAGE-NUMERATOR" "MESSAGE-DENOMINATOR"
"MESSAGE-SF" "MESSAGE-MI" "MESSAGE-TEMPO"
"HEADER" "HEADER-TYPE"
"UNKNOWN-EVENT" "STATUS" "DATA-BYTE"))

(in-package :midi)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File support

;; modified
(defconstant *header-mthd* 1297377380 "decimal value of the string MThd")
(defconstant *header-mtrk* 1297379947 "decimal value of the string MTrk")
(defconstant *header-mthd-length* 6 "value of the header MThd data's length")

;; modified
(define-condition unknown-event ()
((status :initarg :status :reader status)
(data-byte :initform "" :initarg :data-byte :reader data-byte))
(:documentation "condition when the event does not exist in the library"))

;; modified
(define-condition header ()
((header-type :initarg :header :reader header-type))
(:documentation "condition when the header is not correct"))

(defun read-next-byte ()
"read an unsigned 8-bit byte from *midi-input* checking for unread bytes"
(if *input-buffer*
(pop *input-buffer*)
(read-byte *midi-input*)))

(defun unread-byte (byte)
"unread a byte from *midi-input*"
(push byte *input-buffer*))

(defun write-bytes (&rest bytes)
"write an arbitrary number of bytes to *midi-output*"
(mapc #'(lambda (byte) (write-byte byte *midi-output*)) bytes))

(defmacro with-midi-output (filename &body body)
"execute body with *midi-output* assigned to a stream from filename"

`(with-open-file (*midi-output* ,filename

:direction :output :element-type '(unsigned-byte 8))
,@body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; MIDI file representation

(defclass midifile ()
((format :initarg :format :reader midifile-format)
(division :initarg :division :reader midifile-division)
(tracks :initarg :tracks :reader midifile-tracks))
(:documentation "the class that represents a Midifile in core"))

(defparameter *status* nil "the status while reading an event")
;; modified
(defparameter *running-status* nil "the running status while reading an event")

;; modified

(defun read-message ()
"read a message without time indication from *midi-input*"
(let ((classname-or-subtype (aref *dispatch-table* *status*)))
(unless classname-or-subtype

(error (make-condition 'unknown-event
:status *status*)))

(if (symbolp classname-or-subtype)
(make-instance classname-or-subtype)
(let* ((data-byte (read-next-byte))
(classname (aref classname-or-subtype data-byte)))
(unless classname

(error (make-condition 'unknown-event
:status *status*
:data-byte data-byte)))
(unread-byte data-byte)
(make-instance classname)))))

(defparameter *time* 0 "accumulated time from the start of the track")

;; modified

(defun read-timed-message ()
"read a message preceded with a delta-time indication"
(let ((delta-time (read-variable-length-quantity))
(status-or-data (read-next-byte)))
(if (>= status-or-data #x80)

(progn (setf *status* status-or-data)
(when (<= *status* #xef)
(setf *running-status* *status*)))
(progn (unread-byte status-or-data)
(setf *status* *running-status*)))

(let ((message (read-message)))
(fill-message message)
(setf (message-time message) (incf *time* delta-time))
message)))

;; modified
(defun read-track ()

"read a track as a list of timed messages, excluding the end-of-track message"
(let ((type (read-fixed-length-quantity 4))
(length (read-fixed-length-quantity 4)))

(declare (ignore length))
(unless (= type *header-mtrk*)
(error (make-condition 'header :header "MTrk")))

(loop with message = nil
do (setf message (read-timed-message))
until (typep message 'end-of-track-message)
collect message)))

;; modified

(defun read-midi-file (filename)
"read an entire Midifile from the file with name given as argument"

(setf *time* 0)

(with-midi-input filename
(let ((type (read-fixed-length-quantity 4))
(length (read-fixed-length-quantity 4))
(format (read-fixed-length-quantity 2))
(nb-tracks (read-fixed-length-quantity 2))
(division (read-fixed-length-quantity 2)))

(unless (and (= length *header-mthd-length*) (= type *header-mthd*))
(error (make-condition 'header :header "MThd")))

(make-instance 'midifile
:format format
:division division
:tracks (loop repeat nb-tracks

do (when (= format 1) (setf *time* 0))
collect (read-track))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macro for defining midi messages

(defun register-class (class superclass status-min status-max data-min data-max)
(unless status-min
(setf status-min (gethash superclass *status-min*)))
(unless status-max
(setf status-max (gethash superclass *status-max*)))
(unless data-min
(setf data-min (gethash superclass *data-min*)))
(unless data-max
(setf data-max (gethash superclass *data-max*)))

;; set status values for this class

(setf (gethash class *status-min*) status-min)
(setf (gethash class *status-max*) status-max)
(setf (gethash class *data-min*) data-min)
(setf (gethash class *data-max*) data-max)

;; update the dispatch table
(when status-min
(if data-min
(progn (unless (arrayp (aref *dispatch-table* status-min))
(let ((secondary-dispatch (make-array 256
:initial-element nil)))
(loop for i from status-min to status-max do
(setf (aref *dispatch-table* i) secondary-dispatch))))
(loop for i from data-min to data-max do
(setf (aref (aref *dispatch-table* status-min) i)

class)))

(loop for i from status-min to status-max do
(setf (aref *dispatch-table* i)

class)))))

(defmacro define-midi-message (name superclasses
&key slots filler writer
status-min status-max data-min data-max)

`(progn

(register-class ',name ',(car superclasses)
,status-min ,status-max ,data-min ,data-max)

(defclass ,name ,superclasses
,slots)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; midi messages

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; voice messages

(define-midi-message voice-message (channel-message))

;; modified

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; mode messages

(define-midi-message system-message (message))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system common messages

(define-midi-message common-message (system-message))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system real-time messages

(define-midi-message real-time-message (system-message))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system exclusive messages

;; modified

(define-midi-message system-exclusive-message (system-message)
:status-min #xf0 :status-max #xf0

:filler (loop with len = (read-variable-length-quantity)
with data = (read-fixed-length-quantity (1- len))
until (= next-byte #xf7)
do
next-byte
(setf len (read-variable-length-quantity)
data (read-fixed-length-quantity (1- len))))
:writer nil)
; FIXME

;; modified
(define-midi-message authorization-system-exclusive-message (system-message)
:status-min #xf7 :status-max #xf7
:filler (read-fixed-length-quantity (read-variable-length-quantity))
:writer nil)
; FIXME

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; meta messages

(define-midi-message meta-message (message)

:status-min #xff :status-max #xff
:filler next-byte)

;; modified
(define-midi-message sequence-number-message (meta-message)
:data-min #x0 :data-max #x0

:slots ((sequence))
:filler (let ((data2 next-byte))
(setf sequence (if (zerop data2)
0
(logior (ash next-byte 8) next-byte))))
:writer (if (zerop sequence)
(write-bytes 0)
(write-bytes (ash sequence -8) (logand sequence #xf))))

(define-midi-message text-message (meta-message)

(define-midi-message channel-prefix-message (meta-message)

:data-min #x20 :data-max #x20
:slots ((channel))
:filler (progn next-byte (setf channel next-byte)))

;; modified
(define-midi-message midi-port-message (meta-message)
:data-min #x21 :data-max #x21
:slots ((port))
:filler (progn next-byte (setf port next-byte)))

(define-midi-message end-of-track-message (meta-message)

:data-min #x2f :data-max #x2f
:filler next-byte
:writer (write-bytes #x2f 0))

;; modified
(define-midi-message tempo-message (meta-message)

:data-min #x51 :data-max #x51
:slots ((tempo :reader message-tempo))
:filler (progn next-byte (setf tempo (read-fixed-length-quantity 3)))
:writer nil)
; FIXME

(define-midi-message smpte-offset-message (meta-message)

:data-min #x54 :data-max #x54
:slots ((hr) (mn) (se) (fr) (ff))
:filler (progn next-byte (setf hr next-byte mn next-byte se next-byte
fr next-byte ff next-byte))
:writer (write-bytes #x54 hr mn se fr ff))

;; modified
(define-midi-message time-signature-message (meta-message)

:data-min #x58 :data-max #x58
:slots ((nn :reader message-numerator)
(dd :reader message-denominator)
(cc) (bb))
:filler (progn next-byte (setf nn next-byte dd next-byte
cc next-byte bb next-byte))
:writer (write-bytes #x58 nn dd cc bb))

;; modified
(define-midi-message key-signature-message (meta-message)
:data-min #x59 :data-max #x59
:slots ((sf :reader message-sf) (mi :reader message-mi))
:filler (progn next-byte (setf sf (let ((temp-sf next-byte))
(if (> temp-sf 127)
(- temp-sf 256)
temp-sf))

mi next-byte))
:writer (write-bytes #x59 sf mi))

(define-midi-message proprietary-event (meta-message)

0 new messages