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