utils.lisp

   1
   2 (in-package :cl-lwo)
   3
   4 ;; utils used throughout the code
   5
   6 (defmacro with-gensyms ((&rest names) &body body)
   7   `(let ,(loop for n in names collect `(,n (gensym)))
   8      ,@body))
   9
  10 (defmacro once-only ((&rest names) &body body)
  11   (let ((gensyms (loop for n in names collect (gensym))))
  12     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  13       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  14         ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  15            ,@body)))))
  16
  17 (defun make-extensible-string (dimensions &key (initial-element #\Space))
  18   "Create an ajustable string"
  19   (make-array dimensions
  20               :element-type 'character
  21               :initial-element initial-element
  22               :adjustable t
  23               :fill-pointer dimensions))
  24
  25 (defmacro indefinitely ((var form) &body body)
  26   "Expand to a form that repeatedly binds var to form and evaluates body until
  27    something goes wrong (like a condition being signalled)"
  28   `(do ((,var ,form ,form))
  29        (nil)
  30     ,@body))
  31
  32
  33 (defun extend-string (elements  string)
  34   "Add the elements to the end of the extensitble  string."
  35   (assert (adjustable-array-p  string))
  36   (labels
  37       ((extend-string-with-string (chars string)
  38          (iterate
  39           (for char in-vector chars)
  40           (vector-push-extend char string))
  41          string))
  42     (typecase elements
  43       (character (vector-push-extend elements string))
  44       (symbol (extend-string-with-string (string elements) string))
  45       (string (extend-string-with-string elements string))
  46       (number (extend-string-with-string (format nil "~D" elements) string))
  47       (list (mapcar #'(lambda (x)
  48                         (extend-string x string))
  49                     elements))))
  50   string)
  51
  52 (defun collapse-string (stringlist)
  53   "Given a list of strings collapse it to a single string."
  54   (let ((result (make-extensible-string 0)))
  55     (iterate
  56      (for string in stringlist)
  57      (iterate
  58       (for char in-vector string)
  59       (vector-push-extend char result)))
  60     result))
  61
  62
  63 (defmacro formatting (stream initial-string &rest args)
  64 "Format replacement using keywords rather than a control string."
  65 (labels
  66     ((add-numeric-control (control-char control-keys format-string)
  67        (extend-string #\~ format-string)
  68        (destructuring-bind
  69              (&key width fillchar form)
  70            control-keys
  71          (declare (ignore form))
  72          (when width
  73            (extend-string width format-string)
  74            (when fillchar
  75              (extend-string #\, format-string)
  76              (extend-string #\' format-string)
  77              (extend-string fillchar format-string)))
  78          (extend-string control-char format-string)))
  79      (process-control-item (control)
  80        (let ((format-string (make-extensible-string 0)))
  81          (typecase control
  82            (string
  83             (extend-string control format-string))
  84            ;; handle simle forms
  85            (symbol
  86             (case control
  87               (:tab (extend-string "~T" format-string))
  88               (:binary (extend-string "~B" format-string))
  89               (:octal (extend-string "~O" format-string))
  90               (:decimal (extend-string "~D" format-string))
  91               (:hex (extend-string "~X" format-string))
  92               (:newline (extend-string "~%" format-string))
  93               (:freshline (extend-string "~&" format-string))
  94               (:page (extend-string "~|" format-string))
  95               (:pretty (extend-string "~A" format-string))
  96               (:readable (extend-string "~S" format-string))
  97               (:write (extend-string "~W" format-string))))
  98            (list
  99             ;; handle complex forms
 100             (case (first control)
 101               (:binary (add-numeric-control #\B (rest control) format-string))
 102               (:octal (add-numeric-control #\O (rest control) format-string))
 103               (:decimal (add-numeric-control #\D (rest control) format-string))
 104               (:hex (add-numeric-control #\X (rest control) format-string))))
 105            (number
 106             (extend-string control format-string))
 107            (t nil))
 108          format-string))
 109      (process-argument-item (control)
 110        (typecase control
 111          (symbol (when (not (keywordp control)) control))
 112          (list (car (last control)))
 113          (t nil))))
 114   `(format ,stream
 115            ,(collapse-string (cons initial-string (mapcar   #'process-control-item args)))
 116            ,@(remove-if #'null (mapcar #'process-argument-item args)))))
 117