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 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; KMRCL users are granted the rights to distribute and use this software
  13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  15 ;;;; *************************************************************************
  16
  17 (in-package :kmrcl)
  18
  19 (defun memo-proc (fn)
  20   "Memoize results of call to fn, returns a closure with hash-table"
  21   (let ((cache (make-hash-table :test #'equal)))
  22     #'(lambda (&rest args)
  23         (multiple-value-bind (val foundp) (gethash args cache)
  24           (if foundp
  25               val
  26             (setf (gethash args cache) (apply fn args)))))))
  27
  28 (defun memoize (fn-name)
  29   (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
  30
  31 (defmacro defun-memo (fn args &body body)
  32   "Define a memoized function"
  33   `(memoize (defun ,fn ,args . ,body)))
  34
  35 (defmacro _f (op place &rest args)
  36   (multiple-value-bind (vars forms var set access)
  37                        (get-setf-expansion place)
  38     `(let* (,@(mapcar #'list vars forms)
  39             (,(car var) (,op ,access ,@args)))
  40        ,set)))
  41
  42 (defun compose (&rest fns)
  43   (if fns
  44       (let ((fn1 (car (last fns)))
  45             (fns (butlast fns)))
  46         #'(lambda (&rest args)
  47             (reduce #'funcall fns
  48                     :from-end t
  49                     :initial-value (apply fn1 args))))
  50       #'identity))
  51