utils.lisp (2212 bytes)
1 (in-package :sl) 2 3 (eval-when (:compile-toplevel :load-toplevel :execute) 4 ;; From Graham's OnLisp 5 (defun pack (obj) 6 "Ensure obj is a cons." 7 (if (consp obj) obj (list obj))) 8 (defun shuffle (x y) 9 "Interpolate lists x and y with the first item being from x." 10 (cond ((null x) y) 11 ((null y) x) 12 (t (list* (car x) (car y) 13 (shuffle (cdr x) (cdr y)))))) 14 (defun interpol (obj lst) 15 "Intersperse an object in a list." 16 (shuffle lst (loop for #1=#.(gensym) in (cdr lst) 17 collect obj))) 18 (defun group (source n) 19 (labels ((rec (source acc) 20 (let ((rest (nthcdr n source))) 21 (if (consp rest) 22 (rec rest (cons 23 (subseq source 0 n) 24 acc)) 25 (nreverse 26 (cons source acc)))))) 27 (if source (rec source nil) nil))) 28 29 (defun select (fn lst) 30 "Return the first element that matches the function." 31 (if (null lst) 32 nil 33 (let ((val (funcall fn (car lst)))) 34 (if val 35 (values (car lst) val) 36 (select fn (cdr lst)))))) 37 38 (defun gen-case (base ex) 39 (if (symbolp ex) 40 (list 'eql base ex) 41 (append ex (list base)))) 42 43 (defun select-preference (boundp qnames) 44 "Choose the function to use based on user preference." 45 (labels ((select-preference-aux (boundp qnames preflist) 46 (when preflist 47 (let* ((res (select (lambda (x) 48 (string-equal (car x) (car preflist))) 49 qnames)) 50 (package (car res)) 51 (symname (cadr res))) 52 (if (and res (find-package package)) 53 (values symname package) 54 (select-preference-aux boundp qnames (cdr preflist))))))) 55 (select-preference-aux boundp qnames (mapcar #'car qnames)))) 56 57 (defmacro with-gensyms (symbols &body body) 58 "Create gensyms for those symbols." 59 `(let (,@(mapcar #'(lambda (sym) 60 `(,sym ',(gensym))) symbols)) 61 ,@body)))