util.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2011 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18
  19 (in-package :phoros)
  20
  21 (defmacro defun* (name lambda-list &body body)
  22   "Like defun, define a function, but with an additional lambda list
  23 keyword &mandatory-key which goes after the &key section or in place
  24 of it.  &mandatory-key argument definitions are plain symbols (no
  25 lists).  An error is signalled on function calls where one of those
  26 keyargs is missing."
  27   (let ((mandatory-key-position (position '&mandatory-key lambda-list))
  28         (after-key-position (or (position '&allow-other-keys lambda-list)
  29                                 (position '&aux lambda-list))))
  30     (when mandatory-key-position
  31       (setf lambda-list
  32             (append (subseq lambda-list 0 mandatory-key-position)
  33                     (unless (position '&key lambda-list)
  34                       '(&key))
  35                     (mapcar
  36                      #'(lambda (k)
  37                          `(,k (error ,(format nil "~A: argument ~A undefined"
  38                                               name k))))
  39                      (subseq lambda-list
  40                              (1+ mandatory-key-position)
  41                              after-key-position))
  42                     (when after-key-position
  43                       (subseq lambda-list after-key-position))))))
  44   `(defun ,name ,lambda-list ,@body))