1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32
33)package "BOOT"
34
35--% Macro expansion
36--  Functions to transform parse forms.
37--
38--  Global variables:
39--    $pfMacros is an alist [[id, state, body-pform], ...]
40--       (set in newcompInit).
41--       state is one of: mbody, mparam, mlambda
42--
43--    $macActive is a list of the bodies being expanded.
44--    $posActive is a list of the parse forms where the bodies came from.
45
46-- Beware: the name macroExpand is used by the old compiler.
47macroExpanded pf ==
48    $macActive: local := []
49    $posActive: local := []
50
51    macExpand pf
52
53macExpand pf ==
54    pfWhere?       pf => macWhere   pf
55    pfLambda?      pf => macLambda  pf
56    pfMacro?       pf => macMacro pf
57
58    pfId?          pf => macId pf
59    pfApplication? pf => macApplication pf
60    pfMapParts(function macExpand, pf)
61
62macWhere pf ==
63    mac(pf,$pfMacros) where
64        mac(pf,$pfMacros) ==
65            -- pfWhereContext is before pfWhereExpr
66            pfMapParts(function macExpand, pf)
67
68macLambda pf ==
69    mac(pf,$pfMacros) where
70        mac(pf,$pfMacros) ==
71            pfMapParts(function macExpand, pf)
72
73macLambdaParameterHandling( replist , pform )  ==
74    pfLeaf? pform => []
75    pfLambda? pform =>      -- remove ( identifier . replacement ) from assoclist
76        parlist := [ pfTypedId p for p in pf0LambdaArgs pform ] -- extract parameters
77        for par in [ pfIdSymbol par for par in parlist ] repeat
78                replist := AlistRemoveQ(par,replist)
79        replist
80    pfMLambda? pform =>     -- construct assoclist ( identifier . replacement )
81        parlist := pf0MLambdaArgs pform  -- extract parameter list
82        [[pfIdSymbol par ,:pfLeaf( pfAbSynOp par,GENSYM(),pfLeafPosition par)] for par in parlist ]
83    for p in pfParts pform repeat macLambdaParameterHandling( replist , p )
84
85macSubstituteId( replist , pform ) ==
86    ex := AlistAssocQ( pfIdSymbol pform , replist )
87    ex =>
88        RPLPAIR(pform, rest ex)
89        pform
90    pform
91
92macSubstituteOuter( pform ) ==
93    mac0SubstituteOuter( macLambdaParameterHandling( [] , pform ) , pform )
94
95mac0SubstituteOuter( replist , pform ) ==
96    pfId? pform => macSubstituteId( replist , pform )
97    pfLeaf? pform => pform
98    pfLambda? pform =>
99        tmplist := macLambdaParameterHandling( replist , pform )
100        for p in pfParts pform repeat mac0SubstituteOuter( tmplist , p )
101        pform
102    for p in pfParts pform repeat mac0SubstituteOuter( replist , p )
103    pform
104
105-- This function adds the appropriate definition and returns
106-- the original Macro pform.
107macMacro pf ==
108    lhs := pfMacroLhs pf
109    rhs := pfMacroRhs pf
110    not pfId? lhs =>
111        ncSoftError (pfSourcePosition lhs, 'S2CM0001, [%pform lhs] )
112        pf
113    sy := pfIdSymbol lhs
114
115    mac0Define(sy, if pfMLambda? rhs then 'mlambda else 'mbody, macSubstituteOuter rhs)
116
117    if pfNothing? rhs then pf else pfMacro(lhs, pfNothing())
118
119mac0Define(sy, state, body) ==
120    $pfMacros := cons([sy, state, body], $pfMacros)
121
122-- Returns [state, body] or NIL.
123mac0Get sy ==
124    IFCDR ASSOC(sy, $pfMacros)
125
126-- Returns [sy, state] or NIL.
127mac0GetName body ==
128    name := nil
129    for [sy,st,bd] in $pfMacros while not name repeat
130        if st = 'mlambda then
131            bd := pfMLambdaBody bd
132        EQ(bd, body) => name := [sy,st]
133    name
134
135macId pf ==
136    sy := pfIdSymbol pf
137    not (got := mac0Get sy) => pf
138    [state, body] := got
139
140    state = 'mparam     => body                                         -- expanded already
141    state = 'mlambda    => pfCopyWithPos( body , pfSourcePosition pf )  -- expanded later
142
143    pfCopyWithPos( mac0ExpandBody(body, pf, $macActive, $posActive) , pfSourcePosition pf )
144
145macApplication pf ==
146    pf := pfMapParts(function macExpand, pf)
147
148    op := pfApplicationOp pf
149    not pfMLambda? op => pf
150
151    args := pf0ApplicationArgs pf
152    mac0MLambdaApply(op, args, pf, $pfMacros)
153
154mac0MLambdaApply(mlambda, args, opf, $pfMacros) ==
155    params := pf0MLambdaArgs mlambda
156    body   := pfMLambdaBody  mlambda
157    #args ~= #params =>
158        pos := pfSourcePosition opf
159        ncHardError(pos,'S2CM0003, [#params,#args])
160    for p in params for a in args repeat
161        not pfId? p =>
162            pos := pfSourcePosition opf
163            ncHardError(pos, 'S2CM0004, [%pform p])
164        mac0Define(pfIdSymbol p, 'mparam, a)
165
166    mac0ExpandBody( body , opf, $macActive, $posActive)
167
168mac0ExpandBody(body, opf, $macActive, $posActive) ==
169    MEMQ(body,$macActive) =>
170        [.,pf] := $posActive
171        posn   := pfSourcePosition pf
172        mac0InfiniteExpansion(posn, body, $macActive)
173    $macActive := [body, :$macActive]
174    $posActive := [opf,  :$posActive]
175    macExpand body
176
177mac0InfiniteExpansion(posn, body, active) ==
178    blist := [body, :active]
179    [fname, :rnames] := [name b for b in blist] where
180        name b ==
181            got := mac0GetName b
182            not got => '"???"
183            [sy,st] := got
184            st = 'mlambda => CONCAT(PNAME sy, '"(...)")
185            PNAME sy
186    ncSoftError (posn, 'S2CM0005, _
187       [ [:[n,'"==>"] for n in reverse rnames], fname, %pform body ]  )
188
189    body
190