functions.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          functions.lisp
   6 ;;;; Purpose:       Function routines for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: functions.lisp,v 1.3 2003/05/16 13:05:28 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 (defun memo-proc (fn &optional (test #'equal))
  22   "Memoize results of call to fn, returns a closure with hash-table"
  23   (let ((cache (make-hash-table :test test)))
  24     #'(lambda (&rest args)
  25         (multiple-value-bind (val foundp) (gethash args cache)
  26           (if foundp
  27               val
  28             (setf (gethash args cache) (apply fn args)))))))
  29
  30 (defun memoize (fn-name &optional (test #'equal))
  31   (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name) test)))
  32
  33 (defmacro defun-memo (fn args &body body)
  34   "Define a memoized function"
  35   `(memoize (defun ,fn ,args . ,body)))
  36
  37 (defmacro _f (op place &rest args)
  38   (multiple-value-bind (vars forms var set access)
  39                        (get-setf-expansion place)
  40     `(let* (,@(mapcar #'list vars forms)
  41             (,(car var) (,op ,access ,@args)))
  42        ,set)))
  43
  44 (defun compose (&rest fns)
  45   (if fns
  46       (let ((fn1 (car (last fns)))
  47             (fns (butlast fns)))
  48         #'(lambda (&rest args)
  49             (reduce #'funcall fns
  50                     :from-end t
  51                     :initial-value (apply fn1 args))))
  52       #'identity))
  53