1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PU:BIND-MACROS.SL
4% Description:  convenient macros for binding variables
5% Author:       Don Morrison, Hewlett-Packard CRC
6% Created:      Wednesday, 12 May 1982
7% Modified:     9 May 1984 2056-PDT (Nancy Kendzierski)
8% Status:       Open Source: BSD License
9% Mode:         Lisp
10% Package:      Utilities
11% Compiletime:  PL:BACKQUOTE.B PL:READ-MACROS.B PL:DEFMACRO.B PL:COND-MACROS.B
12% Runtime:
13%
14% (c) Copyright 1983, Hewlett-Packard Company, see the file
15%            HP_disclaimer at the root of the PSL file tree
16%
17% (c) Copyright 1982, University of Utah
18%
19% Redistribution and use in source and binary forms, with or without
20% modification, are permitted provided that the following conditions are met:
21%
22%    * Redistributions of source code must retain the relevant copyright
23%      notice, this list of conditions and the following disclaimer.
24%    * Redistributions in binary form must reproduce the above copyright
25%      notice, this list of conditions and the following disclaimer in the
26%      documentation and/or other materials provided with the distribution.
27%
28% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
29% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
30% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
31% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
32% CONTRIBUTORS
33% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
34% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
35% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
36% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
37% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
38% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
39% POSSIBILITY OF SUCH DAMAGE.
40%
41%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
42%
43% Revisions:
44%
45% 6 May 1984 1640-PDT (Nancy Kendzierski)
46%  Changed compiletime loads requirements to allow separate compilation of
47%  USEFUL modules.
48% 09-Feb-84 15:37:52 (Cris Perdue)
49%  Added compiletime load useful so this can be compiled by itself.
50% 19 Jan 1984 1429-PST (Brian Beach)
51%   Added standard header.
52% 18-Oct-82 14:31:17, Edit by BENSON
53%  Reversed vars and vals after collecting them in LET, so that the order
54%  of things in the LAMBDA is the same as the LET.  Not necessary,
55%  but it makes it easier to follow macroexpanded things.
56%
57%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
58
59(compiletime (load backquote read-macros defmacro cond-macros))
60
61(defmacro prog1 (first . body)
62  (if (null body)
63    first
64    `((lambda (***PROG1-VAR***) ,@body ***PROG1-VAR***) ,first)))
65
66(defmacro let (specs . body)
67 (if (null specs)
68   (cond
69     ((null body) nil)
70     ((and (pairp body) (null (cdr body))) (car body))
71     (t `(progn ,@body)))
72   (prog (vars vals)
73     (foreach U in specs do
74       (cond ((atom U)
75	       (setq vars (cons U vars))
76	       (setq vals (cons nil vals)))
77	 (t
78	   (setq vars (cons (car U) vars))
79	   (setq vals (cons (and (cdr U) (cadr U)) vals)))))
80     (return `((lambda ,(reversip vars) ,@body ) ,@(reversip vals))))))
81
82(defmacro let* (specs . body)
83 (if (null specs)
84   (cond
85     ((null body) nil)
86     ((and (pairp body) (null (cdr body))) (car body))
87     (t `(progn ,@body)))
88   (let*1 specs body)))
89
90(de let*1 (specs body)
91 (let ((s (car specs))(specs (cdr specs)))
92  `((lambda (,(if (atom s) s (car s)))
93      ,@(if specs (list (let*1 specs body)) body))
94    ,(if (and (pairp s) (cdr s)) (cadr s) nil))))
95
96