diff options
Diffstat (limited to 'third_party/lisp/sclf/sclf.lisp')
| -rw-r--r-- | third_party/lisp/sclf/sclf.lisp | 1717 |
1 files changed, 0 insertions, 1717 deletions
diff --git a/third_party/lisp/sclf/sclf.lisp b/third_party/lisp/sclf/sclf.lisp deleted file mode 100644 index dfbc2078c829..000000000000 --- a/third_party/lisp/sclf/sclf.lisp +++ /dev/null @@ -1,1717 +0,0 @@ -;;; sclf.lisp --- miscellanea - -;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: SCLF - -#+cmu (ext:file-comment "$Module: sclf.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -;;; Commentary: - -;;; This is a collection of Common Lisp functions of the most disparate -;;; uses and purposes. These functions are too small or too unrelated -;;; to each other to deserve an own module. -;;; -;;; If you want to indent properly the following macros you should add -;;; the following lines to your .emacs file: -;;; -;;; (defun cl-indent-be (path state indent-point sexp-column normal-indent) -;;; (let ((sexp-start (cadr state)) -;;; (i 0)) -;;; (save-excursion -;;; (goto-char sexp-start) -;;; (forward-char) -;;; (+ sexp-column -;;; (block indentation -;;; (condition-case nil -;;; (while (< (point) indent-point) -;;; (setq i (1+ i)) -;;; (when (and (= 0 (logand i 1)) -;;; (looking-at "[\t\n ]*\\s(")) -;;; (return-from indentation 2)) -;;; (forward-sexp)) -;;; (error nil)) -;;; (if (= 1 (logand i 1)) -;;; 6 4)))))) -;;; -;;; (put 'be 'common-lisp-indent-function 'cl-indent-be) -;;; (put 'be* 'common-lisp-indent-function 'cl-indent-be) -;;; (put 'awhen 'lisp-indent-function 1) -;;; (put 'gcase 'lisp-indent-function 1) -;;; (put 'acase 'lisp-indent-function 1) -;;; (put 'acond 'lisp-indent-function 1) -;;; (put 'until 'lisp-indent-function 1) - - - -(cl:in-package :sclf) - -(defmacro be (&rest bindings-and-body) - "Less-parenthetic let." - (let ((bindings - (loop - while (and (symbolp (car bindings-and-body)) - (cdr bindings-and-body)) - collect (list (pop bindings-and-body) - (pop bindings-and-body))))) - `(let ,bindings - ,@bindings-and-body))) - -(defmacro be* (&rest bindings-and-body) - "Less-parenthetic let*." - (let ((bindings - (loop - while (and (symbolp (car bindings-and-body)) - (cdr bindings-and-body)) - collect (list (pop bindings-and-body) - (pop bindings-and-body))))) - `(let* ,bindings - ,@bindings-and-body))) - -(defmacro defconst (name value &rest etc) - "For some reason SBCL, between usefulness and adherence to the ANSI -standard, has chosen the latter, thus rendering the DEFCONSTANT pretty -useless. This macro works around that problem." - #+sbcl (list* 'defvar name value etc) - #-sbcl (list* 'defconstant name value etc)) - -(defmacro with-gensyms ((&rest symbols) &body body) - "Gensym all SYMBOLS and make them available in BODY. -See also LET-GENSYMS." - `(let ,(mapcar #'(lambda (s) - (list s '(gensym))) symbols) - ,@body)) - -(defun s+ (&rest strings) - "Return a string which is made of the concatenation of STRINGS." - (apply #'concatenate 'string strings)) - -(defun string-starts-with (prefix string &optional (compare #'string=)) - (be prefix-length (length prefix) - (and (>= (length string) prefix-length) - (funcall compare prefix string :end2 prefix-length)))) - -(defun string-ends-with (postfix string &optional (compare #'string=)) - "Return true if STRING's last characters are the same as POSTFIX." - (be postfix-length (length postfix) - string-length (length string) - (and (>= string-length postfix-length) - (funcall compare postfix string :start2 (- string-length postfix-length))))) - -(defun string-substitute (from to sequence &key (start 0) end (test #'eql)) - "Replace in SEQUENCE occurrences of FROM with TO. FROM and TO don't -need to be the same length." - (be from-length (length from) - (with-output-to-string (out) - (write-string sequence out :start 0 :end start) - (loop - for position = (search from sequence :start2 start :end2 end :test test) - while position - do - (write-string sequence out :start start :end position) - (write-string to out) - (setf start (+ position from-length)) - finally (write-string (subseq sequence start) out))))) - -(defun string-escape (string character &key (escape-character #\\) (escape-escape t)) - "Prepend all occurences of CHARACTER in STRING with a -ESCAPE-CHARACTER." - (with-output-to-string (stream) - (loop - for c across string - when (or (char= c character) - (and escape-escape - (char= c escape-character))) - do (write-char escape-character stream) - do (write-char c stream)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro aif (test then &optional else) - `(be it ,test - (if it - ,then - ,else))) - -(defmacro awhen (test &body then) - `(be it ,test - (when it - ,@then))) - -(defmacro acond (&body forms) - (when forms - `(aif ,(caar forms) - (progn ,@(cdar forms)) - (acond ,@(cdr forms))))) - -(defmacro aand (&rest args) - (cond ((null args) t) - ((null (cdr args)) (car args)) - (t `(aif ,(car args) (aand ,@(cdr args)))))) - -(defmacro acase (condition &body forms) - `(be it ,condition - (case it ,@forms))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst +whitespace+ '(#\return #\newline #\tab #\space #\page)) - -(defun string-trim-whitespace (string) - (string-trim +whitespace+ string)) - -(defun string-right-trim-whitespace (string) - (string-right-trim +whitespace+ string)) - -(defun string-left-trim-whitespace (string) - (string-left-trim +whitespace+ string)) - -(defun whitespace-p (char) - (member char +whitespace+)) - -(defun seq-whitespace-p (sequence) - (every #'whitespace-p sequence)) - -(defun not-empty (sequence) - "Return SEQUENCE if it's not empty, otherwise NIL. -NIL is indeed empty." - (when (or (listp sequence) - (not (zerop (length sequence)))) - sequence)) - -(defun position-any (bag sequence &rest position-args) - "Find any element of bag in sequence and return its position. -Accept any argument accepted by the POSITION function." - (apply #'position-if #'(lambda (element) - (find element bag)) sequence position-args)) - -(defun find-any (bag sequence &rest find-args) - "Find any element of bag in sequence. Accept any argument -accepted by the FIND function." - (apply #'find-if #'(lambda (element) - (find element bag)) sequence find-args)) - -(defun split-at (bag sequence &key (start 0) key) - "Split SEQUENCE at occurence of any element from BAG. -Contiguous occurences of elements from BAG are considered atomic; -so no empty sequence is returned." - (be len (length sequence) - (labels ((split-from (start) - (unless (>= start len) - (be sep (position-any bag sequence :start start :key key) - (cond ((not sep) - (list (subseq sequence start))) - ((> sep start) - (cons (subseq sequence start sep) - (split-from (1+ sep)))) - (t - (split-from (1+ start)))))))) - (split-from start)))) - -(defun split-string-at-char (string separator &key escape skip-empty) - "Split STRING at SEPARATORs and return a list of the substrings. If -SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is -not nil then split at SEPARATOR only if it's not preceded by ESCAPE." - (declare (type string string) (type character separator)) - (labels ((next-separator (beg) - (be pos (position separator string :start beg) - (if (and escape - pos - (plusp pos) - (char= escape (char string (1- pos)))) - (next-separator (1+ pos)) - pos))) - (parse (beg) - (cond ((< beg (length string)) - (let* ((end (next-separator beg)) - (substring (subseq string beg end))) - (cond ((and skip-empty (string= "" substring)) - (parse (1+ end))) - ((not end) - (list substring)) - (t - (cons substring (parse (1+ end))))))) - (skip-empty - '()) - (t - (list ""))))) - (parse 0))) - -(defun copy-stream (in out) - (loop - for c = (read-char in nil) - while c - do (write-char c out))) - -(defun pathname-as-file (pathname) - "Converts PATHNAME to file form and return it." - (unless (pathnamep pathname) - (setf pathname (pathname pathname))) - (cond ((pathname-name pathname) - pathname) - ((stringp (car (last (pathname-directory pathname)))) - (be name (parse-native-namestring (car (last (pathname-directory pathname)))) - (make-pathname :directory (butlast (pathname-directory pathname)) - :name (pathname-name name) - :type (pathname-type name) - :defaults pathname))) - ;; it can't be done? - (t pathname))) - -(defun copy-file (file copy-file &key (if-exists :error)) - (with-open-file (in file) - (with-open-file (out copy-file :direction :output :if-exists if-exists) - (copy-stream in out)))) - -(defun symlink-file (src dst &key (if-exists :error)) - (when (and (eq :supersede if-exists) - (probe-file dst)) - (delete-file dst)) - #+sbcl (sb-posix:symlink src dst) - #+cmu(unix:unix-symlink (native-namestring src) (native-namestring dst)) - #-(or sbcl cmu) (error "don't know how to symlink files")) - -(defun read-whole-stream (stream) - "Read stream until the end and return it as a string." - (with-output-to-string (string) - (loop - for line = (read-line stream nil) - while line - do (write-line line string)))) - -(defun read-lines (stream &optional n) - "Read N lines from stream and return them as a list of strings. If -N is NIL, read the whole stream til the end. If the stream ends -before N lines a read, this function will return those without -signalling an error." - (loop - for line = (read-line stream nil) - for i from 0 - while (and line - (or (not n) - (< i n))) - collect line)) - -(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) - "Read the whole content of file and return it as a sequence which -can be a string, a vector of bytes, or whatever you specify as -ELEMENT-TYPE." - (with-open-file (in pathname - :element-type element-type - :if-does-not-exist (unless (eq :value if-does-not-exist) - :error)) - (if in - (be seq (make-array (file-length in) :element-type element-type) - (read-sequence seq in) - seq) - default))) - -(defun write-file (pathname contents &key (if-exists :error)) - "Read the whole content of file and return it as a sequence which -can be a string, a vector of bytes, or whatever you specify as -ELEMENT-TYPE." - (with-open-file (out pathname - :element-type (if (stringp contents) - 'character - (array-element-type contents)) - :if-exists if-exists) - (write-sequence contents out))) - -(defun read-from-file (pathname &key (on-error :error) default) - "Similar to READ-FROM-STRING but for files. Read the first Lisp -object in file and return it. If file does not exist or does not -contain a readable Lisp object, ON-ERROR tells what to do. If -ON-ERROR is :ERROR, an error is signalled. If ON-ERROR is :VALUE, -DEFAULT is returned." - (ecase on-error - (:error - (with-open-file (in pathname) - (read in))) - (:value - (handler-case (with-open-file (in pathname) - (read in)) - (t () - default))))) - -(defun write-to-file (object pathname &key (if-exists :error) pretty) - "Similar to WRITE-TO-STRING but for files. Write OBJECT to a file -with pathname PATHNAME." - (with-open-file (out pathname :direction :output :if-exists if-exists) - (write object :stream out :escape t :readably t :pretty pretty))) - -(defun string-concat (list &optional (separator "")) - "Concatenate the strings in LIST interposing SEPARATOR (default -nothing) between them." - (reduce #'(lambda (&rest args) - (if args - (s+ (car args) separator (cadr args)) - "")) - list)) - -;; to indent it properly: (put 'gcase 'lisp-indent-function 1) -(defmacro gcase ((value &optional (test 'equalp)) &rest cases) - "Generic CASE macro. Match VALUE to CASES as if by the normal CASE -but use TEST as the comparison function, which defaults to EQUALP." - (with-gensyms (val) - `(be ,val ,value - ,(cons 'cond - (mapcar #'(lambda (case-desc) - (destructuring-bind (vals &rest forms) case-desc - `(,(cond ((consp vals) - (cons 'or (mapcar #'(lambda (v) - (list test val v)) - vals))) - ((or (eq vals 'otherwise) - (eq vals t)) - t) - (t (list test val vals))) - ,@forms))) - cases))))) - -(defun string-truncate (string max-length) - "If STRING is longer than MAX-LENGTH, return a shorter version. -Otherwise return the same string unchanged." - (if (> (length string) max-length) - (subseq string 0 max-length) - string)) - -;; to indent properly: (put 'until 'lisp-indent-function 1) -(defmacro until (test &body body) - (with-gensyms (result) - `(loop - for ,result = ,test - until ,result - do (progn ,@body) - finally (return ,result)))) - -(defun keywordify (string) - (intern (string-upcase string) :keyword)) - -(defun locate-system-program (name) - "Given the NAME of a system program try to find it through the -search of the environment variable PATH. Return the full -pathname." - (loop - for dir in (split-string-at-char (getenv "PATH") #\:) - for pathname = (merge-pathnames name (pathname-as-directory dir)) - when (probe-file pathname) - return pathname)) - -(defvar *tmp-file-defaults* #P"/tmp/") - -(defun temp-file-name (&optional (default *tmp-file-defaults*)) - "Create a random pathname based on DEFAULT. No effort is made -to make sure that the returned pathname doesn't identify an -already existing file. If missing DEFAULT defaults to -*TMP-FILE-DEFAULTS*." - (make-pathname :defaults default - :name (format nil "~36R" (random #.(expt 36 10))))) - -(defun open-temp-file (&optional default-pathname &rest open-args) - "Open a new temporary file and return a stream to it. This function -makes sure the pathname of the temporary file is unique. OPEN-ARGS -are arguments passed verbatim to OPEN. If OPEN-ARGS specify -the :DIRECTION it should be either :OUTPUT (default) or :IO; -any other value causes an error. If DEFAULT-PATHNAME is specified and -not NIL it's used as defaults to produce the pathname of the temporary -file, otherwise *TMP-FILE-DEFAULTS* is used." - (unless default-pathname - (setf default-pathname *tmp-file-defaults*)) - ;; if :DIRECTION is specified check that it's compatible with the - ;; purpose of this function, otherwise make it default to :OUTPUT - (aif (getf open-args :direction) - (unless (member it '(:output :io)) - (error "Can't create temporary file with open direction ~A." it)) - (setf open-args (append '(:direction :output) - open-args))) - (do* ((name #1=(temp-file-name default-pathname) #1#) - (stream #2=(apply #'open name - :if-exists nil - :if-does-not-exist :create - open-args) #2#)) - (stream stream))) - -(defmacro with-temp-file ((stream &rest open-temp-args) &body body) - "Execute BODY within a dynamic extent where STREAM is bound to -a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are -passed verbatim to OPEN-TEMP-FILE." - `(be ,stream (open-temp-file ,@open-temp-args) - (unwind-protect - (progn ,@body) - (close ,stream) - ;; body may decide to rename the file so we must ignore the errors - (ignore-errors - (delete-file (pathname ,stream)))))) - -(defmacro with-hidden-temp-file ((stream &rest open-args) &body body) - "Just like WITH-TEMP-FILE but unlink (delete) the temporary file -before the execution of BODY. As such BODY won't be able to -manipulate the file but through STREAM, and no other program is able -to see it. Once STREAM is closed the temporary file blocks are -automatically relinquished by the operating system. This works at -least on Unix filesystems. I don't know about MS-OSs where the system -may likely decide to crash, take all your data with it and, in the -meanwhile, report you to the NSA as terrorist." - `(be ,stream (open-temp-file ,@open-args) - (unwind-protect - (progn (delete-file (pathname ,stream)) - ,@body) - (close ,stream)))) - -(defun insert-in-order (item seq &key (test #'<) key) - "Destructively insert ITEM in LIST in order by TEST. Return -the new list. This is a simple wrapper around MERGE." - (merge (if seq - (type-of seq) - 'list) - (list item) seq test :key key)) - -(defmacro f++ (x &optional (delta 1)) - "Same as INCF but hopefully optimised for fixnums." - `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) - -(defun soundex (word &optional (key-length 4)) - "Knuth's Soundex algorithm. Returns a string representing the -sound of a certain word (English). Different words will thus -yield the same output string. To compare two string by the -sound, simply do: - - (string= (soundex str1) (soundex str2)) - -Examples: - - (soundex \"Knuth\") => \"K530\" - (soundex \"Kant\") => \"K530\" - (soundex \"Lloyd\") => \"L300\" - (soundex \"Ladd\") => \"L300\"" - (declare (type string word)) - (flet ((translate-char (char) - (awhen (position char "BFPVCGJKQSXZDTLMNR") - (elt "111122222222334556" it)))) - (let ((key (make-string key-length :initial-element #\0)) - (word-length (length word))) - (setf (elt key 0) (elt word 0)) - (loop - with previous-sound = (translate-char (char-upcase (elt word 0))) - with j = 1 - for i from 1 by 1 below word-length - for c = (char-upcase (elt word i)) - while (< j key-length) - do (be sound (translate-char c) - (cond ((not (eq sound previous-sound)) - (unless (member c '(#\H #\W)) - (setf previous-sound sound)) - (when sound - (setf (elt key j) sound) - (incf j)))))) - key))) - -(defun string-soundex= (string1 string2) - (let ((l1 (split-at +whitespace+ string1)) - (l2 (split-at +whitespace+ string2))) - (and (= (length l1) (length l2)) - (every #'string= (mapcar #'soundex l1) (mapcar #'soundex l2))))) - -#+(OR) -(defun soundex-test () - (let* ((words1 '("Euler" "Gauss" "Hilbert" "Knuth" "Lloyd" "Lukasiewicz" "Wachs")) - (words2 '("Ellery" "Ghosh" "Heilbronn" "Kant" "Ladd" "Lissajous" "Waugh")) - (results '("E460" "G200" "H416" "K530" "L300" "L222" "W200"))) - (mapc #'(lambda (w1 w2 r) - (let ((r1 (soundex w1)) - (r2 (soundex w2))) - (format t "~A = ~A, ~A = ~A => ~A~%" w1 r1 w2 r2 - (if (and (string= r1 r2) - (string= r r1)) - "OK" - (format nil "ERROR (expected ~A)" r))))) - words1 words2 results) - (values))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; (defstruct cache-slot () -;; ((previous :type (or cache-slot null) -;; :initarg :previous -;; :initform nil -;; :accessor cslot-previous) -;; (key :initarg :key -;; :accessor cslot-key) -;; (value :initarg :value -;; :accessor cslot-value) -;; (next :type (or cache-slot null) -;; :initarg :next -;; :initform nil -;; :accessor cslot-next))) - -;; (defmethod print-object ((object cache-slot) stream) -;; (print-unreadable-object (object stream :type t) -;; (if (slot-boundp object 'key) -;; (format stream "key=~S, value=~S" (cslot-key object) (cslot-value object)) -;; (format stream "NULL")))) - - -(defstruct (double-linked-element (:conc-name dle-)) - (previous nil :type (or double-linked-element null)) - value - (next nil :type (or double-linked-element null))) - -(defmethod print-object ((object double-linked-element) stream) - (print-unreadable-object (object stream :type t) - (format stream "value=~S" (dle-value object)))) - -(defun cons-dle (value previous next) - (declare (type (or double-linked-element null) previous next)) - (be new-element (make-double-linked-element :previous previous :next next :value value) - (when previous - (setf (dle-next previous) new-element)) - (when next - (setf (dle-previous next) new-element)) - new-element)) - -(defun dle-remove (dle-object) - "Remove the DLE-OBJECT from its current position in the list of -elements agjusting the pointer of dle-objects before and after this -one (if any)." - (declare (type double-linked-element dle-object)) - (awhen (dle-next dle-object) - (setf (dle-previous it) (dle-previous dle-object))) - (awhen (dle-previous dle-object) - (setf (dle-next it) (dle-next dle-object)))) - -(defun dle-map (function dle-object) - (when dle-object - (make-double-linked-element :value (funcall function (dle-value dle-object)) - :previous (dle-previous dle-object) - :next (dle-map function (dle-next dle-object))))) - -(defmacro do-dle ((var dle &optional (result nil)) &body body) - "Iterate over a list of DOUBLE-LINKED-ELEMENTs and map body to -each element's value. Bind VAR to the value on each iteration." - (be cursor (gensym) - `(do ((,cursor ,dle (dle-next ,cursor))) - ((not ,cursor) ,result) - (be ,var (dle-value ,cursor) - ,@body)))) - -(defmacro do-dle* ((var dle &optional (result nil)) &body body) - "Same as DO-DLE but VAR is a symbol macro, so that BODY can -modify the element's value." - (be cursor (gensym) - `(symbol-macrolet ((,var (dle-value ,cursor))) - (do ((,cursor ,dle (dle-next ,cursor))) - ((not ,cursor) ,result) - ,@body)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass double-linked-list () - ((elements :type double-linked-element - :documentation "The actual list of elements held by this object.") - (last-element :type double-linked-element)) - (:documentation - "A double linked list where elements can be added or removed -from either end.")) - -(defmethod initialize-instance ((object double-linked-list) &rest rest) - (declare (ignorable rest)) - (call-next-method) - (with-slots (last-element elements) object - (setf last-element (make-double-linked-element) - elements last-element))) - -(defmethod print-object ((object double-linked-list) stream) - (print-unreadable-object (object stream :type t) - (be elements '() - (do-dle (e (slot-value object 'elements)) - (push e elements)) - (format stream "elements=~S" (nreverse elements))))) - -(defgeneric pop-first (double-linked-list) - (:documentation - "Pop the first element of a double-linked-list.")) -(defgeneric pop-last (double-linked-list) - (:documentation - "Pop the last element of a double-linked-list.")) -(defgeneric push-first (item double-linked-list) - (:documentation - "Push an item in front of a double-linked-list.")) -(defgeneric push-last (item double-linked-list) - (:documentation - "Append an item to a double-linked-list.")) -(defgeneric list-map (function double-linked-list) - (:documentation - "Map a function to a double-linked-list.")) -(defgeneric dll-find-cursor (object dll &key test key)) -(defgeneric dll-find (object dll &key test key)) -(defgeneric dll-remove (cursor dll)) - -(defmethod pop-last ((list double-linked-list)) - "Drop the last element in the dl list." - (with-slots (last-element) list - (awhen (dle-previous last-element) - (dle-remove it) - (dle-value it)))) - -(defmethod pop-first ((list double-linked-list)) - "Drop the first element in the dl list." - (with-slots (elements) list - (when (dle-next elements) - (prog1 (dle-value elements) - (setf (dle-previous (dle-next elements)) nil - elements (dle-next elements)))))) - -(defmethod push-first (value (list double-linked-list)) - (with-slots (elements) list - (setf elements (cons-dle value nil elements))) - list) - -(defmethod push-last (value (list double-linked-list)) - (with-slots (last-element) list - (cons-dle value (dle-previous last-element) last-element)) - list) - -(defmethod list-map (function (list double-linked-list)) - (labels ((map-dll (dle) - (when (dle-next dle) - (make-double-linked-element - :value (funcall function (dle-value dle)) - :previous (dle-previous dle) - :next (map-dll (dle-next dle)))))) - (map-dll (slot-value list 'elements)))) - -(defmethod dll-find-cursor (object (list double-linked-list) &key (test #'eql) (key #'identity)) - (do ((cursor (slot-value list 'elements) (dle-next cursor))) - ((not (dle-next cursor))) - (be value (dle-value cursor) - (when (funcall test (funcall key value) object) - (return cursor))))) - -(defmethod dll-find (object (list double-linked-list) &key (test #'eql) (key #'identity)) - (awhen (dll-find-cursor object list :test test :key key) - (dle-value it))) - -(defmethod dll-remove ((cursor double-linked-element) (list double-linked-list)) - (with-slots (elements) list - (if (dle-previous cursor) - (dle-remove cursor) - (setf (dle-previous (dle-next elements)) nil - elements (dle-next elements)))) - list) - -(defmacro do-dll ((var list &optional (result nil)) &body body) - "Iterate over a dll and map body to each element's -value. Bind VAR to the value on each iteration." - (be cursor (gensym) - `(do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor))) - ((not (dle-next ,cursor)) ,result) - (be ,var (dle-value ,cursor) - ,@body)))) - -(defmacro do-dll* ((var list &optional (result nil)) &body body) - "Same as DO-DLL but VAR is a symbol macro, so that BODY can -modify the element's value." - (be cursor (gensym) - `(symbol-macrolet ((,var (dle-value ,cursor))) - (do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor))) - ((not (dle-next ,cursor)) ,result) - ,@body)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass limited-list (double-linked-list) - ((max-size :initform nil - :initarg :size - :reader max-size - :type (or integer null) - :documentation "Size limit to which the list is allowed to grow to. NIL = no limit.") - (size :initform 0 - :reader size - :type integer - :documentation "Current number of elements in the list.")) - (:documentation - "A double linked list where the maximum number of elements can -be limited.")) - -(defun dll-member-p (dle list) - (with-slots (elements size) list - (do ((e elements (dle-next e))) - ((not e)) - (when (eq e dle) - (return t))))) - -(defmethod dll-remove ((cursor double-linked-element) (list limited-list)) - (with-slots (size) list - (unless (zerop size) - (decf size) - (call-next-method))) - list) - -(defmethod pop-first ((list limited-list)) - (with-slots (size) list - (unless (zerop size) - (decf size) - (call-next-method)))) - -(defmethod pop-last ((list limited-list)) - (with-slots (size) list - (unless (zerop size) - (decf size) - (call-next-method)))) - -(defmethod push-first (value (list limited-list)) - "Add in front of the list and drop the last element if list is -full." - (declare (ignore value)) - (prog1 (call-next-method) - (with-slots (max-size size last-element) list - (if (or (not max-size) - (< size max-size)) - (incf size) - (dle-remove (dle-previous last-element)))))) - -(defmethod push-last (value (list limited-list)) - "Add at the end of the list and drop the first element if list -is full." - (declare (ignore value)) - (prog1 (call-next-method) - (with-slots (max-size size elements) list - (if (or (not max-size) - (< size max-size)) - (incf size) - (setf (dle-previous (dle-next elements)) nil - elements (dle-next elements)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass sorted-list (limited-list) - ((test :type function - :initarg :test)) - (:documentation - "A double linked list where elements are inserted in a -sorted order.")) - -(defgeneric insert (item sorted-list) - (:documentation - "Insert an item in a sorted-list.")) - -(defmethod insert (item (sl sorted-list)) - "Insert ITEM in SL, which is a sorted double linked list, -before the item for which TEST is true or at the end of the list. -Returns two values, the modified list and the cursor to the new -element." - (with-slots (max-size size elements test last-element) sl - (do ((cursor elements (dle-next cursor))) - ((or (not (dle-next cursor)) - (funcall test item (dle-value cursor))) - (if (dle-previous cursor) - (cons-dle item (dle-previous cursor) cursor) - (setf elements (cons-dle item nil cursor))) - (if (or (not max-size) - (< size max-size)) - (incf size) - (dle-remove (dle-previous last-element))) - (values sl (dle-previous cursor)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass heap () - ((less-than :type function - :initarg :test - :documentation "The heap invariant.") - (data :type array - :documentation "The heap tree representation."))) - -(defmethod initialize-instance ((heap heap) &rest args) - (declare (ignore args)) - (call-next-method) - (with-slots (data) heap - (setf data (make-array 0 :fill-pointer 0 :adjustable t)))) - -(defgeneric heap-add (heap item)) - -(defun bubble-up (heap pos) - (with-slots (data less-than) heap - (loop - for current = pos then parent - for parent = (truncate (1- current) 2) - until (or (zerop current) - (funcall less-than (aref data parent) (aref data current))) - do (rotatef (aref data current) (aref data parent))))) - -(defmethod heap-add ((heap heap) item) - (with-slots (data) heap - (vector-push-extend item data) - (bubble-up heap (1- (fill-pointer data))))) - -(defgeneric heap-size (heap)) - -(defmethod heap-size ((heap heap)) - (fill-pointer (slot-value heap 'data))) - -(defgeneric heap-empty-p (heap)) - -(defmethod heap-empty-p ((heap heap)) - (zerop (heap-size heap))) - - -(defgeneric heap-pop (heap)) - -(defun percolate-down (heap pos) - (with-slots (data less-than) heap - (loop - with end = (fill-pointer data) - for current = pos then child - for left-child = (+ 1 (* 2 current)) - for right-child = (+ 2 (* 2 current)) - for child = (cond ((>= left-child end) - (return)) - ((>= right-child end) - left-child) - ((funcall less-than (aref data left-child) (aref data right-child)) - left-child) - (t - right-child)) - while (funcall less-than (aref data child) (aref data current)) - do (rotatef (aref data current) (aref data child))))) - -(defmethod heap-pop ((heap heap)) - (assert (not (heap-empty-p heap))) - (with-slots (data) heap - (be root (aref data 0) - (setf (aref data 0) (vector-pop data)) - (percolate-down heap 0) - root))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct (lru-cache-slot (:include double-linked-element) - (:conc-name lruc-slot-)) - key) - -(defmethod print-object ((object lru-cache-slot) stream) - (print-unreadable-object (object stream :type t) - (format stream "key=~S value=~S" (lruc-slot-key object) (lruc-slot-value object)))) - -(defvar *default-cache-size* 100 - "Default size of a LRU cache if it's not specified at instantiation -time.") - -(defclass lru-cache () - ((max-size :initform *default-cache-size* - :initarg :size - :reader max-size - :type (or integer null) - :documentation - "Maximum number of elements that the cache can fit.") - (elements-list :type lru-cache-slot - :documentation "The list of elements held by the cache.") - (elements-hash :type hash-table - :documentation "The hash table of the elements held bye the cache.") - (last-element :type lru-cache-slot) - (size :initform 0 - :reader size - :type integer - :documentation "Current number of elements in the cache.") - (finalizer :initform nil - :initarg :finalizer - :documentation - "Procedure to call when elements are dropped from cache.")) - (:documentation - "An objects cache that keeps the elements used more often and -drops those that are used less often. The usage is similar to an -hash table. Elements are added to the list up to MAX-SIZE, then -any new element will drop the less used one in the cache. Every -time an element is set or retrieved it goes in front of a list. -Those which get at the end of the list are dropped when more room -is required.")) - -(defmethod initialize-instance ((object lru-cache) &key test &allow-other-keys) - (call-next-method) - (with-slots (last-element elements-list elements-hash) object - (setf last-element (make-lru-cache-slot) - elements-list last-element - elements-hash (if test - (make-hash-table :test test) - (make-hash-table))))) - -(defgeneric getcache (key cache) - (:documentation - "Get an item with KEY from a CACHE.")) - -(defgeneric (setf getcache) (value key cache) - (:documentation - "Set or add an item with KEY in a CACHE.")) - -(defgeneric remcache (key cache) - (:documentation - "Remove an item with KEY from a CACHE.")) - -(defun move-in-front-of-cache-list (slot cache) - "Relocate slot to the front of the elements list in cache. -This will stretch its lifespan in the cache." - (declare (type lru-cache-slot slot) - (type lru-cache cache)) - (with-slots (elements-list) cache - ;; unless it's already the first - (unless (eq slot elements-list) - ;; remove the slot from its original place... - (dle-remove slot) - ;; ... and add it in front of the list - (setf (lruc-slot-next slot) elements-list - (lruc-slot-previous slot) nil - (lruc-slot-previous elements-list) slot - elements-list slot)))) - -(defun drop-last-cache-element (cache) - "Drop the last element in the list of the cache object." - (declare (type lru-cache cache)) - (with-slots (last-element elements-hash finalizer) cache - (let ((second-last (lruc-slot-previous last-element))) - (assert second-last) - (when finalizer - (funcall finalizer (lruc-slot-value second-last))) - (dle-remove second-last) - (remhash (lruc-slot-key second-last) elements-hash)))) - -(defun add-to-cache (slot cache) - (declare (type lru-cache-slot slot) - (type lru-cache cache)) - (move-in-front-of-cache-list slot cache) - (with-slots (max-size size elements-hash) cache - (setf (gethash (lruc-slot-key slot) elements-hash) slot) - (if (and max-size - (< size max-size)) - (incf size) - (drop-last-cache-element cache)))) - -(defmethod getcache (key (cache lru-cache)) - (multiple-value-bind (slot found?) (gethash key (slot-value cache 'elements-hash)) - (when found? - (move-in-front-of-cache-list slot cache) - (values (lruc-slot-value slot) t)))) - -(defmethod (setf getcache) (value key (cache lru-cache)) - (with-slots (elements-hash elements-list) cache - (multiple-value-bind (slot found?) (gethash key elements-hash) - (if found? - (progn - (move-in-front-of-cache-list slot cache) - (setf (lruc-slot-value slot) value)) - (add-to-cache (make-lru-cache-slot :key key :value value) cache)) - value))) - -(defmethod remcache (key (cache lru-cache)) - (with-slots (elements-hash size elements-list finalizer) cache - (multiple-value-bind (slot found?) (gethash key elements-hash) - (when found? - (remhash key elements-hash) - (when finalizer - (funcall finalizer (lruc-slot-value slot))) - (when (eq slot elements-list) - (setf elements-list (dle-next slot))) - (dle-remove slot) - (decf size) - t)))) - -(defmacro cached (cache key value) - "If KEY is found in CACHE return the associated object. Otherwise -store VALUE for later re-use." - (with-gensyms (object my-cache my-key my-value found?) - `(let* ((,my-cache ,cache) - (,my-key ,key)) - (multiple-value-bind (,object ,found?) (getcache ,my-key ,my-cache) - (if ,found? - ,object - (let ((,my-value ,value)) - (setf (getcache ,my-key ,my-cache) ,my-value) - ,my-value)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(declaim (inline list->string)) -(defun list->string (list) - "Coerce a list of characters into a string." - (coerce list 'string)) - -(defun setuid (id) - "Set the Unix real user id." - (when (stringp id) - (setf id (find-uid id))) - #+sbcl (sb-posix:setuid id) - #+cmu (unix:unix-setuid id) - #+clisp (posix::%setuid id) ; not verified -wcp26/8/09. - #-(or cmu sbcl clisp) - (error "setuid unsupported under this Lisp implementation")) - -(defun seteuid (id) - "Set the Unix effective user id." - (when (stringp id) - (setf id (find-uid id))) - #+sbcl (sb-posix:seteuid id) - #+cmu (unix:unix-setreuid -1 id) - #+clisp (posix::%seteuid id) ; not verified -wcp26/8/09. - #-(or cmu sbcl clisp) - (error "seteuid unsupported under this Lisp implementation")) - -(defun find-uid (name) - "Find the user id of NAME. Return an integer." - #+sbcl (awhen (sb-posix:getpwnam name) - (sb-posix:passwd-uid it)) - #+cmu (awhen (unix:unix-getpwnam name) - (unix:user-info-uid it)) - #-(or cmu sbcl) - (error "Unable to find a UID on this Lisp system.")) - -#+clisp (ffi:def-call-out %getuid - (:name "getuid") - (:arguments) - (:return-type ffi:int) - (:library "libc.so")) - -(defun getuid () - "Return the Unix user id. This is an integer." - #+sbcl (sb-unix:unix-getuid) - #+cmu (unix:unix-getuid) - #+clisp (%getuid) - #-(or cmu sbcl clisp) - (error "getuid unsupported under this Lisp implementation")) - -(defun super-user-p (&optional id) - "Return true if the user ID is zero. ID defaults to the current -user id." - (zerop (or id (getuid)))) - -(defmacro with-euid (uid &body forms) - "Switch temporarely to Unix user id UID, while performing FORMS." - (with-gensyms (ruid) - `(be ,ruid (getuid) - (seteuid ,uid) - (unwind-protect (progn ,@forms) - (seteuid ,ruid))))) - -(defun get-logname (&optional uid) - "Return the login id of the user. This is a string and it is not -the Unix uid, which is a number." - (unless uid - (setf uid (getuid))) - (when (stringp uid) - (setf uid (find-uid uid))) - (when uid - #+sbcl (sb-unix:uid-username uid) - #+cmu (unix:user-info-name (unix:unix-getpwuid uid)) - #+clisp (posix:user-info-login-id (posix:user-info uid)) - #-(or cmu sbcl clisp) - (error "get-logname unsupported under this Lisp implementation"))) - -(defun get-user-name (&optional uid) - "Return the user name, taken from the GCOS field of the /etc/passwd -file." - (unless uid - (setf uid (getuid))) - (when (stringp uid) - (setf uid (find-uid uid))) - (when uid - (car (split-string-at-char #+cmu (unix:user-info-gecos (unix:unix-getpwuid uid)) - #+sbcl (sb-posix:passwd-gecos (sb-posix:getpwuid uid)) - #-(or cmu sbcl) (error "can't getpwuid() on this Lisp system.") - #\,)))) - -(defun get-user-home (&optional uid) - (unless uid - (setf uid (getuid))) - (when (stringp uid) - (setf uid (find-uid uid))) - (when uid - #+cmu (unix:user-info-dir (unix:unix-getpwuid uid)) - #+sbcl (sb-posix:passwd-dir (sb-posix:getpwuid uid)))) - -;; Rather stupid, but the mnemonic is worth it -(declaim (inline alist->plist)) -(defun alist->plist (alist) - "Convert an association list into a property list. The alist -elements are assumed to be lists of just two elements: the key -and the value. If the element list is longer this function -doesn't work." - (mapcan #'identity alist)) - -(defun plist->alist (plist &optional pairs-p) - "Convert a property list into an association list. The alist -elements wiil be lists of just two elements: the key and the -value. If PAIRS-P is true the alist elements will be pairs." - (loop - for (key val) on plist by #'cddr - collect (if pairs-p - (cons key val) - (list key val)))) - -(defun string->byte-vector (string &key start end) - "Convert a string of characters into a vector of (unsigned-byte -8) elements." - (map '(vector (unsigned-byte 8)) #'char-code - (if (or start end) - (subseq string (or start 0) end) - string))) - -(defun byte-vector->string (vector &key start end) - "Convert a vector of (unsigned-byte 8) elements into a string -of characters." - (map 'string #'code-char - (if (or start end) - (subseq vector (or start 0) end) - vector))) - -(defun outdated-p (file dependencies) - "Check if FILE has been modified before any of its -DEPENDENCIES." - (be epoch (and (probe-file file) - (file-write-date file)) - ;; if file is missing altogether, we consider it outdated - (or (not epoch) - (loop - for dep in dependencies - thereis (aand (probe-file dep) - (file-write-date dep) - (> it epoch)))))) - -(defmacro let-places (places-and-values &body body) - "Execute BODY binding temporarily some places to new values and -restoring the original values of these places on exit of BODY. The -syntax of this macro is identical to LET. The difference is that -instead of new variable names this macro binds values to existing -places (variables)." - (be tmp-variables (loop for x in places-and-values collect (gensym)) - `(let ,(mapcar #'(lambda (tmp-var place-and-value) - (list tmp-var (car place-and-value))) - tmp-variables places-and-values) - (unwind-protect - (progn - ;; as some assignments could signal an error, we assign - ;; within the unwind-protect block so that we can always - ;; guarantee a consistent state on exit - ,@(mapcar #'(lambda (place-and-value) - `(setf ,(car place-and-value) ,(cadr place-and-value))) - places-and-values) - ,@body) - ,@(mapcar #'(lambda (tmp-var place-and-value) - `(setf ,(car place-and-value) ,tmp-var)) - tmp-variables - places-and-values))))) - -(defmacro let-slots (accessor/new-value-pairs object &body body) - "Execute BODY with some OBJECT's slots temporary sets to new -values as described in ACCESSOR/NEW-VALUE-PAIRS. The latter -should be an alist of accessor names and the value to be assigned -to that slot. On exit from BODY, those slots are restored to -their original value. See LET-PLACES." - (with-gensyms (obj) - `(be ,obj ,object - (let-places ,(mapcar #'(lambda (av) - `((,(car av) ,obj) ,(cadr av))) - accessor/new-value-pairs) - ,@body)))) - -(defvar *decimal-point* #\.) -(defvar *thousands-comma* #\,) - -(defun format-amount (number &key (decimals 2) (rounder #'round) - (comma *thousands-comma*) (comma-stance 3) - (decimal-point *decimal-point*)) - "Return a string formatted as fixed decimal point number of DECIMALS -adding commas every COMMA-STANCE places before the decimal point." - (declare (type number number) - (type fixnum decimals comma-stance) - (type function rounder) - (type character comma decimal-point) - (optimize (speed 3) (safety 0) (debug 0))) - (let* ((int (funcall rounder (* number (expt 10 decimals)))) - (negative (< int 0))) - (declare (integer int)) - (when negative - (setf int (- int))) - (let* ((digits (max (1+ decimals) - (1+ (if (zerop int) - 0 - (truncate (log int 10)))))) - (string-length (+ digits - ;; the minus sign - (if negative 1 0) - ;; the decimal point - (if (zerop decimals) 0 1) - ;; the thousands commas - (1- (ceiling (- digits decimals) comma-stance)))) - (string (make-string string-length)) - (pos (1- string-length))) - (declare (type fixnum pos digits)) - (labels ((add-char (char) - (setf (schar string pos) char) - (decf pos)) - (add-digit () - (add-char (digit-char (mod int 10))) - (setf int (truncate int 10)))) - (unless (zerop decimals) - (loop - for i fixnum from 0 below decimals - do (add-digit)) - (add-char decimal-point)) - (loop - for i fixnum from 1 - do (add-digit) - while (>= pos (if negative 1 0)) - when (zerop (mod i comma-stance)) - do (add-char comma)) - (when negative - (add-char #\-))) - string))) - -(defun parse-amount (string &key (start 0) end) - "Parse STRING as if it was formatted with FORMAT-AMOUNT and return -the parsed number. Return NIL if STRING is malformed. Leading or -trailing spaces must be removed from the string in advance." - (loop - with amount = 0 - with decimals = nil - with negative = (when (and (not (zerop (length string))) - (char= #\- (char string 0))) - (incf start) - t) - for i from start below (or end (length string)) - for c = (char string i) - do (cond ((char= c *decimal-point*) - (if decimals - (return nil) - (setf decimals 0))) - ((char= c *thousands-comma*)) - (t - (be d (digit-char-p c) - (cond ((not d) - (return nil)) - (decimals - (incf decimals) - (incf amount (/ d (expt 10 decimals)))) - (t - (setf amount (+ d (* amount 10)))))))) - finally (return (if negative - (- amount) - amount)))) - -(defmacro with-package (name &body body) - `(let ((*package* (find-package ,name))) - ,@body)) - -(defun bytes-simple-string (n &optional imply-bytes) - "Return a string describing N using a unit of measure multiple -of a byte that is most apporpriate for the magnitude of N. A -kilobyte is 1024 not 1000 bytes, everything follows." - (let* ((kilo 1024) - (mega (* kilo kilo)) - (giga (* kilo mega)) - (tera (* mega mega)) - (peta (* kilo tera))) - (apply #'format nil "~,1F~A" - (cond ((> n (* 2 peta)) - (list (/ n peta) (if imply-bytes "P" "PB"))) - ((> n (* 2 tera)) - (list (/ n tera) (if imply-bytes "T" "TB"))) - ((> n (* 2 giga)) - (list (/ n giga) (if imply-bytes "G" "GB"))) - ((> n (* 2 mega)) - (list (/ n mega) (if imply-bytes "M" "MB"))) - ((> n (* 2 kilo)) - (list (/ n kilo) (if imply-bytes "K" "KB"))) - (t (list n (if imply-bytes "" " bytes"))))))) - -;; WARNING: This function may or may not work on your Lisp system. It -;; all depends on how the OPEN function has been implemented regarding -;; the :IF-EXISTS option. This function requires that OPEN be -;; implemented in a way so that the checking of the existence of file -;; and its open attempt be atomic. If the Lisp OPEN first checks that -;; the file exists and then tries to open it, this function won't be -;; reliable. CMUCL seems to use the O_EXCL open() flag in the right -;; way. So at least on CMUCL this function will work. Same goes for -;; SBCL. -(defun make-lock-files (pathnames &key (sleep-time 7) retries (suspend 13) expiration) - "Create semaphore files. If it can't create all the specified -files in the specified order, it waits SLEEP-TIME seconds and -retries the last file that didn't succeed. You can specify the -number of RETRIES to do until failure is returned. If the number -of retries is NIL this function will retry forever. - -If it tries RETRIES times without success, this function signal -an error and removes all the lock files it created until then. - -All files created by lock file will be read-only. - -If you specify a EXPIRATION then an existing lock file will be -removed by force after EXPIRATION seconds have passed since the -lock file was last modified/created (most likely by some other -program that unexpectedly died without cleaning up its lock -files). After a lock file has been removed by force, a -suspension of SUSPEND seconds is taken into account, in order to -prevent the inadvertent immediate removal of any newly created -lock file by another program." - (be locked '() - (flet ((lock (file) - (when (and expiration - (> (get-universal-time) - (+ (file-write-date file) expiration))) - (delete-file file) - (when suspend - (sleep suspend))) - (do ((i 0 (1+ i)) - (done nil)) - (done) - (unless (or (not retries) - (< i retries)) - (error "Can't create lock file ~S: tried ~A time~:P." file retries)) - (with-open-file (out file :direction :output :if-exists nil) - (cond (out - (format out "Lock file created on ~A~%" (time-string (get-universal-time))) - (setf done t)) - (sleep-time - (sleep sleep-time))))))) - (unwind-protect - (progn - (dolist (file pathnames) - (lock file) - (push file locked)) - (setf locked '())) - (mapc #'delete-file locked))))) - -(defmacro with-lock-files ((lock-files &rest lock-args) &body body) - "Execute BODY after creating LOCK-FILES. Remove the lock files -on exit. LOCK-ARGS are passed to MAKE-LOCK-FILES." - (with-gensyms (files) - `(be ,files (list ,@lock-files) - (make-lock-files ,files ,@lock-args) - (unwind-protect (progn ,@body) - (mapc #'delete-file ,files))))) - -(defun getpid () - #+cmu (unix:unix-getpid) - #+sbcl (sb-unix:unix-getpid) - #+clisp (ext:process-id) - #-(or cmu sbcl clisp) - (error "getpid unsupported under this Lisp implementation")) - -(defmacro on-error (form &body error-forms) - "Execute FORM and in case of error execute ERROR-FORMS too. -This does _not_ stop the error from propagating." - (be done-p (gensym) - `(be ,done-p nil - (unwind-protect - (prog1 - ,form - (setf ,done-p t)) - (unless ,done-p - ,@error-forms))))) - -(defun floor-to (x aim) - "Round X down to the nearest multiple of AIM." - (* (floor x aim) aim)) - -(defun round-to (x aim) - "Round X to the nearest multiple of AIM." - (* (round x aim) aim)) - -(defun ceiling-to (x aim) - "Round X up to the nearest multiple of AIM." - (* (ceiling x aim) aim)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct queue - first - last) - -(defgeneric queue-append (queue objects)) -(defgeneric queue-pop (queue)) -(defgeneric queue-empty-p (queue)) - -(defmethod queue-append ((queue queue) (objects list)) - (cond ((null (queue-first queue)) - (setf (queue-first queue) objects - (queue-last queue) (last objects))) - (t - (setf (cdr (queue-last queue)) objects - (queue-last queue) (last objects)))) - queue) - -(defmethod queue-append ((queue queue) object) - (queue-append queue (list object))) - -(defmethod queue-pop ((queue queue)) - (prog1 (car (queue-first queue)) - (setf (queue-first queue) (cdr (queue-first queue))))) - -(defmethod queue-empty-p ((queue queue)) - (null (queue-first queue))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun package-locked-p (package) - #+sbcl (sb-ext:package-locked-p package) - #+cmu (ext:package-definition-lock package) - #+clisp (ext:package-lock package) - #-(or sbcl cmu clisp) (error "Don't know how to check whether a package might be locked.")) - -(defun forget-documentation (packages) - "Remove documentation from all known symbols in PACKAGES. If -PACKAGES is NIL remove documentations from all packages. This may not -make sense if your Lisp image has been built so that existing objects -don't get garbage collected. It may work for your own code, though. -Locked packages are left alone. If you need to do those too, unlock -them first." - (flet ((forget (symbol) - (dolist (type '(compiler-macro function method-combination setf structure type variable)) - (when (ignore-errors (documentation symbol type)) - (setf (documentation symbol type) nil))))) - (setf packages (mapcar #'(lambda (pkg) - (if (packagep pkg) - (package-name pkg) - (package-name (find-package pkg)))) - packages)) - (setf packages - ;; don't try to modify locked packages - (remove-if #'package-locked-p - (mapcar #'find-package - (or packages - (list-all-packages))))) - (dolist (package packages) - (with-package-iterator (next package :internal :external) - (loop - (multiple-value-bind (more? symbol) (next) - (unless more? - (return)) - (forget symbol))))) - #+(OR) (do-all-symbols (symbol) - (when (member (symbol-package symbol) packages) - (forget symbol)))) - (values)) - -(defun load-compiled (pathname &optional compiled-pathname) - "Make sure to compile PATHNAME before loading it. Don't compile if -the compiled version is more recent than its source." - ;; be tolerant if we didn't get a type - (unless (probe-file pathname) - (setf pathname (merge-pathnames pathname (make-pathname :type "lisp")))) - (if (probe-file pathname) - (progn - (setf compiled-pathname (or compiled-pathname - (compile-file-pathname pathname))) - (when (or (not (probe-file compiled-pathname)) - (< (file-write-date compiled-pathname) - (file-write-date pathname))) - (compile-file pathname)) - (load compiled-pathname)) - (error "Can't load ~A as it doesn't exist." pathname))) - -;; Just a silly mnemonic for those used to lesser languages -(defmacro swap (x y) - "Swap values of places X and Y." - `(rotatef ,x ,y)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro show (&rest things) - "Debugging macro to show the name and content of variables. You can -also specify forms, not just variables." - (let ((*print-pretty* nil)) - `(let ((*print-circle* t)) - (format t ,(format nil "~~&~{~A=~~:W~~%~}" things) - ,@things) - (finish-output) - (values)))) - -(defmacro memoize-function (name &key test) - "Make function NAME memoized. TEST is passed to MAKE-HASH-TABLE." - `(setf (get ',name 'results-hash-table) - (make-hash-table ,@(when test (list :test test))))) - -(defmacro defun-memoized (name args &body forms) - "Define function NAME and make it memoizable. Then the MEMOIZED -macro can be used to call this function and memoize its results. The -function NAME must accept only one argument and return just one -argument; more complicated cases are not considered. The hash table -test function is the default 'EQL." - `(eval-when (:load-toplevel :compile-toplevel) - (defun ,name ,args ,@forms) - (memoize-function ,name))) - -(defmacro memoized (function arg) - "If necessary call FUNCTION passing ARG so that its return value is -memoized. The next time this form is executed with the same argument -value, the memoized result is returned instead of executing FUNCTION." - (with-gensyms (table key result not-found) - `(be* ,key ,arg - ,table (get ',function 'results-hash-table) - ,not-found (list nil) - ,result (gethash ,key ,table ,not-found) - (if (eq ,not-found ,result) - (setf (gethash ,key ,table) - (,function ,key)) - ,result)))) - - -(defmacro save-file-excursion ((stream &optional position) &body forms) - "Execute FORMS returning, on exit, STREAM to the position it was -before FORMS. Optionally POSITION can be set to the starting offset." - (unless position - (setf position (gensym))) - `(be ,position (file-position ,stream) - (unwind-protect (progn ,@forms) - (file-position ,stream ,position)))) - -(defun circular-list (&rest elements) - "Return a circular list of ELEMENTS." - (setf (cdr (last elements)) elements)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun getenv (var) - "Return the string associate to VAR in the system environment." - #+cmu (cdr (assoc (if (symbolp var) - var - (intern var :keyword)) - ext:*environment-list*)) - #+sbcl (sb-ext:posix-getenv (string var)) - #+lispworks (hcl:getenv var) - #+clisp (ext:getenv (string var)) - #-(or cmu sbcl lispworks clisp) - (error "GETENV not implemented for your Lisp system.")) - -#+clisp (ffi:def-call-out %setenv - (:name "setenv") - (:arguments (name ffi:c-string) (value ffi:c-string) (overwrite ffi:int)) - (:return-type ffi:int) - (:library "libc.so")) - -#+clisp (ffi:def-call-out %unsetenv - (:name "unsetenv") - (:arguments (name ffi:c-string)) - (:return-type ffi:int) - (:library "libc.so")) - -(defun setenv (name value &optional (overwrite t)) - (typecase value - (string) - (pathname - (setf value (native-namestring value))) - (t - (setf value (format nil "~A" value)))) - #+sbcl (unless (zerop (sb-posix:setenv name value (if overwrite 1 0))) - (error "unable to setenv ~A: errno=~A." name - (sb-alien:get-errno))) - #+cmu (be key (keywordify name) - (aif (assoc key - ext:*environment-list*) - (when overwrite - (setf (cdr it) value)) - (setf ext:*environment-list* - (cons (cons key value) - ext:*environment-list*)))) - #-(or cmu sbcl) (unless (zerop (%setenv name value (if overwrite 1 0))) - (error "unable to setenv ~A." name))) - -(defun unsetenv (name) - #+sbcl (unless (zerop (sb-posix:unsetenv name)) - (error "unable to unsetenv ~A: errno=~A." name - (sb-alien:get-errno))) - #+cmu (be key (keywordify name) - (setf ext:*environment-list* - (delete-if #'(lambda (e) - (eq (car e) key)) - ext:*environment-list*))) - #-(or cmu sbcl) (unless (zerop (%unsetenv name)) - (error "unable to unsetenv ~A." name))) - -(defun (setf getenv) (value name) - (if value - (setenv name value t) - (unsetenv name))) - -;; in CMUCL it's much easier (see below) -#-cmu -(defmacro with-system-environment ((&rest var-and-values) &body body) - (be gensym-alist (mapcar #'(lambda (vv) - (list (gensym) (string (car vv)) (cadr vv))) - var-and-values) - `(let ,(mapcar #'(lambda (vv) - (destructuring-bind (varsym var value) vv - (declare (ignore value)) - `(,varsym (getenv ,var)))) - gensym-alist) - (unwind-protect - (progn - ,@(mapcar #'(lambda (vv) - (destructuring-bind (varsym var value) vv - (declare (ignore varsym)) - `(setenv ,var ,value))) - gensym-alist) - ,@body) - ,@(mapcar #'(lambda (vv) - (destructuring-bind (varsym var value) vv - (declare (ignore value)) - `(if ,varsym - (setenv ,var ,varsym) - (unsetenv ,var)))) - gensym-alist))))) - -#+cmu -(defmacro with-system-environment ((&rest var-and-values) &body body) - `(let ((ext:*environment-list* - (append (list ,@(mapcar #'(lambda (vv) - (destructuring-bind (variable value) vv - `(cons ,(keywordify variable) - ,value))) - var-and-values)) - ext:*environment-list*))) - ,@body)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun last-member (item list &key key (test #'eq)) - "Return the last sublist in LIST that is prefixed by ITEM." - (loop - with l = list and result = nil - for l2 = (member item l :key key :test test) - while l2 - do (setf result l2 - l (cdr l2)) - finally (return result))) - - -(defun glob->regex (string) - "Convert a shell glob expression into a regular expression string." - (with-output-to-string (out) - ;; globs are always anchored to beginning and end - (write-char #\^ out) - (loop - for i from 0 below (length string) - do (be c (char string i) - (cond ((char= c #\\) - (setf c (char string (incf i)))) - ((find c ".+()|^$") - (write-char #\\ out)) - ((char= c #\*) - (write-char #\. out)) - ((char= c #\?) - (setf c #\.))) - (write-char c out))) - (write-char #\$ out))) |