general cleanup

abstract-tag.lisp

@@ -84,7 +84,6 @@
       (let ((new-frames))
         (dolist (f frames)
           (push (list (encoding f) (lang f) (desc f) (val f)) new-frames))
-        ;; XXX need to render this into text
         (return-from comment new-frames))))
   (if (v21-tag-header (id3-header me))
       (comment (v21-tag-header (id3-header me)))
@@ -120,7 +119,7 @@
             (end)
             (str (info (first frames))))
 
-        ;; XXX for V23/V24 TCON frames, a genre can be pretty gnarly.
+        ;; For V23/V24 TCON frames, a genre can be pretty gnarly.
         ;; if the first byte of the TCON INFO field is a '(', what is between this '('
         ;; and the next ')' is interpreted as an ID3v2.1 genre number.
         ;; These can stack up (called "refinements") too.

audio-streams.lisp

@@ -59,6 +59,8 @@ As a convenience, OFFSET and FROM are optional, so (STREAM-SEEK stream) returns
       (:end                    ; INDEX set to OFFSET from end of stream
        (setf index (- stream-size offset))))))
 
+(declaim (inline read-n-bytes))
+
 (defun read-n-bytes (stream n-bytes &key (bits-per-byte 8) (endian :little-endian))
   "Returns a FIXNUM constructed by reading N-BYTES.  BITS-PER-BYTE contols how many bits should be used from each read byte."
   (declare #.utils:*standard-optimize-settings*)
@@ -79,10 +81,7 @@ As a convenience, OFFSET and FROM are optional, so (STREAM-SEEK stream) returns
                finally (return-from read-n-bytes value))))))
     nil)
 
-;;; XXX Not sure this does anything...
-(declaim (inline read-n-bytes))
-
-(defmethod stream-read-u8   ((stream mem-stream) &key (bits-per-byte 8)) (read-n-bytes stream 1 :bits-per-byte bits-per-byte))
+(defmethod stream-read-u8   ((stream mem-stream) &key (bits-per-byte 8))                         (read-n-bytes stream 1  :bits-per-byte bits-per-byte))
 (defmethod stream-read-u16  ((stream mem-stream) &key (bits-per-byte 8) (endian :little-endian)) (read-n-bytes stream 2  :bits-per-byte bits-per-byte :endian endian))
 (defmethod stream-read-u24  ((stream mem-stream) &key (bits-per-byte 8) (endian :little-endian)) (read-n-bytes stream 3  :bits-per-byte bits-per-byte :endian endian))
 (defmethod stream-read-u32  ((stream mem-stream) &key (bits-per-byte 8) (endian :little-endian)) (read-n-bytes stream 4  :bits-per-byte bits-per-byte :endian endian))
@@ -173,8 +172,8 @@ a displaced array from STREAMs underlying vector.  If it is == 7, then we have t
   (declare #.utils:*standard-optimize-settings*)
   (labels ((get-byte-order-mark (octets)
              (let ((retval 0))
-               (setf (ldb (byte 8 0) retval) (aref octets 1))
-               (setf (ldb (byte 8 8) retval) (aref octets 0))
+               (setf (ldb (byte 8 0) retval) (aref octets 1)
+                     (ldb (byte 8 8) retval) (aref octets 0))
                (when (not (or (= #xfffe retval) (= #xfeff retval)))
                  (error "Got invalid byte-order mark of ~x in STREAM-DECODE-UCS-STRING" retval))
                retval)))

flac-frame.lisp

@@ -21,12 +21,12 @@
    (header-len  :accessor header-len  :initarg :header-len  :documentation "how long the info associated w/header is"))
   (:documentation "Representation of FLAC stream header"))
 
-(defmacro with-frame-slots ((instance) &body body)
+(defmacro with-flac-slots ((instance) &body body)
   `(with-slots (pos last-bit header-type header-len) ,instance
      ,@body))
 
 (defmethod vpprint ((me flac-header) stream)
-  (with-slots (pos last-bit header-type header-len) me
+  (with-flac-slots (me)
     (format stream "pos = ~:d, last-bit = ~b, header-type = ~d, length = ~:d"
             pos
             last-bit
@@ -149,20 +149,21 @@
   "Read in the the audio properties from current file position."
   (declare #.utils:*standard-optimize-settings*)
   (let ((info (make-instance 'flac-audio-properties)))
-    (setf (min-block-size info) (stream-read-u16 flac-stream))
-    (setf (max-block-size info) (stream-read-u16 flac-stream))
-    (setf (min-frame-size info) (stream-read-u24 flac-stream))
-    (setf (max-frame-size info) (stream-read-u24 flac-stream))
+    (setf (min-block-size info) (stream-read-u16 flac-stream)
+          (max-block-size info) (stream-read-u16 flac-stream)
+          (min-frame-size info) (stream-read-u24 flac-stream)
+          (max-frame-size info) (stream-read-u24 flac-stream))
     (let* ((int1 (stream-read-u32 flac-stream))
            (int2 (stream-read-u32 flac-stream)))
-      (setf (total-samples info) (logior (ash (get-bitfield int1 3  4) -32) int2))
-      (setf (bits-per-sample info)            (1+ (get-bitfield int1 8  5)))
-      (setf (num-channels info)               (1+ (get-bitfield int1 11 3)))
-      (setf (sample-rate info)                (get-bitfield int1 31 20)))
-    (setf (md5-sig info) (stream-read-u128 flac-stream))
+      (setf (total-samples info)   (logior (ash (get-bitfield int1 3  4) -32) int2)
+            (bits-per-sample info) (1+ (get-bitfield int1 8  5))
+            (num-channels info)    (1+ (get-bitfield int1 11 3))
+            (sample-rate info)     (get-bitfield int1 31 20)
+            (md5-sig info)         (stream-read-u128 flac-stream)))
     info))
 
 (defun flac-show-raw-tag (flac-file-stream out-stream)
+  "Spit out the raw form of comments we found"
   (declare #.utils:*standard-optimize-settings*)
   (format out-stream "Vendor string: <~a>~%" (vendor-str (flac-tags flac-file-stream)))
   (dotimes (i (length (comments (flac-tags flac-file-stream))))

id3-frame.lisp

@@ -33,8 +33,8 @@ Written in this fashion so as to be 'crash-proof' when passed an arbitrary file.
              (handler-case
                  (progn
                    (stream-seek mp3-file 0 :start)
-                   (setf id3 (stream-read-string-with-len mp3-file 3))
-                   (setf version (stream-read-u8 mp3-file))
+                   (setf id3     (stream-read-string-with-len mp3-file 3)
+                         version (stream-read-u8 mp3-file))
                    (when (> (stream-size mp3-file) 128)
                      (stream-seek mp3-file 128 :end)
                      (setf tag (stream-read-string-with-len mp3-file 3)))
@@ -72,10 +72,10 @@ Written in this fashion so as to be 'crash-proof' when passed an arbitrary file.
   (log5:with-context "v21-frame-initializer"
     (log-id3-frame "reading v2.1 tag from ~:d" (stream-seek instream 0))
     (with-slots (title artist album year comment genre track) me
-      (setf title    (upto-null (stream-read-string-with-len instream 30)))
-      (setf artist   (upto-null (stream-read-string-with-len instream 30)))
-      (setf album    (upto-null (stream-read-string-with-len instream 30)))
-      (setf year     (upto-null (stream-read-string-with-len instream 4)))
+      (setf title    (upto-null (stream-read-string-with-len instream 30))
+            artist   (upto-null (stream-read-string-with-len instream 30))
+            album    (upto-null (stream-read-string-with-len instream 30))
+            year     (upto-null (stream-read-string-with-len instream 4)))
 
       ;; In V21, a comment can be split into comment and track #
       ;; find the first #\Null then check to see if that index < 28.  If so, the check the last two bytes being
@@ -85,8 +85,9 @@ Written in this fashion so as to be 'crash-proof' when passed an arbitrary file.
                (first-null (find 0 c))
                (trck 0))
           (when (and first-null (<= first-null 28))
-            (setf (ldb (byte 8 8) trck) (aref c 28))
-            (setf (ldb (byte 8 0) trck) (aref c 29)))
+            (setf (ldb (byte 8 8) trck) (aref c 28)
+                  (ldb (byte 8 0) trck) (aref c 29)))
+
           (setf comment (upto-null (map 'string #'code-char c)))
           (if (> trck 0)
               (setf track trck)
@@ -110,8 +111,8 @@ Note: extended headers are subject to unsynchronization, so make sure that INSTR
 NB: 2.3 and 2.4 extended flags are different..."
   (declare #.utils:*standard-optimize-settings*)
   (with-slots (size flags padding crc is-update restrictions) me
-    (setf size (stream-read-u32 instream))
-    (setf flags (stream-read-u16 instream)) ; reading in flags fields, must discern below 2.3/2.4
+    (setf size  (stream-read-u32 instream)
+          flags (stream-read-u16 instream)) ; reading in flags fields, must discern below 2.3/2.4
     (log-id3-frame "making id3-ext-header: version = ~d, size = ~d, flags = ~x"
                    version size flags)
     (ecase version
@@ -225,10 +226,10 @@ NB: 2.3 and 2.4 extended flags are different..."
 
       (stream-seek instream 0 :start)
       (when (string= "ID3" (stream-read-string-with-len instream 3))
-        (setf version (stream-read-u8 instream))
-        (setf revision (stream-read-u8 instream))
-        (setf flags (stream-read-u8 instream))
-        (setf size (stream-read-u32 instream :bits-per-byte 7))
+        (setf version  (stream-read-u8 instream)
+              revision (stream-read-u8 instream)
+              flags    (stream-read-u8 instream)
+              size     (stream-read-u32 instream :bits-per-byte 7))
         (when (header-unsynchronized-p flags)
           (log-id3-frame "header flags indicate unsync"))
         (assert (not (header-footer-p flags)) () "Can't decode ID3 footer's yet")
@@ -402,8 +403,8 @@ NB: 2.3 and 2.4 extended flags are different..."
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "frame-com"
     (with-slots (len encoding lang desc val) me
-      (setf encoding (stream-read-u8 instream))
-      (setf lang (stream-read-iso-string-with-len instream 3))
+      (setf encoding (stream-read-u8 instream)
+            lang (stream-read-iso-string-with-len instream 3))
       (multiple-value-bind (n v) (get-name-value-pair instream (- len 1 3) encoding encoding)
         (setf desc n)
 
@@ -416,7 +417,7 @@ NB: 2.3 and 2.4 extended flags are different..."
     (format stream "frame-com: ~a, encoding = ~d, lang = <~a> (~a), desc = <~a>, val = <~a>"
             (vpprint-frame-header me) encoding lang (get-iso-639-2-language lang) desc val)))
 
-;;; ULT's are same format as COM's... XXX rewrite this as suggested in comment at bottom of this file
+;;; ULT's are same format as COM's...
 ;;; V22 unsynced lyrics/text "ULT"
 ;;; Text encoding        $xx
 ;;; Language             $xx xx xx
@@ -442,12 +443,12 @@ NB: 2.3 and 2.4 extended flags are different..."
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "frame-pic"
     (with-slots (id len encoding img-format type desc data) me
-      (setf encoding (stream-read-u8 instream))
-      (setf img-format (stream-read-iso-string-with-len instream 3))
-      (setf type (stream-read-u8 instream))
+      (setf encoding (stream-read-u8 instream)
+            img-format (stream-read-iso-string-with-len instream 3)
+            type (stream-read-u8 instream))
       (multiple-value-bind (n v) (get-name-value-pair instream (- len 5) encoding -1)
-        (setf desc n)
-        (setf data v)
+        (setf desc n
+              data v)
         (log-id3-frame "encoding: ~d, img-format = <~a>, type = ~d (~a), desc = <~a>, value = ~a"
                    encoding img-format type (get-picture-type type) desc (printable-array data))))))
 
@@ -478,8 +479,8 @@ NB: 2.3 and 2.4 extended flags are different..."
           (if (frame-24-datalen-p flags)
               (setf read-len (stream-read-u32 instream :bits-per-byte 7))))
 
-        (setf encoding (stream-read-u8 instream))
-        (setf info (stream-read-string-with-len instream (1- read-len) :encoding encoding)))
+        (setf encoding (stream-read-u8 instream)
+              info     (stream-read-string-with-len instream (1- read-len) :encoding encoding)))
 
       ;; A null is ok, but according to the "spec", you're supposed to ignore anything after a 'Null'
       (log-id3-frame "made text-info-frame: ~a" (vpprint me nil))
@@ -544,8 +545,8 @@ NB: 2.3 and 2.4 extended flags are different..."
     (with-slots (len encoding desc val) me
       (setf encoding (stream-read-u8 instream))
       (multiple-value-bind (n v) (get-name-value-pair instream (1- len) encoding encoding)
-        (setf desc n)
-        (setf val v)
+        (setf desc n
+              val v)
         (log-id3-frame "encoding = ~d, desc = <~a>, val = <~a>" encoding desc val)))))
 
 (defmethod vpprint ((me frame-txx) stream)
@@ -565,8 +566,8 @@ NB: 2.3 and 2.4 extended flags are different..."
   (log5:with-context "frame-ufi"
     (with-slots (id len name value) me
       (multiple-value-bind (n v) (get-name-value-pair instream len 0 -1)
-        (setf name n)
-        (setf value v))
+        (setf name n
+              value v))
       (log-id3-frame "name = <~a>, value = ~a" name (printable-array value)))))
 
 (defmethod vpprint ((me frame-ufi) stream)
@@ -704,12 +705,12 @@ NB: 2.3 and 2.4 extended flags are different..."
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "frame-apic"
     (with-slots (id len encoding mime type desc data) me
-      (setf encoding (stream-read-u8 instream))
-      (setf mime (stream-read-iso-string instream))
-      (setf type (stream-read-u8 instream))
+      (setf encoding (stream-read-u8 instream)
+            mime     (stream-read-iso-string instream)
+            type     (stream-read-u8 instream))
       (multiple-value-bind (n v) (get-name-value-pair instream (- len 1 (length mime) 1 1) encoding -1)
-        (setf desc n)
-        (setf data v)
+        (setf desc n
+              data v)
         (log-id3-frame "enoding = ~d, mime = <~a>, type = ~d (~a), desc = <~a>, data = ~a" encoding mime type (get-picture-type type) desc (printable-array data))))))
 
 (defmethod vpprint ((me frame-apic) stream)
@@ -734,8 +735,8 @@ NB: 2.3 and 2.4 extended flags are different..."
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "frame-comm"
     (with-slots (encoding lang len desc val) me
-      (setf encoding (stream-read-u8 instream))
-      (setf lang (stream-read-iso-string-with-len instream 3))
+      (setf encoding (stream-read-u8 instream)
+            lang     (stream-read-iso-string-with-len instream 3))
       (multiple-value-bind (n v) (get-name-value-pair instream (- len 1 3) encoding encoding)
         (setf desc n)
 
@@ -784,8 +785,8 @@ NB: 2.3 and 2.4 extended flags are different..."
   (log5:with-context "frame-priv"
     (with-slots (id len name value) me
       (multiple-value-bind (n v) (get-name-value-pair instream len 0 -1)
-        (setf name n)
-        (setf value v)
+        (setf name n
+              value v)
         (log-id3-frame "name = <~a>, value = <~a>" name value)))))
 
 (defmethod vpprint ((me frame-priv) stream)
@@ -812,8 +813,8 @@ NB: 2.3 and 2.4 extended flags are different..."
                                                       (- len 1)
                                                       encoding
                                                       encoding)
-        (setf desc n)
-        (setf val v))
+        (setf desc n
+              val v))
       (log-id3-frame "encoding = ~d, desc = <~a>, value = <~a>" encoding desc val))))
 
 (defmethod vpprint ((me frame-txxx) stream)
@@ -833,8 +834,8 @@ NB: 2.3 and 2.4 extended flags are different..."
   (log5:with-context "frame-ufid"
     (with-slots (id len name value) me
       (multiple-value-bind (n v) (get-name-value-pair instream len 0 -1)
-        (setf name n)
-        (setf value v))
+        (setf name n
+              value v))
       (log-id3-frame "name = <~a>, value = ~a" name (printable-array value)))))
 
 (defmethod vpprint ((me frame-ufid) stream)
@@ -1023,13 +1024,3 @@ NB: 2.3 and 2.4 extended flags are different..."
 (defun map-id3-frames (mp3-file &key (func (constantly t)))
   "Iterates through the ID3 frames found in an MP3 file"
   (mapcar func (frames (id3-header mp3-file))))
-
-#|
-XXX
-Random ideas for rewrite:
--might be simplest to read in frame payloads (sync'ed appropriately) for all frames and then move parsing into
- accessor methods? This might be easier to handle sync/compression/etc.
-
--probably should rewrite name/value pairs as a mixin class?  Or more broadly, there is a finite set of frame-encodings,
- so abstact to that, then subclass for frame-????
-|#

mp4-atom.lisp

@@ -20,10 +20,10 @@
   (declare #.utils:*standard-optimize-settings*)
   (let ((int 0))
     (declare (integer int))
-    (setf (ldb (byte 8 24) int) (char-code (aref str 0)))
-    (setf (ldb (byte 8 16) int) (char-code (aref str 1)))
-    (setf (ldb (byte 8 8) int)  (char-code (aref str 2)))
-    (setf (ldb (byte 8 0) int)  (char-code (aref str 3)))
+    (setf (ldb (byte 8 24) int) (char-code (aref str 0))
+          (ldb (byte 8 16) int) (char-code (aref str 1))
+          (ldb (byte 8 8) int)  (char-code (aref str 2))
+          (ldb (byte 8 0) int)  (char-code (aref str 3)))
 
     int))
 
@@ -51,10 +51,10 @@
   (defmacro mk-mp4-atom-type (l1 l2 l3 l4)
     "Given 4 chars/ints, create a 32-bit word representing an atom 'type' (aka name)"
     `(let ((retval 0))
-       (setf (ldb (byte 8 24) retval) ,(as-octet l1))
-       (setf (ldb (byte 8 16) retval) ,(as-octet l2))
-       (setf (ldb (byte 8 8) retval)  ,(as-octet l3))
-       (setf (ldb (byte 8 0) retval)  ,(as-octet l4))
+       (setf (ldb (byte 8 24) retval) ,(as-octet l1)
+             (ldb (byte 8 16) retval) ,(as-octet l2)
+             (ldb (byte 8 8) retval)  ,(as-octet l3)
+             (ldb (byte 8 0) retval)  ,(as-octet l4))
        retval)))
 
 (defconstant +itunes-album+          (mk-mp4-atom-type #xa9 #\a #\l #\b) "text: album name")
@@ -98,16 +98,16 @@
 (defconstant +mp4-atom-trak+         (mk-mp4-atom-type #\t #\r #\a #\k))
 (defconstant +mp4-atom-udta+         (mk-mp4-atom-type #\u #\d #\t #\a))
 
-(defun atom-read-loop (mp4-file end func)
-  "Loop from start to end through a file and call FUNC for every ATOM we find. Used
-at top-level and also for container ATOMs that need to read their contents."
-  (declare #.utils:*standard-optimize-settings*)
-  (log5:with-context "atom-read-loop"
-    (do ()
-        ((>= (stream-seek mp4-file) end))
-      (log-mp4-atom "atom-read-loop: @~:d before dispatch" (stream-seek mp4-file))
-      (funcall func)
-      (log-mp4-atom "atom-read-loop: @~:d after dispatch" (stream-seek mp4-file)))))
+;; (defun atom-read-loop (mp4-file end func)
+;;   "Loop from start to end through a file and call FUNC for every ATOM we find. Used
+;; at top-level and also for container ATOMs that need to read their contents."
+;;   (declare #.utils:*standard-optimize-settings*)
+;;   (log5:with-context "atom-read-loop"
+;;     (do ()
+;;         ((>= (stream-seek mp4-file) end))
+;;       (log-mp4-atom "atom-read-loop: @~:d before dispatch" (stream-seek mp4-file))
+;;       (funcall func)
+;;       (log-mp4-atom "atom-read-loop: @~:d after dispatch" (stream-seek mp4-file)))))
 
 (defclass mp4-atom ()
   ((atom-file-position :accessor atom-file-position :initarg :atom-file-position)
@@ -147,6 +147,7 @@ to read the payload of an atom."
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ILST ATOMS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defclass atom-ilst (mp4-atom) ())
+
 (defmethod initialize-instance :after ((me atom-ilst) &key (mp4-file nil) &allow-other-keys)
   "Construct an ilst atom.  ILST atoms are containers that hold data elements related to tagging.
 Loop through this container and construct constituent atoms"
@@ -155,13 +156,12 @@ Loop through this container and construct constituent atoms"
     (with-slots (atom-size atom-type atom-children) me
       (log-mp4-atom "atom-ilst-init: found ilst atom <~a> @ ~:d, looping for ~:d bytes"
                     (as-string atom-type) (stream-seek mp4-file) (- atom-size 8))
-      (atom-read-loop mp4-file (+ (stream-seek mp4-file)  (- atom-size 8))
-                      (lambda ()
-                        (let ((child (make-mp4-atom mp4-file atom-type)))
-                          ;(log-mp4-atom "adding new child ~a" (vpprint child nil))
-                          (addc me child))))))
-  ;(log-mp4-atom "returning ilst atom: ~a" (vpprint me nil))
-  )
+
+      (let ((end (+ (stream-seek mp4-file) (- atom-size 8))))
+        (loop for current = (stream-seek mp4-file) then (stream-seek mp4-file)
+            while (< current end) do
+              (log-mp4-atom "at ~:d:~:d~%" current end)
+              (addc me (make-mp4-atom mp4-file atom-type)))))))
 
 (defclass atom-©alb (atom-ilst) ())
 (defclass atom-aART (atom-ilst) ())
@@ -197,8 +197,8 @@ Loop through this container and construct constituent atoms"
   (declare #.utils:*standard-optimize-settings*)
    (log5:with-context "atom-data-init"
      (with-slots (atom-size atom-type atom-version atom-flags atom-value atom-parent-type) me
-       (setf atom-version (stream-read-u8 mp4-file))
-       (setf atom-flags (stream-read-u24 mp4-file))
+       (setf atom-version (stream-read-u8 mp4-file)
+             atom-flags (stream-read-u24 mp4-file))
        (assert (= 0 (stream-read-u32 mp4-file)) () "a data atom lacks the required null field") ; XXX is this true?
        (log-mp4-atom "atom-data-init: size = ~:d, name = ~a, version = ~d, flags = ~x" atom-size (as-string atom-type) atom-version atom-flags)
        (setf atom-value (decode-ilst-data-atom atom-type me atom-parent-type mp4-file))
@@ -237,8 +237,8 @@ Loop through this container and construct constituent atoms"
        (declare (ignore tmp)))
        ;(format t "ilist decode, parent = ~a: ~x~%" (as-string atom-parent-type) tmp))
      (let ((a) (b))
-       (setf a (stream-read-u16 mp4-file))
-       (setf b (stream-read-u16 mp4-file))
+       (setf a (stream-read-u16 mp4-file)
+             b (stream-read-u16 mp4-file))
        (stream-seek mp4-file (- (atom-size atom) 16 6) :current) ; seek to end of atom: 16 == header; 4 is a, b, skip read above
        (list a b))))
 
@@ -290,18 +290,18 @@ Loop through this container and construct constituent atoms"
    (resv    :accessor resv)    ; 4 bytes
    (rflag   :accessor rflag)   ; 4 bytes
    (rmask   :accessor rmask)   ; 4 bytes
-   (mhdlr   :accessor mhdlr))) ; null-terminated string (XXX but we're reading it as octets)
+   (mhdlr   :accessor mhdlr))) ; null-terminated string (but we're reading it as octets)
 
 (defmethod initialize-instance :after ((me atom-hdlr) &key (mp4-file nil) &allow-other-keys)
   (with-slots (version flags qtype mtype resv rflag rmask mhdlr atom-size) me
-    (setf version  (stream-read-u8 mp4-file))
-    (setf flags    (stream-read-u24 mp4-file))
-    (setf qtype    (stream-read-u32 mp4-file))
-    (setf mtype    (stream-read-u32 mp4-file))
-    (setf resv     (stream-read-u32 mp4-file))
-    (setf rflag    (stream-read-u32 mp4-file))
-    (setf rmask    (stream-read-u32 mp4-file))
-    (setf mhdlr    (stream-read-sequence mp4-file (- atom-size 32))))) ; 32 is 8-bytes of header plus fields above
+    (setf version  (stream-read-u8 mp4-file)
+          flags    (stream-read-u24 mp4-file)
+          qtype    (stream-read-u32 mp4-file)
+          mtype    (stream-read-u32 mp4-file)
+          resv     (stream-read-u32 mp4-file)
+          rflag    (stream-read-u32 mp4-file)
+          rmask    (stream-read-u32 mp4-file)
+          mhdlr    (stream-read-sequence mp4-file (- atom-size 32))))) ; 32 is 8-bytes of header plus fields above
 
 (defclass atom-mdhd (mp4-atom)
   ((version  :accessor version)
@@ -312,17 +312,18 @@ Loop through this container and construct constituent atoms"
    (duration :accessor duration)
    (lang     :accessor lang)
    (quality  :accessor quality)))
+
 (defmethod initialize-instance :after ((me atom-mdhd) &key (mp4-file nil) &allow-other-keys)
   (declare #.utils:*standard-optimize-settings*)
   (with-slots (version flags c-time m-time scale duration lang quality) me
-    (setf version  (stream-read-u8 mp4-file))
-    (setf flags    (stream-read-u24 mp4-file))
-    (setf c-time   (stream-read-u32 mp4-file))
-    (setf m-time   (stream-read-u32 mp4-file))
-    (setf scale    (stream-read-u32 mp4-file))
-    (setf duration (if (= 0 version) (stream-read-u32 mp4-file) (stream-read-u64 mp4-file)))
-    (setf lang     (stream-read-u16 mp4-file))
-    (setf quality  (stream-read-u16 mp4-file))))
+    (setf version  (stream-read-u8 mp4-file)
+          flags    (stream-read-u24 mp4-file)
+          c-time   (stream-read-u32 mp4-file)
+          m-time   (stream-read-u32 mp4-file)
+          scale    (stream-read-u32 mp4-file)
+          duration (if (= 0 version) (stream-read-u32 mp4-file) (stream-read-u64 mp4-file))
+          lang     (stream-read-u16 mp4-file)
+          quality  (stream-read-u16 mp4-file))))
 
 (defclass atom-esds (mp4-atom)
   ((version      :accessor version)       ; 1 byte
@@ -347,8 +348,8 @@ Loop through this container and construct constituent atoms"
          (len (logand tmp #x7f)))
     (declare (type (unsigned-byte 8) tmp))
     (while (not (zerop (logand #x80 tmp)))
-      (setf tmp (stream-read-u8 instream))
-      (setf len (logior (ash len 7) (logand tmp #x7f))))
+      (setf tmp (stream-read-u8 instream)
+            len (logior (ash len 7) (logand tmp #x7f))))
     len))
 
 ;;; one-byte descriptor tags
@@ -375,22 +376,22 @@ Loop through this container and construct constituent atoms"
 (defmethod initialize-instance :after ((me atom-esds) &key (mp4-file nil) &allow-other-keys)
   (declare #.utils:*standard-optimize-settings*)
   (with-slots (version flags esid s-priority obj-id s-type buf-size max-bit-rate avg-bit-rate) me
-    (setf version (stream-read-u8 mp4-file))
-    (setf flags (stream-read-u24 mp4-file))
+    (setf version (stream-read-u8 mp4-file)
+          flags (stream-read-u24 mp4-file))
     (assert (= +MP4-ESDescrTag+ (stream-read-u8 mp4-file)) () "Expected description tag of ESDescrTag")
     (let* ((len (read-descriptor-len mp4-file))
            (end-of-atom (+ (stream-seek mp4-file) len)))
-      (setf esid (stream-read-u16 mp4-file))
-      (setf s-priority (stream-read-u8 mp4-file))
+      (setf esid (stream-read-u16 mp4-file)
+            s-priority (stream-read-u8 mp4-file))
       (assert (= +MP4-DecConfigDescrTag+ (stream-read-u8 mp4-file)) () "Expected tag type of DecConfigDescrTag")
-      (setf len (read-descriptor-len mp4-file))
-      (setf obj-id (stream-read-u8 mp4-file))
-      (setf s-type (stream-read-u8 mp4-file))
-      (setf buf-size (stream-read-u24 mp4-file))
-      (setf max-bit-rate (stream-read-u32 mp4-file))
-      (setf avg-bit-rate (stream-read-u32 mp4-file))
-
-      ;; XXX should do checking here and/or read rest of atom,
+      (setf len          (read-descriptor-len mp4-file)
+            obj-id       (stream-read-u8 mp4-file)
+            s-type       (stream-read-u8 mp4-file)
+            buf-size     (stream-read-u24 mp4-file)
+            max-bit-rate (stream-read-u32 mp4-file)
+            avg-bit-rate (stream-read-u32 mp4-file))
+
+      ;; Should do checking here and/or read rest of atom,
       ;; but for now, we have what we want, so just seek to end of atom
       (stream-seek mp4-file end-of-atom :start))))
 
@@ -403,9 +404,9 @@ Loop through this container and construct constituent atoms"
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "atom-stsd"
     (with-slots (flags version num-entries) me
-      (setf version (stream-read-u8 mp4-file))
-      (setf flags (stream-read-u24 mp4-file))
-      (setf num-entries (stream-read-u32 mp4-file))
+      (setf version (stream-read-u8 mp4-file)
+            flags   (stream-read-u24 mp4-file)
+            num-entries (stream-read-u32 mp4-file))
       (log-mp4-atom "atom-stsd: version = ~d, flags = ~x, num-fields = ~d" version flags num-entries))))
 
 (defclass atom-mp4a (mp4-atom)
@@ -424,16 +425,16 @@ Loop through this container and construct constituent atoms"
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "atom-mp4a"
     (with-slots (reserved d-ref-idx version revision vendor num-chans samp-size comp-id packet-size samp-rate) me
-      (setf reserved    (stream-read-sequence mp4-file 6))
-      (setf d-ref-idx   (stream-read-u16 mp4-file))
-      (setf version     (stream-read-u16 mp4-file))
-      (setf revision    (stream-read-u16 mp4-file))
-      (setf vendor      (stream-read-u32 mp4-file))
-      (setf num-chans   (stream-read-u16 mp4-file))
-      (setf samp-size   (stream-read-u16 mp4-file))
-      (setf comp-id     (stream-read-u16 mp4-file))
-      (setf packet-size (stream-read-u16 mp4-file))
-      (setf samp-rate   (stream-read-u32 mp4-file)) ; fixed 16.16 floating point number
+      (setf reserved    (stream-read-sequence mp4-file 6)
+            d-ref-idx   (stream-read-u16 mp4-file)
+            version     (stream-read-u16 mp4-file)
+            revision    (stream-read-u16 mp4-file)
+            vendor      (stream-read-u32 mp4-file)
+            num-chans   (stream-read-u16 mp4-file)
+            samp-size   (stream-read-u16 mp4-file)
+            comp-id     (stream-read-u16 mp4-file)
+            packet-size (stream-read-u16 mp4-file)
+            samp-rate   (stream-read-u32 mp4-file)) ; fixed 16.16 floating point number
 
       (read-container-atoms mp4-file me))))
 
@@ -442,11 +443,12 @@ Loop through this container and construct constituent atoms"
   "Loop through a container atom and add it's children to it"
   (declare #.utils:*standard-optimize-settings*)
   (with-slots (atom-children atom-file-position atom-of-interest atom-size atom-type atom-decoded) parent-atom
-    (atom-read-loop mp4-file (+ atom-file-position atom-size)
-                    (lambda ()
-                      (let ((child (make-mp4-atom mp4-file atom-type)))
-                        (log-mp4-atom "read-container-atoms: adding new child ~a" (vpprint child nil))
-                        (addc parent-atom child))))))
+    (let ((end (+ atom-file-position atom-size)))
+      (loop for current = (stream-seek mp4-file) then (stream-seek mp4-file)
+            while (< current end) do
+              (let ((child (make-mp4-atom mp4-file atom-type)))
+                (log-mp4-atom "read-container-atoms: adding new child ~a" (vpprint child nil))
+                (addc parent-atom child))))))
 
 (defclass atom-meta (mp4-atom)
   ((version  :accessor version)
@@ -454,8 +456,8 @@ Loop through this container and construct constituent atoms"
 (defmethod initialize-instance :after ((me atom-meta) &key (mp4-file nil) &allow-other-keys)
   (declare #.utils:*standard-optimize-settings*)
    (with-slots (version flags) me
-     (setf version  (stream-read-u8 mp4-file))
-     (setf flags    (stream-read-u24 mp4-file))
+     (setf version  (stream-read-u8 mp4-file)
+           flags    (stream-read-u24 mp4-file))
      (read-container-atoms mp4-file me)))
 
 (defun find-atom-class (id)
@@ -519,9 +521,9 @@ Written in this fashion so as to be 'crash-proof' when passed an arbitrary file.
            (handler-case
                (progn
                  (stream-seek mp4-file 0 :start)
-                 (setf size (stream-read-u32 mp4-file))
-                 (setf header (stream-read-u32 mp4-file))
-                 (setf valid (and (<= size (stream-size mp4-file))
+                 (setf size   (stream-read-u32 mp4-file)
+                       header (stream-read-u32 mp4-file)
+                       valid  (and (<= size (stream-size mp4-file))
                                   (= header +m4-ftyp+))))
              (condition (c)
                (utils:warn-user "File:~a~%is-valid-mp4-file got condition ~a" (stream-filename mp4-file) c)))
@@ -537,12 +539,13 @@ Written in this fashion so as to be 'crash-proof' when passed an arbitrary file.
     (log-mp4-atom "find-mp4-atoms: ~a, before read-file loop, file-position = ~:d, end = ~:d"
                   (stream-filename mp4-file) (stream-seek mp4-file) (stream-size mp4-file))
 
-    (let ((atoms))
-      (atom-read-loop mp4-file (stream-size mp4-file)
-                      (lambda ()
-                        (let ((new-atom (make-mp4-atom mp4-file)))
-                          (when new-atom
-                            (push new-atom atoms)))))
+    (let ((atoms)
+          (end (stream-size mp4-file)))
+      (loop for current = (stream-seek mp4-file) then (stream-seek mp4-file)
+            while (< current end) do
+              (let ((new-atom (make-mp4-atom mp4-file)))
+                (when new-atom
+                  (push new-atom atoms))))
       (setf (mp4-atoms mp4-file) (nreverse atoms))) ; preserve in-file-order
 
     (log-mp4-atom "find-mp4-atoms: returning list of size ~d" (length (mp4-atoms mp4-file)))))
@@ -666,12 +669,12 @@ return trak.mdia.mdhd and trak.mdia.minf.stbl.stsd"
         (when mdhd
           (setf seconds (/ (float (duration mdhd)) (float (scale mdhd)))))
         (when mp4a
-          (setf channels (num-chans mp4a))
-          (setf bits-per-sample (samp-size mp4a))
+          (setf channels (num-chans mp4a)
+                bits-per-sample (samp-size mp4a))
           (let* ((upper (ash (samp-rate mp4a) -16))
                  (lower (logand (samp-rate mp4a) #xffff)))
             (setf sample-rate (+ (float upper) (/ (float lower) 1000))))
         (when esds
-          (setf avg-bit-rate (avg-bit-rate esds))
-          (setf max-bit-rate (max-bit-rate esds))))))
+          (setf avg-bit-rate (avg-bit-rate esds)
+                max-bit-rate (max-bit-rate esds))))))
     info))

mpeg.lisp

@@ -199,8 +199,8 @@
           (log-mpeg-frame "loading frame from pos ~:d" (stream-seek instream))
           (when (null hdr-u32)          ; has header already been read in?
             (log-mpeg-frame "reading in header")
-            (setf pos (stream-seek instream))
-            (setf hdr-u32 (stream-read-u32 instream))
+            (setf pos (stream-seek instream)
+                  hdr-u32 (stream-read-u32 instream))
             (when (null hdr-u32)
               (log-mpeg-frame "hit EOF")
               (return-from load-frame nil)))
@@ -242,33 +242,26 @@ Bits   1-0 (2  bits): the emphasis"
     (with-frame-slots (me)
       ;; check sync word
       (setf sync (get-bitfield hdr-u32 31 11))
-                                        ;(setf (ldb (byte 8 8) sync) (ldb (byte 8 24) hdr-u32))
-                                        ;(setf (ldb (byte 3 5) sync) (ldb (byte 3 5) (ldb (byte 8 16) hdr-u32)))
       (when (not (= sync +sync-word+))
         (log-mpeg-frame "bad sync ~x/~x" sync hdr-u32)
         (return-from parse-header nil))
 
       ;; check version
-                                        ;(setf version (ldb (byte 2 3) (ldb (byte 8 16) hdr-u32)))
       (setf version (get-bitfield hdr-u32 20 2))
       (when (not (valid-version version))
         (log-mpeg-frame "bad version ~d" version)
         (return-from parse-header nil))
 
       ;; check layer
-                                        ;(setf layer (ldb (byte 2 1) (ldb (byte 8 16) hdr-u32)))
       (setf layer (get-bitfield hdr-u32 18 2))
       (when (not (valid-layer layer))
         (log-mpeg-frame "bad layer ~d" layer)
         (return-from parse-header nil))
 
-                                        ;(setf protection (ldb (byte 1 0) (ldb (byte 8 16) hdr-u32)))
-      (setf protection (get-bitfield hdr-u32 16 1))
-
-      (setf samples (get-samples-per-frame version layer))
+      (setf protection (get-bitfield hdr-u32 16 1)
+            samples (get-samples-per-frame version layer))
 
       ;; check bit-rate
-                                        ;(let ((br-index (the fixnum (ldb (byte 4 4) (ldb (byte 8 8) hdr-u32)))))
       (let ((br-index (get-bitfield hdr-u32 15 4)))
         (when (not (valid-bit-rate-index br-index))
           (log-mpeg-frame "bad bit-rate index ~d" br-index)
@@ -277,7 +270,6 @@ Bits   1-0 (2  bits): the emphasis"
         (setf bit-rate (get-bit-rate version layer br-index)))
 
       ;; check sample rate
-                                        ;(let ((sr-index (the fixnum (ldb (byte 2 2) (ldb (byte 8 8) hdr-u32)))))
       (let ((sr-index (get-bitfield hdr-u32 11 2)))
         (when (not (valid-sample-rate-index sr-index))
           (log-mpeg-frame "bad sample-rate index ~d" sr-index)
@@ -285,13 +277,13 @@ Bits   1-0 (2  bits): the emphasis"
 
         (setf sample-rate (get-sample-rate version sr-index)))
 
-      (setf padded (get-bitfield hdr-u32 9 1))
-      (setf private (get-bitfield hdr-u32 8 1))
-      (setf channel-mode (get-bitfield hdr-u32 7 2))
-      (setf mode-extension (get-bitfield hdr-u32 5 2))
-      (setf copyright (get-bitfield hdr-u32 3 1))
-      (setf original (get-bitfield hdr-u32 2 1))
-      (setf emphasis (get-bitfield hdr-u32 1 2))
+      (setf padded (get-bitfield hdr-u32 9 1)
+            private (get-bitfield hdr-u32 8 1)
+            channel-mode (get-bitfield hdr-u32 7 2)
+            mode-extension (get-bitfield hdr-u32 5 2)
+            copyright (get-bitfield hdr-u32 3 1)
+            original (get-bitfield hdr-u32 2 1)
+            emphasis (get-bitfield hdr-u32 1 2))
 
       ;; check emphasis
       (when (not (valid-emphasis emphasis))
@@ -370,8 +362,8 @@ Bits   1-0 (2  bits): the emphasis"
           (setf vbr (make-instance 'vbr-info))
           (let ((v (make-mem-stream (payload me))))
             (stream-seek v i :start)            ; seek to Xing/Info offset
-            (setf (tag vbr) (stream-read-iso-string-with-len v 4))
-            (setf (flags vbr) (stream-read-u32 v))
+            (setf (tag vbr)   (stream-read-iso-string-with-len v 4)
+                  (flags vbr) (stream-read-u32 v))
 
             (when (logand (flags vbr) +vbr-frames+)
               (setf (frames vbr) (stream-read-u32 v))
@@ -411,8 +403,8 @@ Bits   1-0 (2  bits): the emphasis"
 
       (handler-case
           (loop
-            (setf pos (stream-seek in))
-            (setf hdr-u32 (stream-read-u32 in))
+            (setf pos (stream-seek in)
+                  hdr-u32 (stream-read-u32 in))
             (when (null hdr-u32)
               (return-from find-first-sync nil))
             (incf count)
@@ -430,7 +422,7 @@ Bits   1-0 (2  bits): the emphasis"
         (condition (c) (progn
                          (warn-user "Condtion <~a> signaled while looking for first sync" c)
                          (log-mpeg-frame "got a condition while looking for first sync: ~a" c)
-                         (error c)))) ; XXX should I propogate this, or just return nil
+                         (error c))))
       nil)))
 
 (defmethod next-frame ((me frame) &key instream read-payload)
@@ -516,9 +508,9 @@ Bits   1-0 (2  bits): the emphasis"
           (log-mpeg-frame "couldn't get audio-info: only got ~d frames" n-frames)
           (return-from calc-bit-rate-exhaustive))
 
-        (setf is-vbr t)
-        (setf len total-len)
-        (setf bit-rate (float (/ bit-rate-total n-frames)))
+        (setf is-vbr t
+              len total-len
+              bit-rate (float (/ bit-rate-total n-frames)))
         (log-mpeg-frame "len = ~:d, bit-rate = ~f" len bit-rate)))))
 
  (defun get-mpeg-audio-info (in &key) ;; (max-frames *max-frames-to-read*))
@@ -535,29 +527,28 @@ Bits   1-0 (2  bits): the emphasis"
          (return-from get-mpeg-audio-info nil))
 
        (with-slots (is-vbr sample-rate bit-rate len version layer n-frames) info
-         (setf version (version first-frame))
-         (setf layer (layer first-frame))
-         (setf sample-rate (sample-rate first-frame))
+         (setf version (version first-frame)
+               layer (layer first-frame)
+               sample-rate (sample-rate first-frame))
 
          (if (vbr first-frame)
              ;; found a Xing header, now check to see if it is correct
              (if (zerop (frames (vbr first-frame)))
                  (calc-bit-rate-exhaustive in (pos first-frame) info) ; Xing header broken, read all frames to calc
                  ;; Good Xing header, use info in VBR to calc
-                 (progn
-                   (setf n-frames 1)
-                   (setf is-vbr t)
-                   (setf len (float (* (frames (vbr first-frame)) (/ (samples first-frame) (sample-rate first-frame)))))
-                   (setf bit-rate (float (/ (* 8 (bytes (vbr first-frame))) len)))))
+                 (setf n-frames 1
+                       is-vbr   t
+                       len      (float (* (frames (vbr first-frame)) (/ (samples first-frame) (sample-rate first-frame))))
+                       bit-rate (float (/ (* 8 (bytes (vbr first-frame))) len))))
 
              ;; No Xing header found.  Assume CBR and calculate based on first frame
              (let* ((first (pos first-frame))
                     (last (- (audio-streams:stream-size in) (if (id3-frame::v21-tag-header (id3-header in)) 128 0)))
                     (n-fr (round (/ (float (- last first)) (float (size first-frame)))))
                     (n-sec (round (/ (float (* (size first-frame) n-fr)) (float (* 125 (float (/ (bit-rate first-frame) 1000))))))))
-               (setf is-vbr nil)
-               (setf n-frames 1)
-               (setf len n-sec)
-               (setf bit-rate (float (bit-rate first-frame))))))
+               (setf is-vbr nil
+                     n-frames 1
+                     len n-sec
+                     bit-rate (float (bit-rate first-frame))))))
 
              info)))

utils.lisp

@@ -2,12 +2,9 @@
 ;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
 (in-package #:utils)
 
-#+CCL (eval-when (:compile-toplevel :load-toplevel :exec)
+#+CCL (eval-when (:compile-toplevel :load-toplevel :execute)
         (defvar *standard-optimize-settings* '(optimize (speed 3) (safety 0) (space 0) (debug 0))))
 
-;; #+SBCL (eval-when (:compile-toplevel :load-toplevel :execute)
-;;          (defvar *standard-optimize-settings* '(optimize (speed 3) (safety 0) (space 0) (debug 0))))
-
 (defparameter *break-on-warn-user* nil "set to T if you'd like to stop in warn-user")
 
 (defun warn-user (format-string &rest args)
@@ -78,28 +75,31 @@ The above will expand to (ash (logand #xFFFBB240 #xFFE00000) -21) at COMPILE tim
   `(aif ,test-form
         (progn ,@body)))
 
-;;;(defvar *hashes* nil)
+#+INSTRUMENT-MEMOIZED (progn
+                        (defstruct memoized-funcs
+                          table
+                          calls
+                          finds
+                          news)
+                        (defvar *memoized-funcs* nil))
+
 (defun mk-memoize (func)
   "Takes a normal function object and returns a memoized one"
-  (let* ((count 0)
-         (hash-table (make-hash-table :test 'equal)))
-    ;;(push hash-table *hashes*)
-    ;;(format t "Hashes now: ~a~%" *hashes*)
-    #'(lambda (arg)
-        ;;(format t "Looking for <~a>~%" arg)
-        (multiple-value-bind (value foundp) (gethash arg hash-table)
-        (incf count)
+  (let* ((hash-table (make-hash-table :test 'equal))
+          #+INSTRUMENT-MEMOIZED (s (make-memoized-funcs :table hash-table :calls 0 :finds 0 :news 0))
+         )
 
-          ;; (when (> count 20)
-          ;;   (break "Breaking as requested")
-          ;;   (setf count 0))
+    #+INSTRUMENT-MEMOIZED (push s *memoized-funcs*)
 
+    #'(lambda (arg)
+        (multiple-value-bind (value foundp) (gethash arg hash-table)
+          #+INSTRUMENT-MEMOIZED (incf (memoized-funcs-calls s))
           (if foundp
               (progn
-                ;;(format t "Already seen <~a>~%" arg)
+                #+INSTRUMENT-MEMOIZED (incf (memoized-funcs-finds s))
                 value)
               (progn
-                ;;(format t "First time seen <~a>~%" arg)
+                #+INSTRUMENT-MEMOIZED (incf (memoized-funcs-news s))
                 (setf (gethash arg hash-table) (funcall func arg))))))))
 
 (defmacro memoize (func-name)