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.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 (defun memo-proc (fn)
  22   "Memoize results of call to fn, returns a closure with hash-table"
  23   (let ((cache (make-hash-table :test #'equal)))
  24     #'(lambda (&rest args)
  25         (multiple-value-bind (val foundp) (gethash args cache)
  26           (if foundp
  27               val
  28               (setf (gethash args cache)
  29                     (apply fn args)))))))
  30
  31 (defun memoize (fn-name)
  32   (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
  33
  34 (defmacro defun-memo (fn args &body body)
  35   "Define a memoized function"
  36   `(memoize (defun ,fn ,args . ,body)))
  37
  38 (defmacro _f (op place &rest args)
  39   (multiple-value-bind (vars forms var set access)
  40                        (get-setf-expansion place)
  41     `(let* (,@(mapcar #'list vars forms)
  42             (,(car var) (,op ,access ,@args)))
  43        ,set)))
  44
  45 (defun compose (&rest fns)
  46   (if fns
  47       (let ((fn1 (car (last fns)))
  48             (fns (butlast fns)))
  49         #'(lambda (&rest args)
  50             (reduce #'funcall fns
  51                     :from-end t
  52                     :initial-value (apply fn1 args))))
  53       #'identity))
  54