macros.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          gentils.lisp
   6 ;;;; Purpose:       Main general utility functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: macros.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package :kmrcl)
  20
  21 (defmacro let-when ((var test-form) &body body)
  22   `(let ((,var ,test-form))
  23       (when ,var ,@body)))
  24
  25 (defmacro let-if ((var test-form) if-true &optional if-false)
  26   `(let ((,var ,test-form))
  27       (if ,var ,if-true ,if-false)))
  28
  29 ;; Anaphoric macros
  30
  31 (defmacro aif (test then &optional else)
  32   `(let ((it ,test))
  33      (if it ,then ,else)))
  34
  35 (defmacro awhen (test-form &body body)
  36   `(aif ,test-form
  37         (progn ,@body)))
  38
  39 (defmacro awhile (expr &body body)
  40   `(do ((it ,expr ,expr))
  41        ((not it))
  42      ,@body))
  43
  44 (defmacro aand (&rest args)
  45   (cond ((null args) t)
  46         ((null (cdr args)) (car args))
  47         (t `(aif ,(car args) (aand ,@(cdr args))))))
  48
  49 (defmacro acond (&rest clauses)
  50   (if (null clauses)
  51       nil
  52       (let ((cl1 (car clauses))
  53             (sym (gensym)))
  54         `(let ((,sym ,(car cl1)))
  55            (if ,sym
  56                (let ((it ,sym)) ,@(cdr cl1))
  57                (acond ,@(cdr clauses)))))))
  58
  59 (defmacro alambda (parms &body body)
  60   `(labels ((self ,parms ,@body))
  61      #'self))
  62
  63
  64 (defmacro aif2 (test &optional then else)
  65   (let ((win (gensym)))
  66     `(multiple-value-bind (it ,win) ,test
  67        (if (or it ,win) ,then ,else))))
  68
  69 (defmacro awhen2 (test &body body)
  70   `(aif2 ,test
  71          (progn ,@body)))
  72
  73 (defmacro awhile2 (test &body body)
  74   (let ((flag (gensym)))
  75     `(let ((,flag t))
  76        (while ,flag
  77          (aif2 ,test
  78                (progn ,@body)
  79                (setq ,flag nil))))))
  80
  81 (defmacro acond2 (&rest clauses)
  82   (if (null clauses)
  83       nil
  84       (let ((cl1 (car clauses))
  85             (val (gensym))
  86             (win (gensym)))
  87         `(multiple-value-bind (,val ,win) ,(car cl1)
  88            (if (or ,val ,win)
  89                (let ((it ,val)) ,@(cdr cl1))
  90                (acond2 ,@(cdr clauses)))))))
  91
  92 (defmacro mac (expr)
  93 "Expand a macro"
  94   `(pprint (macroexpand-1 ',expr)))
  95
  96 (defmacro print-form-and-results (form)
  97   `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
  98
  99
 100 ;;; Loop macros
 101
 102 (defmacro until (test &body body)
 103   `(do ()
 104        (,test)
 105      ,@body))
 106
 107 (defmacro while (test &body body)
 108   `(do ()
 109        ((not ,test))
 110      ,@body))
 111
 112 (defmacro for ((var start stop) &body body)
 113   (let ((gstop (gensym)))
 114     `(do ((,var ,start (1+ ,var))
 115           (,gstop ,stop))
 116          ((> ,var ,gstop))
 117        ,@body)))
 118
 119 (defmacro with-each-stream-line ((var stream) &body body)
 120   (let ((eof (gensym))
 121         (eof-value (gensym))
 122         (strm (gensym)))
 123     `(let ((,strm ,stream)
 124            (,eof ',eof-value))
 125       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 126           ((eql ,var ,eof))
 127         ,@body))))
 128
 129 (defmacro with-each-file-line ((var file) &body body)
 130   (let ((stream (gensym)))
 131     `(with-open-file (,stream ,file :direction :input)
 132       (with-each-stream-line (,var ,stream)
 133         ,@body))))
 134
 135
 136 (defmacro in (obj &rest choices)
 137   (let ((insym (gensym)))
 138     `(let ((,insym ,obj))
 139        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 140                      choices)))))
 141
 142 (defmacro mean (&rest args)
 143   `(/ (+ ,@args) ,(length args)))
 144
 145 (defmacro with-gensyms (syms &body body)
 146   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 147           syms)
 148      ,@body))
 149
 150
 151 (defmacro time-iterations (n &body body)
 152   (let ((i (gensym))
 153         (count (gensym)))
 154     `(progn
 155        (let ((,count ,n))
 156          (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
 157          (let ((t1 (get-internal-real-time)))
 158            (dotimes (,i ,count)
 159              ,@body)
 160            (let* ((t2 (get-internal-real-time))
 161                   (secs (coerce (/ (- t2 t1)
 162                                    internal-time-units-per-second)
 163                                 'double-float)))
 164              (format t "~&Total time: ")
 165              (print-seconds secs)
 166              (format t ", time per iteration: ")
 167              (print-seconds (coerce (/ secs ,n) 'double-float))))))))