/usr/share/common-lisp/source/kmrcl/lists.lisp is in cl-kmrcl 1.106-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: lists.lisp
;;;; Purpose: Functions for lists for KMRCL package
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:kmrcl)
(defun mklist (obj)
"Make into list if atom"
(if (listp obj) obj (list obj)))
(defun map-and-remove-nils (fn lst)
"mao a list by function, eliminate elements where fn returns nil"
(let ((acc nil))
(dolist (x lst (nreverse acc))
(let ((val (funcall fn x)))
(when val (push val acc))))))
(defun filter (fn lst)
"Filter a list by function, eliminate elements where fn returns nil"
(let ((acc nil))
(dolist (x lst (nreverse acc))
(when (funcall fn x)
(push x acc)))))
(defun appendnew (l1 l2)
"Append two lists, filtering out elem from second list that are already in first list"
(dolist (elem l2 l1)
(unless (find elem l1)
(setq l1 (append l1 (list elem))))))
(defun remove-from-tree-if (pred tree &optional atom-processor)
"Strip from tree of atoms that satistify predicate"
(if (atom tree)
(unless (funcall pred tree)
(if atom-processor
(funcall atom-processor tree)
tree))
(let ((car-strip (remove-from-tree-if pred (car tree) atom-processor))
(cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor)))
(cond
((and car-strip (atom (cadr tree)) (null cdr-strip))
(list car-strip))
((and car-strip cdr-strip)
(cons car-strip cdr-strip))
(car-strip
car-strip)
(cdr-strip
cdr-strip)))))
(defun find-tree (sym tree)
"Finds an atom as a car in tree and returns cdr tree at that positions"
(if (or (null tree) (atom tree))
nil
(if (eql sym (car tree))
(cdr tree)
(aif (find-tree sym (car tree))
it
(aif (find-tree sym (cdr tree))
it
nil)))))
(defun flatten (tree)
(let ((result '()))
(labels ((scan (item)
(if (consp item)
(map nil #'scan item)
(push item result))))
(scan tree))
(nreverse result)))
;;; Keyword functions
;; ECL doesn't allow FOR clauses after UNTIL.
#-ecl
(defun remove-keyword (key arglist)
(loop for sublist = arglist then rest until (null sublist)
for (elt arg . rest) = sublist
unless (eq key elt) append (list elt arg)))
(defun remove-keywords (key-names args)
(loop for ( name val ) on args by #'cddr
unless (member (symbol-name name) key-names
:key #'symbol-name :test 'equal)
append (list name val)))
(defun mapappend (func seq)
(apply #'append (mapcar func seq)))
(defun mapcar-append-string-nontailrec (func v)
"Concatenate results of mapcar lambda calls"
(aif (car v)
(concatenate 'string (funcall func it)
(mapcar-append-string-nontailrec func (cdr v)))
""))
(defun mapcar-append-string (func v &optional (accum ""))
"Concatenate results of mapcar lambda calls"
(aif (car v)
(mapcar-append-string
func
(cdr v)
(concatenate 'string accum (funcall func it)))
accum))
(defun mapcar2-append-string-nontailrec (func la lb)
"Concatenate results of mapcar lambda call's over two lists"
(let ((a (car la))
(b (car lb)))
(if (and a b)
(concatenate 'string (funcall func a b)
(mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
"")))
(defun mapcar2-append-string (func la lb &optional (accum ""))
"Concatenate results of mapcar lambda call's over two lists"
(let ((a (car la))
(b (car lb)))
(if (and a b)
(mapcar2-append-string func (cdr la) (cdr lb)
(concatenate 'string accum (funcall func a b)))
accum)))
(defun append-sublists (list)
"Takes a list of lists and appends all sublists"
(let ((results (car list)))
(dolist (elem (cdr list) results)
(setq results (append results elem)))))
;; alists and plists
(defun alist-elem-p (elem)
(and (consp elem) (atom (car elem)) (atom (cdr elem))))
(defun alistp (alist)
(when (listp alist)
(dolist (elem alist)
(unless (alist-elem-p elem)
(return-from alistp nil)))
t))
(defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
"Macro to support below (setf get-alist)"
(let ((elem (gensym "ELEM-"))
(val (gensym "VAL-")))
`(let ((,elem (assoc ,akey ,alist :test ,test :key ,key))
(,val ,value))
(cond
(,elem
(setf (cdr ,elem) ,val))
(,alist
(setf (cdr (last ,alist)) (list (cons ,akey ,val))))
(t
(setf ,alist (list (cons ,akey ,val)))))
,alist)))
(defun get-alist (key alist &key (test #'eql))
(cdr (assoc key alist :test test)))
(defun (setf get-alist) (value key alist &key (test #'eql))
"This won't work if the alist is NIL."
(update-alist key value alist :test test)
value)
(defun remove-alist (key alist &key (test #'eql))
"Removes a key from an alist."
(remove key alist :test test :key #'car))
(defun delete-alist (key alist &key (test #'eql))
"Deletes a key from an alist."
(delete key alist :test test :key #'car))
(defun alist-plist (alist)
(apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))
(defun plist-alist (plist)
(do ((alist '())
(pl plist (cddr pl)))
((null pl) alist)
(setq alist (acons (car pl) (cadr pl) alist))))
(defmacro update-plist (pkey value plist &key (test '#'eql))
"Macro to support below (setf get-alist)"
(let ((pos (gensym)))
`(let ((,pos (member ,pkey ,plist :test ,test)))
(if ,pos
(progn
(setf (cadr ,pos) ,value)
,plist)
(setf ,plist (append ,plist (list ,pkey ,value)))))))
(defun unique-slot-values (list slot &key (test 'eql))
(let ((uniq '()))
(dolist (item list (nreverse uniq))
(let ((value (slot-value item slot)))
(unless (find value uniq :test test)
(push value uniq))))))
|