1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PNK:PROG-FRIEND.SL
4% Title:        PROG, GO, and RETURN
5% Author:       Eric Benson
6% Created:      20 August 1981
7% Modified:     22-Mar-84 11:51:38 (Brian Beach)
8% Status:       Open Source: BSD License
9% Mode:         Lisp
10% Package:      Kernel
11% Compiletime:
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% 24 Nov 1994 (Herbert Melenk)
46%  modified progjumptable* assoc structure to memq (saving conses).
47%  Enabled GO to prog body on higher level.
48% 26 Jan 1984 1001-PST (Brian Beach)
49%  Corrected file name in header.
50% 01-Dec-83 14:58:48 (Brian Beach)
51%   Translated from Rlisp to Lisp.
52%
53%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
54
55(fluid '(
56         progjumptable* % A-List of labels and expressions
57	 progbody*      % Tail of the current PROG
58))
59
60(global '(
61         progform*      % Currently processed statement of a PROG
62))
63
64(df prog (progbody)
65  %. Program feature function
66  (prog (n x result)
67
68        (unless (pairp progbody) (return nil))
69        (setq n 0)
70
71        (foreach x in (car progbody) do
72                 (progn (pbind1 x) (setq n (plus n 1))))
73        (setq progbody (cdr progbody))
74
75        (setq x progbody)
76        (while (and (pairp x)(pairp (car x))) (setq x (cdr x)))
77
78        (let ((progjumptable* x)
79              (progbody*      progbody))
80
81
82         (while progbody*
83
84            (if (pairp (setq progform* (car progbody*)))
85                (setq result (*catch '$prog$ (eval progform*)))
86                (setq throwsignal* nil))
87
88            (unless throwsignal*
89                  (setq result nil)
90                  (setq progbody* (cdr progbody*)))
91        ))
92        (unbindn n)
93             % Now we have unwound the complete PROG structure.
94             % A pending go is evaluated towards the next higher level
95             % where it may be satisfied or lead to an error.
96        (when (eq result '$pending-go$) (eval progform*))
97        (return result)))
98
99(df go (u)
100  %. Goto label within PROG
101  (let*((lbl (car u))
102        (x (memq lbl progjumptable*)))
103   (cond
104      ((null progbody*) (stderror (bldmsg "GO: Label >%w< not found" lbl)))
105      (x (setq progbody* (cdr x)) (*throw '$prog$ nil))
106      (t (setq progbody* nil)
107         (when (not (eq (car progform*) 'go)) (setq progform* (cons 'go u)))
108         (*throw '$prog$ '$pending-go$)) )))
109
110
111(de return (u)
112  %. Return value from PROG
113  (if progbody*
114    (progn (setq progbody* nil) (*throw '$prog$ u))
115    (stderror "RETURN attempted outside the scope of a PROG")))
116
117