r4666: *** empty log message ***

[kmrcl.git] / macros.lisp

diff --git a/macros.lisp b/macros.lisp
new file mode 100644 (file)
index 0000000..74ea24b
--- /dev/null
+++ b/macros.lisp
@@ -0,0 +1,167 @@
+;;;; -*- 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: macros.lisp,v 1.1 2003/04/28 23:51:59 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)))))))
+
+(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))
+
+
+;;; 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))))
+
+
+(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))
+
+
+(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))))))))