X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=genutils.lisp;fp=genutils.lisp;h=0000000000000000000000000000000000000000;hb=4de7f25a69c218303f170314ac26217770a531ed;hp=cbd78f1682ea0d3a498883b55cd3c547fdc577a3;hpb=aa610805927518a648eb0da6a8713cd0a83337df;p=kmrcl.git

diff --git a/genutils.lisp b/genutils.lisp
deleted file mode 100644
index cbd78f1..0000000
--- a/genutils.lisp
+++ /dev/null
@@ -1,529 +0,0 @@
-;;;; -*- 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))