src/utils.lisp (2059 bytes)
1 (in-package :utils) 2 (defmacro with-gensyms (symbols &body body) 3 "Create gensyms for those symbols." 4 `(let (,@(mapcar #'(lambda (sym) 5 `(,sym ',(gensym))) symbols)) 6 ,@body)) 7 (defmacro doread((var stream) &body body) 8 "Read character by character with the speed of line by line reading." 9 (with-gensyms (line count len) 10 `(do ((,line #1=(read-line ,stream nil nil) #1#)) 11 ((null ,line)) 12 (do* ((,line (concatenate 'string ,line (format nil "~%~%"))) 13 (,len (length ,line)) 14 (,count 0 (1+ ,count)) 15 (,var #2=(elt ,line ,count) #2#)) 16 ((= (1- ,len) ,count)) 17 ,@body)))) 18 (defmacro once-only ((&rest names) &body body) 19 "A macro-writing utility for evaluating code only once." 20 (let ((gensyms (loop for n in names collect (gensym)))) 21 `(let (,@(loop for g in gensyms collect `(,g (gensym)))) 22 `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) 23 ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) 24 ,@body))))) 25 (defmacro make-reader (name (stream-var dispatch-1 dispatch-2) &body body) 26 (with-gensyms (sub-char numarg) 27 `(progn (defun ,name (,stream-var ,sub-char ,numarg) 28 (declare (ignore ,sub-char ,numarg)) 29 ,@body) 30 (set-dispatch-macro-character ,dispatch-1 ,dispatch-2 #',name)))) 31 (defun push-on (elem array) 32 (let ((len (length array))) 33 (adjust-array array (1+ len)) 34 (setf (elt array len) elem) 35 array)) 36 (defmacro dolines ((var path) &body body) 37 (with-gensyms (s) 38 `(with-open-file (,s ,path) 39 (do ((,var (read-line ,s nil nil) (read-line ,s nil nil))) 40 ((null ,var)) 41 ,@body)))) 42 (defmacro aif ((it conditional) then &optional else) 43 `(let ((,it ,conditional)) 44 (if ,it 45 ,then 46 ,else))) 47 (defmacro awhen ((it conditional) then) 48 `(aif (,it ,conditional) ,then)) 49 (defmacro abbrev (short long) 50 `(defmacro ,short (&rest args) 51 `(,',long ,@args))) 52 (abbrev mvbind multiple-value-bind) 53 (abbrev dbind destructuring-bind) 54 (defun list-directory (directory) 55 (directory (merge-pathnames "*.*" directory)))