-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: gentils.lisp
-;;;; Purpose: Main general utility functions for KMRCL package
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Apr 2000
-;;;;
-;;;; $Id: genutils.lisp,v 1.16 2003/04/28 21:12:27 kevin Exp $
-;;;;
-;;;; 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)
-
-(defmacro let-when ((var test-form) &body body)
- `(let ((,var ,test-form))
- (when ,var ,@body)))
-
-(defmacro let-if ((var test-form) if-true &optional if-false)
- `(let ((,var ,test-form))
- (if ,var ,if-true ,if-false)))
-
-;; Anaphoric macros
-
-(defmacro aif (test then &optional else)
- `(let ((it ,test))
- (if it ,then ,else)))
-
-(defmacro awhen (test-form &body body)
- `(aif ,test-form
- (progn ,@body)))
-
-(defmacro awhile (expr &body body)
- `(do ((it ,expr ,expr))
- ((not it))
- ,@body))
-
-(defmacro aand (&rest args)
- (cond ((null args) t)
- ((null (cdr args)) (car args))
- (t `(aif ,(car args) (aand ,@(cdr args))))))
-
-(defmacro acond (&rest clauses)
- (if (null clauses)
- nil
- (let ((cl1 (car clauses))
- (sym (gensym)))
- `(let ((,sym ,(car cl1)))
- (if ,sym
- (let ((it ,sym)) ,@(cdr cl1))
- (acond ,@(cdr clauses)))))))
-
-(defmacro alambda (parms &body body)
- `(labels ((self ,parms ,@body))
- #'self))
-
-
-(defmacro aif2 (test &optional then else)
- (let ((win (gensym)))
- `(multiple-value-bind (it ,win) ,test
- (if (or it ,win) ,then ,else))))
-
-(defmacro awhen2 (test &body body)
- `(aif2 ,test
- (progn ,@body)))
-
-(defmacro awhile2 (test &body body)
- (let ((flag (gensym)))
- `(let ((,flag t))
- (while ,flag
- (aif2 ,test
- (progn ,@body)
- (setq ,flag nil))))))
-
-(defmacro acond2 (&rest clauses)
- (if (null clauses)
- nil
- (let ((cl1 (car clauses))
- (val (gensym))
- (win (gensym)))
- `(multiple-value-bind (,val ,win) ,(car cl1)
- (if (or ,val ,win)
- (let ((it ,val)) ,@(cdr cl1))
- (acond2 ,@(cdr clauses)))))))
-
-
-;; Debugging
-
-(defmacro mac (expr)
-"Expand a macro"
- `(pprint (macroexpand-1 ',expr)))
-
-(defmacro print-form-and-results (form)
- `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
-
-(defun show (&optional (what :variables) (package *package*))
- (ecase what
- (:variables (show-variables package))
- (:functions (show-functions package))))
-
-(defun show-variables (package)
- (do-symbols (s package)
- (multiple-value-bind (sym status)
- (find-symbol (symbol-name s) package)
- (when (and (or (eq status :external)
- (eq status :internal))
- (boundp sym))
- (format t "~&Symbol ~S~T -> ~S~%"
- sym
- (symbol-value sym))))))
-
-(defun show-functions (package)
- (do-symbols (s package)
- (multiple-value-bind (sym status)
- (find-symbol (symbol-name s) package)
- (when (and (or (eq status :external)
- (eq status :internal))
- (fboundp sym))
- (format t "~&Function ~S~T -> ~S~%"
- sym
- (symbol-function sym))))))
-
-#+allegro
-(ff:def-foreign-call (memory-status-dump "memory_status_dump")
- ()
- :strings-convert t)
-
-
-;; Ensure functions
-
-(defmacro ensure-integer (obj)
- "Ensure object is an integer. If it is a string, then parse it"
- `(if (stringp ,obj)
- (parse-integer ,obj)
- ,obj))
-
-;; Lists
-
-(defun mklist (obj)
- "Make into list if atom"
- (if (listp obj) obj (list obj)))
-
-(defun filter (fn lst)
- "Filter a list by function, eliminate elements where fn returns nil"
- (let ((acc nil))
- (dolist (x lst)
- (let ((val (funcall fn x)))
- (if val (push val acc))))
- (nreverse acc)))
-
-(defun appendnew (l1 l2)
- "Append two lists, filtering out elem from second list that are already in first list"
- (dolist (elem l2)
- (unless (find elem l1)
- (setq l1 (append l1 (list elem)))))
- l1)
-
-;; Functions
-
-(defun memo-proc (fn)
- "Memoize results of call to fn, returns a closure with hash-table"
- (let ((cache (make-hash-table :test #'equal)))
- #'(lambda (&rest args)
- (multiple-value-bind (val foundp) (gethash args cache)
- (if foundp
- val
- (setf (gethash args cache)
- (apply fn args)))))))
-
-(defun memoize (fn-name)
- (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
-
-(defmacro defun-memo (fn args &body body)
- "Define a memoized function"
- `(memoize (defun ,fn ,args . ,body)))
-
-(defmacro _f (op place &rest args)
- (multiple-value-bind (vars forms var set access)
- (get-setf-expansion place)
- `(let* (,@(mapcar #'list vars forms)
- (,(car var) (,op ,access ,@args)))
- ,set)))
-
-(defun compose (&rest fns)
- (if fns
- (let ((fn1 (car (last fns)))
- (fns (butlast fns)))
- #'(lambda (&rest args)
- (reduce #'funcall fns
- :from-end t
- :initial-value (apply fn1 args))))
- #'identity))
-
-;;; Loop macros
-
-(defmacro until (test &body body)
- `(do ()
- (,test)
- ,@body))
-
-(defmacro while (test &body body)
- `(do ()
- ((not ,test))
- ,@body))
-
-(defmacro for ((var start stop) &body body)
- (let ((gstop (gensym)))
- `(do ((,var ,start (1+ ,var))
- (,gstop ,stop))
- ((> ,var ,gstop))
- ,@body)))
-
-(defmacro with-each-stream-line ((var stream) &body body)
- (let ((eof (gensym))
- (eof-value (gensym))
- (strm (gensym)))
- `(let ((,strm ,stream)
- (,eof ',eof-value))
- (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
- ((eql ,var ,eof))
- ,@body))))
-
-(defmacro with-each-file-line ((var file) &body body)
- (let ((stream (gensym)))
- `(with-open-file (,stream ,file :direction :input)
- (with-each-stream-line (,var ,stream)
- ,@body))))
-
-
-;;; Keyword functions
-
-(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)))
-
-(defmacro in (obj &rest choices)
- (let ((insym (gensym)))
- `(let ((,insym ,obj))
- (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
- choices)))))
-
-(defmacro mean (&rest args)
- `(/ (+ ,@args) ,(length args)))
-
-(defmacro with-gensyms (syms &body body)
- `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
- syms)
- ,@body))
-
-
-;;; Mapping
-
-(defun mapappend (fn list)
- (apply #'append (mapcar fn list)))
-
-
-(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)))
-
-
-;;; Output
-
-(defun indent-spaces (n &optional (stream *standard-output*))
- "Indent n*2 spaces to output stream"
- (when (numberp n)
- (let ((fmt (format nil "~~~DT" (+ n n))))
- (format stream fmt))))
-
-(defun print-list (l &optional (output *standard-output*))
- "Print a list to a stream"
- (if (consp l)
- (progn
- (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
- t)
- nil))
-
-(defun print-rows (rows &optional (ostrm *standard-output*))
- "Print a list of list rows to a stream"
- (dolist (r rows)
- (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
- (terpri ostrm)))
-
-
-;;; IO
-
-
-(defstruct buf
- vec (start -1) (used -1) (new -1) (end -1))
-
-(defun bref (buf n)
- (svref (buf-vec buf)
- (mod n (length (buf-vec buf)))))
-
-(defun (setf bref) (val buf n)
- (setf (svref (buf-vec buf)
- (mod n (length (buf-vec buf))))
- val))
-
-(defun new-buf (len)
- (make-buf :vec (make-array len)))
-
-(defun buf-insert (x b)
- (setf (bref b (incf (buf-end b))) x))
-
-(defun buf-pop (b)
- (prog1
- (bref b (incf (buf-start b)))
- (setf (buf-used b) (buf-start b)
- (buf-new b) (buf-end b))))
-
-(defun buf-next (b)
- (when (< (buf-used b) (buf-new b))
- (bref b (incf (buf-used b)))))
-
-(defun buf-reset (b)
- (setf (buf-used b) (buf-start b)
- (buf-new b) (buf-end b)))
-
-(defun buf-clear (b)
- (setf (buf-start b) -1 (buf-used b) -1
- (buf-new b) -1 (buf-end b) -1))
-
-(defun buf-flush (b str)
- (do ((i (1+ (buf-used b)) (1+ i)))
- ((> i (buf-end b)))
- (princ (bref b i) str)))
-
-
-(defun file-subst (old new file1 file2)
- (with-open-file (in file1 :direction :input)
- (with-open-file (out file2 :direction :output
- :if-exists :supersede)
- (stream-subst old new in out))))
-
-(defun stream-subst (old new in out)
- (declare (string old new))
- (let* ((pos 0)
- (len (length old))
- (buf (new-buf len))
- (from-buf nil))
- (declare (fixnum pos len))
- (do ((c (read-char in nil :eof)
- (or (setf from-buf (buf-next buf))
- (read-char in nil :eof))))
- ((eql c :eof))
- (declare (character c))
- (cond ((char= c (char old pos))
- (incf pos)
- (cond ((= pos len) ; 3
- (princ new out)
- (setf pos 0)
- (buf-clear buf))
- ((not from-buf) ; 2
- (buf-insert c buf))))
- ((zerop pos) ; 1
- (princ c out)
- (when from-buf
- (buf-pop buf)
- (buf-reset buf)))
- (t ; 4
- (unless from-buf
- (buf-insert c buf))
- (princ (buf-pop buf) out)
- (buf-reset buf)
- (setf pos 0))))
- (buf-flush buf out)))
-
-
-;;; Tree Functions
-
-(defun remove-tree-if (pred tree)
- "Strip from tree of atoms that satistify predicate"
- (if (atom tree)
- (unless (funcall pred tree)
- tree)
- (let ((car-strip (remove-tree-if pred (car tree)))
- (cdr-strip (remove-tree-if pred (cdr tree))))
- (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)))))
-
-;;; Files
-
-(defun print-file-contents (file &optional (strm *standard-output*))
- "Opens a reads a file. Returns the contents as a single string"
- (when (probe-file file)
- (with-open-file (in file :direction :input)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (format strm "~A~%" line))))))
-
-(defun read-file-to-string (file)
- "Opens a reads a file. Returns the contents as a single string"
- (with-output-to-string (out)
- (with-open-file (in file :direction :input)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (format out "~A~%" line))))))
-
-(defun read-file-to-strings (file)
- "Opens a reads a file. Returns the contents as a list of strings"
- (let ((lines '()))
- (with-open-file (in file :direction :input)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (push line lines)))
- (nreverse lines))))
-
-
-
-;; Benchmarking
-
-(defun print-float-units (val unit)
- (cond
- ((< val 1d-6)
- (format t "~,2,9F nano~A" val unit))
- ((< val 1d-3)
- (format t "~,2,6F micro~A" val unit))
- ((< val 1)
- (format t "~,2,3F milli~A" val unit))
- ((> val 1d9)
- (format t "~,2,-9F giga~A" val unit))
- ((> val 1d6)
- (format t "~,2,-6F mega~A" val unit))
- ((> val 1d3)
- (format t "~,2,-3F kilo~A" val unit))
- (t
- (format t "~,2F ~A" val unit))))
-
-(defun print-seconds (secs)
- (print-float-units secs "sec"))
-
-(defmacro time-iterations (n &body body)
- (let ((i (gensym))
- (count (gensym)))
- `(progn
- (let ((,count ,n))
- (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
- (let ((t1 (get-internal-real-time)))
- (dotimes (,i ,count)
- ,@body)
- (let* ((t2 (get-internal-real-time))
- (secs (coerce (/ (- t2 t1)
- internal-time-units-per-second)
- 'double-float)))
- (format t "~&Total time: ")
- (print-seconds secs)
- (format t ", time per iteration: ")
- (print-seconds (coerce (/ secs ,n) 'double-float))))))))
-
-
-(defun nsubseq (sequence start &optional (end (length sequence)))
- (make-array (- end start)
- :element-type (array-element-type sequence)
- :displaced-to sequence
- :displaced-index-offset start))
projects / kmrcl.git / commitdiff