Path: utzoo!attcan!uunet!cs.utexas.edu!rutgers!columbia!cs!mkamer
From: mkamer@cs.columbia.edu (Matthew Kamerman)
Newsgroups: comp.lang.lisp
Subject: PLet
Summary: Local variables with values which persist between calls.
Message-ID: <509@cs.columbia.edu>
Date: 29 Nov 89 02:38:21 GMT
Organization: Columbia University Department of Computer Science
Lines: 150

I'm gratified to have gotten a lot of mail about the PLet macros.  Most
everyone liked the idea of posting code and pointers to code.  But be 
warned, your code had better be good!

As several people pointed out, the macros make assumptions about the
relationship between the Compiler and Run time environments which are
not required in CLtL.  The remedy which these people have propoesed
has been using a lexically enclosed function.  Stylistically they're
correct, but on most systems lexical closures seem to be inefficiently
implemented (about 30x the cost of FunCall on an Outer Level function).

Here is a "new, improved" version of the PLet file.  I've tested it on
all the Common Lisp implementations I could get hold of and it seems to
work properly.


;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package: USER -*-
;;; -----------------------------------------------------------------------
;;; File:         plet.l
;;;
;;; Description:  Provides Macros PLet and PLet*.
;;;
;;;               PLet is like LET except that each variable's binding
;;;               is evaluated only the first time the PLet is evaluated.
;;;               Thereafter, each variable's value is saved away on a
;;;               GenSym each time the body is exited, and reloaded each
;;;               time the PLet is reentered.
;;;               
;;;               PLet* is like LET* with the same exceptions as PLet.
;;;
;;;               Declarations, including (Special) are accepted.
;;;
;;;               Note that since Common Lisp doesn't provide Symbol
;;;               Macros (albeit CLOS does), the values are Loaded and 
;;;               Saved upon entrance and exit from the PLet body.  This 
;;;               means that in Recursive calls, all nested activations 
;;;               get the same bindings, those which the outer-most 
;;;               level received.  Also, Recursive Calls don't effect
;;;               each other's values, and the Outer Most values are
;;;               effectively the only ones permanently saved.
;;;
;;; Example:      > (DeFun Fibonacci ()
;;;                   (PLet ((arg1 1) (arg2 0))
;;;                     (PSetQ arg1 arg2 
;;;                            arg2 (+ arg1 arg2))
;;;                     arg2))
;;;               FIBONACCI
;;;               > (DoTimes (i 4 (VALUES)) (PRINT (Fibonacci)))
;;;
;;;               1
;;;               1
;;;               2
;;;               3
;;;               >
;;;
;;; Author:       Matthew Kamerman
;;; Created:      29 Aug 1989
;;; Modified:     27 Nov 1989 for greater CLtL compatibility
;;; Package:      USER
;;; -----------------------------------------------------------------------

(In-Package 'User)

;;;====================================================================;;;
(DefMacro PLet ((&Rest vars-and-bindings) &Body body)
  "(PLet (&Rest vars-and-bindings) &Body body)

   PLet functions in a manner similar to Let with the exceptions that
   bindings are evaluated only when the PLet is first evaluated, and
   thereafter variable values are loaded and saved upon entrance and 
   exit of the PLet body.  All declarations, including (Special) are 
   accepted.

   Note that since values are saved only upon exit from a PLet,
   recursive calls to a function containing a PLet will find each
   with values initialized to the same values as the outer level
   initially received."

  (LET (vars bindings syms declarations)
    (DoList (var-and-binding vars-and-bindings
	     (SetQ vars (NReverse vars)
		   bindings (NReverse bindings)))
      (PUSH (GenSym) syms)
      (COND 
       ((ListP var-and-binding)
	(PUSH (FIRST var-and-binding) vars)
	(PUSH (SECOND var-and-binding) bindings))
       (T
	(PUSH var-and-binding vars)
	(PUSH NIL bindings))))
    (DO ((sexp (FIRST body) (FIRST body)))
	((NOT (AND body (ListP sexp) (EQL (FIRST sexp) 'DECLARE)))
	 (SetQ declarations (NReverse declarations)))
	(PUSH (POP body) declarations))
    (IF vars
	`(LET ,(MapCar 
		 #'(LAMBDA (var binding sym) 
		   `(,var (IF (BoundP ',sym) ,sym ,binding)))
		 vars bindings syms)
	       (DECLARE (Special ,@syms))
	       ,@declarations
           (UnWind-Protect
	    ,(AND body `(ProgN ,@body))
	    (SetQ ,@(MapCan #'LIST syms vars))))
	`(LET () ,@declarations ,@body))))

;;;--------------------------------------------------------------------;;;
(DefMacro PLet* ((&Rest vars-and-bindings) &Body body)
  "(PLet* (&Rest vars-and-bindings) &Body body)

   PLet* functions in a manner similar to Let with the exceptions that
   bindings are evaluated only when the PLet* is first evaluated, and
   thereafter variable values are loaded and saved upon entrance and 
   exit of the PLet* body.  All declarations, including (Special) are 
   accepted.

   Note that since values are saved only upon exit from a PLet*,
   recursive calls to a function containing a PLet* will find each
   with values initialized to the same values as the outer level
   initially received."

  (LET (vars bindings syms declarations)
    (DoList (var-and-binding vars-and-bindings
	     (SetQ vars (NReverse vars)
		   bindings (NReverse bindings)))
      (PUSH (GenSym) syms)
      (COND 
       ((ListP var-and-binding)
	(PUSH (FIRST var-and-binding) vars)
	(PUSH (SECOND var-and-binding) bindings))
       (T
	(PUSH var-and-binding vars)
	(PUSH NIL bindings))))
    (DO ((sexp (FIRST body) (FIRST body)))
	((NOT (AND body (ListP sexp) (EQL (FIRST sexp) 'DECLARE)))
	 (SetQ declarations (NReverse declarations)))
	(PUSH (POP body) declarations))
    (IF vars
	`(LET* ,(MapCar 
		 #'(LAMBDA (var binding sym) 
		   `(,var (IF (BoundP ',sym) ,sym ,binding)))
		 vars bindings syms)
	       (DECLARE (Special ,@syms))
	       ,@declarations
           (UnWind-Protect
	    ,(AND body `(ProgN ,@body))
	    (SetQ ,@(MapCan #'LIST syms vars))))
	`(LET* () ,@declarations ,@body))))

;;;====================================================================;;;