utils.lisp

   1
   2 (in-package :lodematron)
   3
   4 ;; utils used throughout the code
   5
   6
   7 (defmacro with-gensyms ((&rest names) &body forms)
   8   "Create hygenic tempoary variables for macros"
   9   `(let ,(loop for n in names collect `(,n (gensym)))
  10      ,@forms))
  11
  12 (defmacro once-only ((&rest names) &body body)
  13   "Evaluate form once only and assign to temp var for macro body"
  14   (let ((gensyms (loop for n in names collect (gensym))))
  15     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  16       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  17         ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  18            ,@body)))))
  19
  20 (defmacro destructure-bits (bits vals &body forms)
  21   "Destructure a numeric variable into individual bits"
  22   (once-only (bits)
  23     `(let
  24          ,(loop
  25              for val in vals
  26              for mask = 1 then (ash mask 1)
  27              collect `(,val (logandc2 ,bits ,mask)))
  28        (declare (ignorable ,@vals))
  29        ,@forms)))
  30
  31
  32 (defun make-extensible-string (dimensions &key (initial-element #\Space))
  33   "Create an ajustable string"
  34   (make-array dimensions
  35               :element-type 'character
  36               :initial-element initial-element
  37               :adjustable t
  38               :fill-pointer dimensions))
  39
  40 (defmacro indefinitely ((var form) &body body)
  41   "Expand to a form that repeatedly binds var to form and evaluates body until
  42    something goes wrong (like a condition being signalled)"
  43   `(do ((,var ,form ,form))
  44        (nil)
  45     ,@body))
  46
  47
  48 (defun extend-string (elements  string)
  49   "Add the elements to the end of the extensitble  string."
  50   (assert (adjustable-array-p  string))
  51   (labels
  52       ((extend-string-with-string (chars string)
  53          (iterate
  54           (for char in-vector chars)
  55           (vector-push-extend char string))
  56          string))
  57     (typecase elements
  58       (character (vector-push-extend elements string))
  59       (symbol (extend-string-with-string (string elements) string))
  60       (string (extend-string-with-string elements string))
  61       (number (extend-string-with-string (format nil "~D" elements) string))
  62       (list (mapcar #'(lambda (x)
  63                         (extend-string x string))
  64                     elements))))
  65   string)
  66
  67 (defun collapse-string (stringlist)
  68   "Given a list of strings collapse it to a single string."
  69   (let ((result (make-extensible-string 0)))
  70     (iterate
  71      (for string in stringlist)
  72      (iterate
  73       (for char in-vector string)
  74       (vector-push-extend char result)))
  75     result))
  76
  77
  78 (defmacro formatting (stream initial-string &rest args)
  79 "Format replacement using keywords rather than a control string."
  80 (labels
  81     ((add-numeric-control (control-char control-keys format-string)
  82        (extend-string #\~ format-string)
  83        (destructuring-bind
  84              (&key width fillchar form)
  85            control-keys
  86          (declare (ignore form))
  87          (when width
  88            (extend-string width format-string)
  89            (when fillchar
  90              (extend-string #\, format-string)
  91              (extend-string #\' format-string)
  92              (extend-string fillchar format-string)))
  93          (extend-string control-char format-string)))
  94      (process-control-item (control)
  95        (let ((format-string (make-extensible-string 0)))
  96          (typecase control
  97            (string
  98             (extend-string control format-string))
  99            ;; handle simle forms
 100            (symbol
 101             (case control
 102               (:tab (extend-string "~T" format-string))
 103               (:binary (extend-string "~B" format-string))
 104               (:octal (extend-string "~O" format-string))
 105               (:decimal (extend-string "~D" format-string))
 106               (:hex (extend-string "~X" format-string))
 107               (:newline (extend-string "~%" format-string))
 108               (:freshline (extend-string "~&" format-string))
 109               (:page (extend-string "~|" format-string))
 110               (:pretty (extend-string "~A" format-string))
 111               (:readable (extend-string "~S" format-string))
 112               (:write (extend-string "~W" format-string))))
 113            (list
 114             ;; handle complex forms
 115             (case (first control)
 116               (:binary (add-numeric-control #\B (rest control) format-string))
 117               (:octal (add-numeric-control #\O (rest control) format-string))
 118               (:decimal (add-numeric-control #\D (rest control) format-string))
 119               (:hex (add-numeric-control #\X (rest control) format-string))))
 120            (number
 121             (extend-string control format-string))
 122            (t nil))
 123          format-string))
 124      (process-argument-item (control)
 125        (typecase control
 126          (symbol (when (not (keywordp control)) control))
 127          (list (car (last control)))
 128          (t nil))))
 129   `(format ,stream
 130            ,(collapse-string (cons initial-string (mapcar   #'process-control-item args)))
 131            ,@(remove-if #'null (mapcar #'process-argument-item args)))))
 132
 133
 134 (defun pad2 (i)
 135   (logandc1 #X1 (1+ i)))
 136
 137 (defun string-id (string)
 138   "Convert string into 4byte IFFF id"
 139   (logior
 140    (ash  (char-code  (char string 3)) 0)
 141    (ash  (char-code  (char string 2)) 8)
 142    (ash  (char-code  (char string 1)) 16)
 143    (ash  (char-code   (char string 0)) 24)))
 144
 145 (defun id-string (id)
 146   "Convert 4 byte IFFF id into string"
 147   (concatenate 'string
 148                (string (code-char (logand #XFF (ash id -24))))
 149                (string (code-char (logand #XFF (ash id -16))))
 150                (string (code-char (logand #XFF  (ash id -8))))
 151                (string (code-char (logand #XFF id)))))