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)package "BOOT"
33
34DEFPARAMETER($currentFunctionLevel, 0)
35DEFPARAMETER($tryRecompileArguments, true)
36DEFPARAMETER($locVarsTypes, nil)
37
38initEnvHashTable(l) ==
39  for u in first(first(l)) repeat
40      for v in rest(u) repeat
41            HPUT($envHashTable, [first u, first v], true)
42
43compTopLevel(x,m,e) ==
44  $killOptimizeIfTrue: local:= false
45  $forceAdd: local:= false
46  $compTimeSum: local := 0
47  $resolveTimeSum: local := 0
48  $envHashTable : local := MAKE_HASHTABLE('EQUAL)
49  initEnvHashTable(e)
50  initEnvHashTable($CategoryFrame)
51  -- The next line allows the new compiler to be tested interactively.
52  compFun := 'compOrCroak
53  x is ["DEF",:.] or x is ["where",["DEF",:.],:.] =>
54    ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e])
55        --keep old environment after top level function defs
56  FUNCALL(compFun,x,m,e)
57
58compUniquely(x,m,e) ==
59  $compUniquelyIfTrue: local:= true
60  CATCH("compUniquely",comp(x,m,e))
61
62compOrCroak(x,m,e) == compOrCroak1(x,m,e,'comp)
63
64compOrCroak1(x,m,e,compFn) ==
65  fn(x,m,e,nil,nil,compFn) where
66    fn(x,m,e,$compStack,$compErrorMessageStack,compFn) ==
67      T:= CATCH("compOrCroak",FUNCALL(compFn,x,m,e)) => T
68      -- stackAndThrow does the appropriate THROW
69      $compStack:= [[x,m,e,$exitModeStack],:$compStack]
70      $s:=
71        compactify $compStack where
72          compactify al ==
73            null al => nil
74            LASSOC(first first al,rest al) => compactify rest al
75            [first al,:compactify rest al]
76      $level:= #$s
77      errorMessage:=
78        if $compErrorMessageStack
79           then first $compErrorMessageStack
80           else "unspecified error"
81      $scanIfTrue =>
82        stackSemanticError(errorMessage,mkErrorExpr $level)
83        ["failedCompilation",m,e]
84      displaySemanticErrors()
85      SAY("****** comp fails at level ",$level," with expression: ******")
86      displayComp $level
87      userError errorMessage
88
89comp(x,m,e) ==
90  T:= compNoStacking(x,m,e) => ($compStack:= nil; T)
91  $compStack:= [[x,m,e,$exitModeStack],:$compStack]
92  nil
93
94compNoStacking(x,m,e) ==
95  T:= comp2(x,m,e) =>
96    (m=$EmptyMode and T.mode=$Representation => [T.expr,"$",T.env]; T)
97         --$Representation is bound in compDefineFunctor, set by doIt
98         --this hack says that when something is undeclared, $ is
99         --preferred to the underlying representation -- RDJ 9/12/83
100  compNoStacking1(x,m,e,$compStack)
101
102compNoStacking1(x,m,e,$compStack) ==
103  u:= get(if m="$" then "Rep" else m,"value",e) =>
104    (T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil)
105  nil
106
107comp2(x,m,e) ==
108  [y,m',e]:= comp3(x,m,e) or return nil
109  --if null atom y and isDomainForm(y,e) then e := addDomain(x,e)
110        --line commented out to prevent adding derived domain forms
111  m ~= m' and isDomainForm(m',e) => [y, m', addDomain(m', e)]
112        --isDomainForm test needed to prevent error while compiling Ring
113  [y,m',e]
114
115comp3(x, m, e) ==
116  --returns a Triple or else nil to signal can't do
117  e := addDomain(m, e)
118  m is ["Mapping",:.] => compWithMappingMode(x,m,e)
119  m is ["QUOTE",a] => (x=a => [x, m, e]; nil)
120  STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil)
121  not x or atom x => compAtom(x,m,e)
122  op:= first x
123  op=":" => compColon(x,m,e)
124  op="::" => compCoerce(x,m,e)
125  t:= compExpression(x,m,e)
126  t is [x',m',e'] and not member(m',getDomainsInScope e') =>
127    [x',m',addDomain(m',e')]
128  t
129
130hasFormalMapVariable(x, vl) ==
131  $formalMapVariables: local := vl
132  null vl => false
133  ScanOrPairVec(function hasone?, x) where
134     hasone? x == MEMQ(x,$formalMapVariables)
135
136argsToSig(args) ==
137    args is [":", v, t] => [[v], [t]]
138    sig1 := []
139    arg1 := []
140    bad := false
141    for arg in args repeat
142        arg is [":", v, t] =>
143             sig1 := [t, :sig1]
144             arg1 := [v, :arg1]
145        bad := true
146    bad => [nil, nil]
147    [REVERSE(arg1), REVERSE(sig1)]
148
149compLambda(x is ["+->", vl, body], m, e) ==
150    vl is [":", args, target] =>
151        args :=
152             args is ["@Tuple", :a1] => a1
153             args
154        LISTP(args) =>
155             [arg1, sig1] := argsToSig(args)
156             sig1 or NULL(args) =>
157                 ress := compAtSign(["@", ["+->", arg1, body],
158                                  ["Mapping", target, :sig1]], m, e)
159                 ress
160             stackAndThrow ["compLambda: malformed argument list", x]
161        stackAndThrow ["compLambda: malformed argument list", x]
162    nil
163
164getFreeList(u, bound, free, e) ==
165    atom u =>
166        not IDENTP u => free
167        MEMQ(u,bound) => free
168        v := ASSQ(u, free) =>
169            RPLACD(v, 1 + CDR v)
170            free
171        not getmode(u, e) => free
172        [[u, :1], :free]
173    op := first u
174    MEMQ(op, '(QUOTE GO function)) => free
175    EQ(op, 'LAMBDA) =>
176        lvl := CADR u
177        avl := []
178        for evl in lvl repeat
179            el :=
180                ATOM(evl) => evl
181                first(evl)
182            avl := [el, :avl]
183        bound := UNIONQ(bound, avl)
184        for v in CDDR u repeat
185            free := getFreeList(v, bound, free, e)
186        free
187    EQ(op, 'PROG) =>
188        bound := UNIONQ(bound, CADR u)
189        for v in CDDR u | NOT ATOM v repeat
190            free := getFreeList(v, bound, free, e)
191        free
192    EQ(op, 'SPROG) =>
193        bound := UNIONQ(bound, [first uu for uu in CADR u])
194        for v in CDDR u | NOT ATOM v repeat
195            free := getFreeList(v, bound, free, e)
196        free
197    EQ(op, 'SEQ) =>
198        for v in rest u | NOT ATOM v repeat
199            free := getFreeList(v, bound, free, e)
200        free
201    EQ(op, 'COND) =>
202        for v in rest u repeat
203            for vv in v repeat
204                free := getFreeList(vv, bound, free, e)
205        free
206    if ATOM op then u := rest u  --Atomic functions aren't descended
207    for v in u repeat
208        free := getFreeList(v, bound, free, e)
209    free
210
211compWithMappingMode(x, m, oldE) ==
212  compWithMappingMode1(x, m, oldE, $formalArgList)
213
214compWithMappingMode1(x, m is ["Mapping", m', :sl], oldE, $formalArgList) ==
215  $killOptimizeIfTrue: local:= true
216  e:= oldE
217  isFunctor x =>
218    if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and
219        (and/[extendsCategoryForm("$", s, mode, e) for mode in argModeList
220                                                   for s in sl]
221          ) and extendsCategoryForm("$", target, m', e) then return [x, m, e]
222  if STRINGP x then x:= INTERN x
223  ress := nil
224  old_style := true
225  if x is ["+->", vl, nx] then
226      old_style := false
227      vl is [":", :.] =>
228         ress := compLambda(x,m,oldE)
229         -- In case Boot gets fixed
230         ress
231      vl :=
232          vl is ["@Tuple", :vl1] => vl1
233          vl
234      vl :=
235         IDENTP(vl) => [vl]
236         LISTP(vl) and (and/[SYMBOLP(v) for v in vl])=> vl
237         stackAndThrow ["bad +-> arguments:", vl]
238      $formalArgList := [:vl, :$formalArgList]
239      #sl ~= #vl =>
240         stackAndThrow [_
241           "number of arguments to +-> does not match, expected:", #sl]
242      x := nx
243  else
244      vl:= take(#sl,$FormalMapVariableList)
245  ress => ress
246  $returnMode : local := m'
247  $currentFunctionLevel : local := #$exitModeStack
248  old_style and not null vl and not hasFormalMapVariable(x, vl) =>
249      vln := [GENSYM() for v in vl]
250      $formalArgList := [:vln, :$formalArgList]
251      for m in sl for v in vln repeat
252          [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e)
253      [u,.,.] := comp([x,:vln],m',e) or return nil
254      extractCodeAndConstructTriple(u, m, oldE)
255  null vl and (t := comp([x], m', e)) =>
256    [u,.,.] := t
257    extractCodeAndConstructTriple(u, m, oldE)
258  for m in sl for v in vl repeat
259      [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e)
260  [u,.,.]:= comp(x,m',e) or return nil
261  (uu := simpleCall(u, vl, m, oldE)) => uu
262  catchTag:= MKQ GENSYM()
263  u := replaceExitEtc(u, catchTag, "TAGGEDreturn", $returnMode)
264  u := ["CATCH", catchTag, u]
265  uu := optimizeFunctionDef [nil, ['LAMBDA, vl, u]]
266  --  At this point, we have a function that we would like to pass.
267  --  Unfortunately, it makes various free variable references outside
268  --  itself.  So we build a mini-vector that contains them all, and
269  --  pass this as the environment to our inner function.
270  expandedFunction := compTranDryRun CADR uu
271  frees := getFreeList(expandedFunction, vl, nil, e)
272  expandedFunction :=
273            --One free can go by itself, more than one needs a vector
274         --An A-list name . number of times used
275    #frees = 0 =>
276        ['LAMBDA, addNilTypesToArgs [:vl, "$$"], :CDDR expandedFunction]
277    #frees = 1 =>
278      vec:=first first frees
279      ['LAMBDA, addNilTypesToArgs [:vl, vec], :CDDR expandedFunction]
280    scode:=nil
281    vec:=nil
282    locals:=nil
283    i:=-1
284    for v in frees repeat
285      i:=i+1
286      vec:=[first v,:vec]
287      scode:=[['SETQ, first v, [($QuickCode => 'QREFELT;'ELT),"$$",i]], :scode]
288      locals:=[first v, :locals]
289    body:= CDDR expandedFunction
290    if locals then
291      if body is [['DECLARE,:.],:.] then
292        body := [first body, ['PROG, locals, :scode,
293                              ['RETURN, ['PROGN, :rest body]]]]
294      else body:=[['PROG,locals,:scode,['RETURN,['PROGN,:body]]]]
295    vec:=['VECTOR,:NREVERSE vec]
296    ['LAMBDA, addNilTypesToArgs [:vl, "$$"], :body]
297  fname:=['CLOSEDFN,expandedFunction]
298         --Like QUOTE, but gets compiled
299  uu:=
300    frees => ['CONS,fname,vec]
301    ['LIST,fname]
302  [uu,m,oldE]
303
304simpleCall(u, vl, m, oldE) ==
305    u is ["call", fn, :avl] and avl = vl =>
306        if fn is ["applyFun", a] then fn := a
307        fn = "mkRecord" => nil
308        [fn,m,oldE]
309    nil
310
311extractCodeAndConstructTriple(u, m, oldE) ==
312  u is ["call",fn,:.] =>
313    if fn is ["applyFun",a] then fn := a
314    [fn,m,oldE]
315  [op,:.,env] := u
316  [["CONS",["function",op],env],m,oldE]
317
318compExpression(x,m,e) ==
319  op := first x
320  SYMBOLP(op) and (fn := GET(op, "SPECIAL")) =>
321    FUNCALL(fn,x,m,e)
322  getmode(op, e) is ["Mapping", :ml] and (u := applyMapping(x, m, e, ml)) => u
323  compForm(x,m,e)
324
325compAtom(x, m, e) ==
326    res := compAtom1(x, m, e) => res
327    -- Needed at least for bootstrap of FFIELDC.spad
328    compAtomWithModemap(x, m, e, get(x, "modemap", e))
329
330compAtom1(x, m, e) ==
331  t:=
332    isSymbol x =>
333      compSymbol(x,m,e) or return nil
334    STRINGP x => [x,x,e]
335    [x,primitiveType x or return nil,e]
336  convert(t,m)
337
338primitiveType x ==
339  x is nil => $EmptyMode
340  STRINGP x => BREAK() -- handled in compAtom1
341  INTEGERP x =>
342    x=0 => $NonNegativeInteger
343    x>0 => $PositiveInteger
344    $Integer
345  FLOATP x => BREAK() -- no longer used
346  nil
347
348DEFPARAMETER($compForModeIfTrue, false)
349
350compSymbol(s,m,e) ==
351  s="$NoValue" => ["$NoValue",$NoValueMode,e]
352  isFluid s => [s,getmode(s,e) or return nil,e]
353  s="true" => ['(QUOTE T),$Boolean,e]
354  s="false" => [false,$Boolean,e]
355  s = m => [["QUOTE", s], s, e]
356  v:= get(s,"value",e) =>
357--+
358    MEMQ(s,$functorLocalParameters) =>
359        NRTgetLocalIndex(s, e)
360        [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile
361    [s,v.mode,e] --s has been SETQd
362  m':= getmode(s,e) =>
363    if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and
364      not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s
365    [s,m',e] --s is a declared argument
366  MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s]
367  not isFunction(s,e) => errorRef s
368
369convertOrCroak(T,m) ==
370  u:= convert(T,m) => u
371  userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l",
372    " TO MODE: ",m,"%l"]
373
374convert(T,m) ==
375  coerce(T,resolve(T.mode,m) or return nil)
376
377maxSuperType(m,e) ==
378  typ:= get(m,"SuperDomain",e) => maxSuperType(typ,e)
379  m
380
381hasType(x,e) ==
382  fn get(x,"condition",e) where
383    fn x ==
384      null x => nil
385      x is [["case",.,y],:.] => y
386      fn rest x
387
388compForm(form,m,e) ==
389  T:=
390    compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return
391      stackMessageIfNone ["cannot compile","%b",form,"%d"]
392  T
393
394compArgumentsAndTryAgain(form is [.,:argl],m,e) ==
395  not($tryRecompileArguments) or null(argl) => nil
396  -- used in case: f(g(x)) where f is in domain introduced by
397  -- comping g, e.g. for (ELT (ELT x a) b), environment can have no
398  -- modemap with selector b
399  form is ["Sel", a, .] => nil
400  u:= for x in argl repeat [.,.,e]:= comp(x,$EmptyMode,e) or return "failed"
401  u="failed" => nil
402  compForm1(form,m,e)
403
404-- FIXME: we should check the argument.
405outputComp(x,e) ==
406  u:=comp(['_:_:, x, $OutputForm], $OutputForm, e) => u
407  x is ['construct,:argl] =>
408    [['LIST, ['QUOTE, 'CONCAT], :[([.,.,e] := outputComp(x, e)).expr
409        for x in argl]], $OutputForm, e]
410  (v:= get(x,"value",e)) and (v.mode is ['Union,:l]) =>
411    [['coerceUn2E, x, v.mode], $OutputForm, e]
412  SAY ["outputComp strange x ", x]
413  nil
414
415compSel1(domain, op, argl, m, e) ==
416    domain="Lisp" =>
417        [[op, :[([., ., e] := compOrCroak(x, $EmptyMode, e)).expr
418           for x in argl]], m, e]
419    (op = "COLLECT") and coerceable(domain, m, e) =>
420      (T := comp([op, :argl], domain, e) or return nil; coerce(T, m))
421    -- FIXME: we should handle 0 and 1 in systematic way, instead
422    -- of renaming hacks like below
423    if op = 0 then
424        op := "Zero"
425    else if op = 1 then
426        op := "One"
427    -- Next clause added JHD 8/Feb/94: the clause after doesn't work
428    -- since addDomain refuses to add modemaps from Mapping
429    domain=$Float and op="float" and m=$DoubleFloat =>
430        argl is [mant, exp, 10] => try_constant_DF(mant, exp, m, e)
431        nil
432    e :=
433        domain is ['Mapping, :.] =>
434            augModemapsFromDomain1(domain, domain, e)
435        addDomain(domain, e)
436    mml := [x for x in getFormModemaps([op, :argl], e)
437              | x is [[ =domain, :.], :.]]
438    (ans := compForm2([op, :argl], m, e, mml)) => ans
439    op = "construct" and coerceable(domain, m, e) =>
440        (T := comp_construct1(argl, domain, e)) or return nil
441        coerce(T, m)
442    nil
443
444try_constant_DF(mant, exp, m, e) ==
445    if mant = ["Zero"] then mant := 0
446    if mant = ["One"] then mant := 1
447    if exp = ["Zero"] then exp := 0
448    if exp = ["One"] then exp := 1
449    INTEGERP(mant) and INTEGERP(exp) => [["mk_DF", mant, exp], m, e]
450    nil
451
452compForm1(form is [op,:argl],m,e) ==
453  op="error" =>
454      #argl = 1 =>
455          arg := first(argl)
456          u := comp(arg, $String, e) =>
457              [[op, u.expr], m, e]
458          SAY ["compiling call to error ", argl]
459          u := outputComp(arg, e) =>
460              [[op, ['LIST, ['QUOTE, 'mathprint], u.expr]], m, e]
461          nil
462      SAY ["compiling call to error ", argl]
463      nil
464  op is ["Sel", domain, op'] => compSel1(domain, op', argl, m, e)
465
466  e:= addDomain(m,e) --???unnecessary because of comp2's call???
467  (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T
468  compToApply(op,argl,m,e)
469
470compForm2(form is [op,:argl],m,e,modemapList) ==
471  sargl:= TAKE(# argl, $TriangleVariableList)
472  aList:= [[sa,:a] for a in argl for sa in sargl]
473  modemapList:= SUBLIS(aList,modemapList)
474  Tl:=
475    [[.,.,e]:= T
476      for x in argl while (isSimple x and (T:= compUniquely(x,$EmptyMode,e)))]
477  or/[x for x in Tl] =>
478    partialModeList:= [(x => x.mode; nil) for x in Tl]
479    compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) or
480      compForm3(form,m,e,modemapList)
481  compForm3(form,m,e,modemapList)
482
483compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) ==
484  mmList:= [mm for mm in modemapList | compFormMatch(mm,partialModeList)] =>
485    compForm3(form,m,e,mmList)
486
487compFormMatch(mm,partialModeList) ==
488  mm is [[.,.,:argModeList],:.] and match(argModeList,partialModeList) where
489    match(a,b) ==
490      null b => true
491      null first b => match(rest a,rest b)
492      first a=first b and match(rest a,rest b)
493
494compForm3(form is [op,:argl],m,e,modemapList) ==
495  T:=
496    or/
497      [compFormWithModemap(form,m,e,first (mml:= ml))
498        for ml in tails modemapList]
499  $compUniquelyIfTrue =>
500    or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] =>
501      THROW("compUniquely",nil)
502    T
503  T
504
505getFormModemaps(form is [op,:argl],e) ==
506  op is ["Sel", domain, op1] =>
507    [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]]
508  null atom op => nil
509  modemapList:= get(op,"modemap",e)
510  if $insideCategoryPackageIfTrue then
511    modemapList := [x for x in modemapList | x is [[dom,:.],:.] and dom ~= '$]
512  if op = "elt" and #argl = 2 or op = "setelt!" and #argl = 3 then
513      modemapList := eltModemapFilter(argl.1, modemapList, e) or return nil
514  nargs:= #argl
515  finalModemapList:= [mm for (mm:= [[.,.,:sig],:.]) in modemapList | #sig=nargs]
516  modemapList and null finalModemapList =>
517    stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"]
518  finalModemapList
519
520eltModemapFilter(name,mmList,e) ==
521  isConstantId(name,e) =>
522    l:= [mm for mm in mmList | mm is [[.,.,.,sel,:.],:.] and sel=name] => l
523            -- setelt! has extra parameter
524    stackMessage ["selector variable: ",name," is undeclared and unbound"]
525    nil
526  mmList
527
528substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) ==
529  #dc~=#sig =>
530    keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap",
531      '"Incompatible maps"])
532  #argl=#rest sig =>
533                        --here, we actually have a functor form
534    sig:= EQSUBSTLIST(argl,rest dc,sig)
535      --make new modemap, subst. actual for formal parametersinto modemap
536    Tl:= [[.,.,e]:= compOrCroak(a,m,e) for a in argl for m in rest sig]
537    substitutionList:= [[x,:T.expr] for x in rest dc for T in Tl]
538    [SUBLIS(substitutionList,modemap),e]
539  nil
540
541--% SPECIAL EVALUATION FUNCTIONS
542
543--% SETQ
544
545compSetq([":=", form, val], m, E) == compSetq1(form, val, m, E)
546
547compSetq1(form,val,m,E) ==
548  IDENTP form => setqSingle(form,val,m,E)
549  form is [":",x,y] =>
550    [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E)
551    compSetq([":=", x, val], m, E')
552  form is [op,:l] =>
553    op="CONS"  => setqMultiple(uncons form,val,m,E)
554    op = "@Tuple" => setqMultiple(l, val, m, E)
555    setqSetelt(form,val,m,E)
556
557compMakeDeclaration(x,m,e) ==
558  compColon(x,m,e)
559
560setqSetelt([v,:s],val,m,E) ==
561    comp(["setelt!", v, :s, val], m, E)
562
563setqSingle(id,val,m,E) ==
564  $insideSetqSingleIfTrue: local:= true
565    --used for comping domain forms within functions
566  currentProplist:= getProplist(id,E)
567  m'':=
568    get(id,'mode,E) or getmode(id,E) or
569       (if m=$NoValueMode then $EmptyMode else m)
570-- m'':= LASSOC("mode",currentProplist) or $EmptyMode
571       --for above line to work, line 3 of compNoStackingis required
572  T:=
573    eval or return nil where
574      eval() ==
575        T:= comp(val,m'',E) => T
576        not get(id,"mode",E) and m'' ~= (maxm'':=maxSuperType(m'',E)) and
577           (T:=comp(val,maxm'',E)) => T
578        (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) =>
579          assignError(val,T.mode,id,m'')
580  m'' = $EmptyMode and T.mode = $EmptyMode =>
581      stackMessage ["No mode in assignment to: ", id]
582  finish_setq_single(T, m, id, val, currentProplist)
583
584finish_setq_single(T, m, id, val, currentProplist) ==
585  T' := [x, m', e'] := convert(T, m) or return nil
586  newProplist:= consProplistOf(id,currentProplist,"value",removeEnv [val,:rest T])
587  e':= (PAIRP id => e'; addBinding(id,newProplist,e'))
588  if isDomainForm(val,e') then
589    if isDomainInScope(id,e') then
590      stackWarning ["domain valued variable","%b",id,"%d",
591        "has been reassigned within its scope"]
592    e':= augModemapsFromDomain1(id,val,e')
593      --all we do now is to allocate a slot number for lhs
594      --e.g. the LET form below will be changed by putInLocalDomainReferences
595--+
596  saveLocVarsTypeDecl(x, id, e')
597
598  if (k:=NRTassocIndex(id))
599     then form:=['SETELT,"$",k,x]
600     else form:=
601         $QuickLet => ["LET",id,x]
602         ["LET",id,x,
603            (isDomainForm(x, e') => ['ELT, id, 0]; first outputComp(id, e'))]
604  [form,m',e']
605
606saveLocVarsTypeDecl(x, id, e) ==
607    t := getmode(id, e) =>
608        t := (t = '$EmptyMode => nil; ATOM(t) => [t]; t)
609        typeDecl := ASSOC(id, $locVarsTypes)
610        null typeDecl =>
611            if null t then
612                SAY("Local variable ", id, " lacks type.")
613            else $locVarsTypes := ACONS(id, t, $locVarsTypes)
614        t' := CDR(typeDecl)
615        not EQUAL(t, t') =>
616            if not null t' then
617                SAY("Local variable ", id, " type redefined: ", t, " to ", t')
618            RPLACD(typeDecl, t)
619
620assignError(val,m',form,m) ==
621  message:=
622    val =>
623      ["CANNOT ASSIGN: ",val,"%l","   OF MODE: ",m',"%l","   TO: ",form,"%l",
624        "   OF MODE: ",m]
625    ["CANNOT ASSIGN: ",val,"%l","   TO: ",form,"%l","   OF MODE: ",m]
626  stackMessage message
627
628MKPROGN(l) == MKPF(l, "PROGN")
629
630setqMultiple(nameList,val,m,e) ==
631  val is ["CONS",:.] and m=$NoValueMode =>
632    setqMultipleExplicit(nameList,uncons val,m,e)
633  val is ["@Tuple", :l] and m = $NoValueMode =>
634      setqMultipleExplicit(nameList,l,m,e)
635  -- 1 create a gensym, add to local environment, compile and assign rhs
636  g:= genVariable()
637  e:= addBinding(g,nil,e)
638  T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil
639  e:= put(g,"mode",m1,e)
640  [x,m',e]:= convert(T,m) or return nil
641  -- 1.1 exit if result is a list
642  m1 is ["List",D] =>
643    g2 := genVariable()
644    e := addBinding(g2, nil, e)
645    e := put(g2, "mode", m1, e)
646    T := compSetq1(g2, g, m1, e) or return nil
647    [x2, ., e] := convert(T, m1) or return nil
648    ass_list := []
649    for y in nameList repeat
650        e := put(y, "value", [genSomeVariable(), D, $noEnv], e)
651        ass_list := cons(["LET", y, ["SPADfirst", g2]], ass_list)
652        ass_list := cons(["LET", g2, ["CDR", g2]], ass_list)
653    ass_list := nreverse(rest(ass_list))
654    convert([["PROGN",x, x2, :ass_list, g], m', e], m)
655  -- 2 verify that the #nameList = number of parts of right-hand-side
656  selectorModePairs:=
657                                                --list of modes
658    decompose(m1,#nameList,e) or return nil where
659      decompose(t,length,e) ==
660        t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l]
661        comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] =>
662          [[name,:mode] for [":",name,mode] in l]
663        stackMessage ["no multiple assigns to mode: ",t]
664  #nameList~=#selectorModePairs =>
665    stackMessage [val," must decompose into ",#nameList," components"]
666  -- 3 generate code; return
667  assignList:=
668    [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr
669      for x in nameList for [y,:z] in selectorModePairs]
670  if assignList="failed" then NIL
671  else [MKPROGN [x,:assignList,g],m',e]
672
673setqMultipleExplicit(nameList,valList,m,e) ==
674  #nameList~=#valList =>
675    stackMessage ["Multiple assignment error; # of items in: ",nameList,
676      "must = # in: ",valList]
677  gensymList:= [genVariable() for name in nameList]
678  assignList:=
679             --should be fixed to declare genVar when possible
680    [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed"
681      for g in gensymList for val in valList]
682  assignList="failed" => nil
683  reAssignList:=
684    [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed"
685      for g in gensymList for name in nameList]
686  reAssignList="failed" => nil
687  [["PROGN",:[T.expr for T in assignList],:[T.expr for T in reAssignList]],
688    $NoValueMode, (last reAssignList).env]
689
690--% WHERE
691compWhere([.,form,:exprList],m,eInit) ==
692  $insideWhereIfTrue: local:= true
693  e:= eInit
694  u:=
695    for item in exprList repeat
696      [.,.,e]:= comp(item,$EmptyMode,e) or return "failed"
697  u="failed" => return nil
698  $insideWhereIfTrue:= false
699  [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil
700  eFinal:=
701    del:= deltaContour(eAfter,eBefore) => addContour(del,eInit)
702    eInit
703  [x,m,eFinal]
704
705comp_construct1(l, m, e) ==
706    (y := modeIsAggregateOf("List", m, e)) =>
707        compList(l, ["List", CADR y], e)
708    (y := modeIsAggregateOf("Vector", m, e)) =>
709        compVector(l,["Vector",CADR y],e)
710
711compConstruct(form is ["construct", :l], m, e) ==
712    (T := comp_construct1(l, m, e)) and (T' := convert(T,m)) => T'
713    T := compForm(form, m, e) => T
714    for D in getDomainsInScope e repeat
715        (T := comp_construct1(l, D, e)) and (T' := convert(T, m)) =>
716            return T'
717
718compQuote(expr is [QUOTE, e1], m, e) ==
719  SYMBOLP(e1) => [expr, ["Symbol"], e]
720  stackAndThrow ["Strange argument to QUOTE", expr]
721  -- [expr,m,e]
722
723compList(l,m is ["List",mUnder],e) ==
724  null l => [NIL,m,e]
725  Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l]
726  Tl="failed" => nil
727  T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e]
728
729compVector(l,m is ["Vector",mUnder],e) ==
730  null l => [$EmptyVector,m,e]
731  Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l]
732  Tl="failed" => nil
733  [["VECTOR",:[T.expr for T in Tl]],m,e]
734
735--% MACROS
736compMacro(form,m,e) ==
737  ["MDEF",lhs,signature,specialCases,rhs]:= form
738  prhs :=
739    rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
740    rhs is ['Join,:.]     => ['"-- the constructor category"]
741    rhs is ['CAPSULE,:.]  => ['"-- the constructor capsule"]
742    rhs is ['add,:.]      => ['"-- the constructor capsule"]
743    formatUnabbreviated rhs
744  sayBrightly ['"   processing macro definition",'%b,
745    :formatUnabbreviated lhs,'" ==> ",:prhs,'%d]
746  ATOM(lhs) => userError("Malformed macro definition")
747  nrhs :=
748      (margs := rest(lhs)) => [rhs, :margs]
749      [rhs]
750  m=$EmptyMode or m=$NoValueMode =>
751    ["/throwAway", $NoValueMode, put(first lhs, "macro", nrhs, e)]
752
753--% SEQ
754
755compSeq(["SEQ",:l],m,e) == compSeq1(l,[m,:$exitModeStack],e)
756
757compSeq1(l,$exitModeStack,e) ==
758  $finalEnv: local := false
759           --used in replaceExitEtc.
760  c:=
761    [([.,.,e]:=
762
763
764      --this used to be compOrCroak-- but changed so we can back out
765
766        (compSeqItem(x, $NoValueMode, e) or return "failed")).expr for x in l]
767  if c="failed" then return nil
768  catchTag:= MKQ GENSYM()
769  form:= ["SEQ",:replaceExitEtc(c,catchTag,"TAGGEDexit",$exitModeStack.(0))]
770  [["CATCH",catchTag,form],$exitModeStack.(0),$finalEnv]
771
772compSeqItem(x,m,e) == comp(macroExpand(x,e),m,e)
773
774replaceExitEtc(x,tag,opFlag,opMode) ==
775  (fn(x,tag,opFlag,opMode); x) where
776    fn(x,tag,opFlag,opMode) ==
777      atom x => nil
778      x is ["QUOTE",:.] => nil
779      x is [ =opFlag,n,t] =>
780        rplac(first t,replaceExitEtc(first t, tag, opFlag, opMode))
781        n = 0 =>
782          $finalEnv:=
783                  --bound in compSeq1 and compDefineCapsuleFunction
784            $finalEnv => intersectionEnvironment($finalEnv,t.env)
785            t.env
786          rplac(first x,"THROW")
787          rplac(CADR x,tag)
788          rplac(CADDR x,(convertOrCroak(t,opMode)).expr)
789        true => rplac(CADR x,CADR x-1)
790      x is [key,n,t] and MEMQ(key,'(TAGGEDreturn TAGGEDexit)) =>
791        rplac(first t,replaceExitEtc(first t,tag,opFlag,opMode))
792      replaceExitEtc(first x,tag,opFlag,opMode)
793      replaceExitEtc(rest x,tag,opFlag,opMode)
794
795
796--% try
797
798comp_try(["try", expr, catcher, finallizer], m, e) ==
799    $exitModeStack : local := [m, :$exitModeStack]
800    if catcher then
801        stackAndThrow ["comp_try: catch unimplemented"]
802    ([c1, m1, .] := comp(expr, m, e)) or return nil
803    ([c2, ., .] := comp(finallizer, $EmptyMode, e)) or return nil
804    [["finally", c1, c2], m1, e]
805
806--% SUCHTHAT
807compSuchthat([.,x,p],m,e) ==
808  [x',m',e]:= comp(x,m,e) or return nil
809  [p',.,e]:= comp(p,$Boolean,e) or return nil
810  e:= put(x',"condition",p',e)
811  [x',m',e]
812
813--% exit
814
815compExit(["exit",level,x],m,e) ==
816  index:= level-1
817  $exitModeStack = [] => comp(x,m,e)
818  m1:= $exitModeStack.index
819  [x',m',e']:=
820    u:=
821      comp(x,m1,e) or return
822        stackMessageIfNone ["cannot compile exit expression",x,"in mode",m1]
823  modifyModeStack(m',index)
824  [["TAGGEDexit",index,u],m,e]
825
826modifyModeStack(m,index) ==
827  $reportExitModeStack =>
828    SAY("exitModeStack: ",COPY $exitModeStack," ====> ",
829      ($exitModeStack.index:= resolve(m,$exitModeStack.index); $exitModeStack))
830  $exitModeStack.index:= resolve(m,$exitModeStack.index)
831
832compLeave(["leave",level,x],m,e) ==
833  index:= #$exitModeStack-1-$leaveLevelStack.(level-1)
834  [x',m',e']:= u:= comp(x,$exitModeStack.index,e) or return nil
835  modifyModeStack(m',index)
836  [["TAGGEDexit",index,u],m,e]
837
838--% return
839
840compReturn(["return", x], m, e) ==
841  ns := #$exitModeStack
842  ns = $currentFunctionLevel =>
843    stackSemanticError(["the return before","%b",x,"%d","is unnecessary"],nil)
844    nil
845  index := MAX(0, ns - $currentFunctionLevel - 1)
846  $returnMode:= resolve($exitModeStack.index,$returnMode)
847  [x',m',e']:= u:= comp(x,$returnMode,e) or return nil
848  $returnMode:= resolve(m',$returnMode)
849  modifyModeStack(m',index)
850  [["TAGGEDreturn",0,u],m,e']
851
852--% ELT
853
854compSel(form is ["Sel", aDomain, anOp], m, E) ==
855  aDomain="Lisp" =>
856    [anOp',m,E] where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp)
857  anOp := (anOp = $Zero => "Zero"; anOp = $One => "One"; anOp)
858  compSel1(aDomain, anOp, [], m, E)
859
860--% HAS
861
862compHas(pred is ["has", a, b], m, e) ==
863  --b is (":",:.) => (.,.,E):= comp(b,$EmptyMode,E)
864  e := chaseInferences(pred, e)
865  --pred':= ("has",a',b') := formatHas(pred)
866  predCode := compHasFormat1(pred, e)
867  coerce([predCode, $Boolean, e], m)
868
869compHasFormat1(pred is ["has", a, b], e) ==
870    [a, :.] := comp(a, $EmptyMode, e) or return nil
871    b is ["ATTRIBUTE", c] => BREAK()
872    b is ["SIGNATURE", op, sig] =>
873        ["HasSignature", a,
874          mkList [MKQ op, mkList [mkDomainConstructor type for type in sig]]]
875    isDomainForm(b, $EmptyEnvironment) => ["EQUAL", a, b]
876    ["HasCategory", a, mkDomainConstructor b]
877
878--used in various other places to make the discrimination
879compHasFormat (pred is ["has",olda,b], e) ==
880  argl := rest($functorForm)
881  formals := TAKE(#argl,$FormalMapVariableList)
882  a := SUBLISLIS(argl,formals,olda)
883  [a,:.] := comp(a, $EmptyMode, e) or return nil
884  a := SUBLISLIS(formals,argl,a)
885  b is ["ATTRIBUTE",c] => BREAK()
886  b is ["SIGNATURE",op,sig] =>
887     ["HasSignature",a,
888       mkList [MKQ op,mkList [mkDomainConstructor type for type in sig]]]
889  isDomainForm(b,$EmptyEnvironment) => ["EQUAL",a,b]
890  ["HasCategory",a,mkDomainConstructor b]
891
892--% IF
893
894compIf(["IF",a,b,c],m,E) ==
895  [xa,ma,Ea,Einv]:= compBoolean(a,$Boolean,E) or return nil
896  [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil
897  [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil
898  xb':= coerce(Tb,mc) or return nil
899  x:= ["IF", xa, xb'.expr, xc]
900  (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where
901    Env(bEnv,cEnv,b,c,E) ==
902      canReturn(b,0,0,true) =>
903        (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv)
904      canReturn(c,0,0,true) => cEnv
905      E
906  [x,mc,returnEnv]
907
908canReturn(expr,level,exitCount,ValueFlag) ==  --SPAD: exit and friends
909  atom expr => ValueFlag and level=exitCount
910  (op:= first expr)="QUOTE" => ValueFlag and level=exitCount
911  op="TAGGEDexit" =>
912    expr is [.,count,data] => canReturn(data.expr,level,count,count=level)
913  level=exitCount and not ValueFlag => nil
914  op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr]
915  op = "error" => nil
916  op="TAGGEDreturn" => nil
917  op="CATCH" =>
918    [.,gs,data]:= expr
919    (findThrow(gs,data,level,exitCount,ValueFlag) => true) where
920      findThrow(gs,expr,level,exitCount,ValueFlag) ==
921        atom expr => nil
922        expr is ["THROW", =gs,data] => true
923            --this is pessimistic, but I know of no more accurate idea
924        expr is ["SEQ",:l] =>
925          or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l]
926        or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr]
927    canReturn(data,level,exitCount,ValueFlag)
928  op = "COND" =>
929    level = exitCount =>
930      or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr]
931    or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v]
932                for v in rest expr]
933  op="IF" =>
934    expr is [.,a,b,c]
935    if not canReturn(a,0,0,true) then
936      SAY "IF statement can not cause consequents to be executed"
937      pp expr
938    canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag)
939      or canReturn(c,level,exitCount,ValueFlag)
940  op = "SPROG" =>
941      expr is [., defs, body]
942      canReturn(body, level, exitCount, ValueFlag)
943  op = "LAMBDA" =>
944      expr is [., args, :body]
945      and/[canReturn(u, level, exitCount, ValueFlag) for u in body]
946  --now we have an ordinary form
947  atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
948  op is ["XLAM",args,bods] =>
949    and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
950  systemErrorHere '"canReturn" --for the time being
951
952compBoolean(p,m,E) ==
953  [p',m,E]:= comp(p,m,E) or return nil
954  [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)]
955
956getSuccessEnvironment(a,e) ==
957  -- the next four lines try to ensure that explicit special-case tests
958  --  prevent implicit ones from being generated
959  a is ["has",x,m] =>
960    e
961  a is ["is",id,m] =>
962    IDENTP id and isDomainForm(m,$EmptyEnvironment) =>
963         currentProplist:= getProplist(id,e)
964         [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs
965         newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T])
966         addBinding(id,newProplist,e)
967    e
968  a is ["case",x,m] and IDENTP x =>
969    put(x,"condition",[a,:get(x,"condition",e)],e)
970  e
971
972getInverseEnvironment(a,E) ==
973  atom a => E
974  [op,:argl]:= a
975-- the next five lines try to ensure that explicit special-case tests
976-- prevent implicit ones from being generated
977  op="has" =>
978    [x,m]:= argl
979    E
980  a is ["case",x,m] and IDENTP x =>
981           --the next two lines are necessary to get 3-branched Unions to work
982           -- old-style unions, that is
983    (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) =>
984      put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E)
985    getUnionMode(x,E) is ["Union",:l]
986    l':= delete(m,l)
987    for u in l' repeat
988       if u is ['_:,=m,:.] then l':=delete(u,l')
989    newpred:= MKPF([["case",x,m'] for m' in l'],"OR")
990    put(x,"condition",[newpred,:get(x,"condition",E)],E)
991  E
992
993getUnionMode(x,e) ==
994  m:=
995    atom x => getmode(x,e)
996    return nil
997  isUnionMode(m,e)
998
999isUnionMode(m,e) ==
1000  m is ["Union",:.] => m
1001  (m':= getmode(m,e)) is ["Mapping",["UnionCategory",:.]] => CADR m'
1002  v:= get(if m="$" then "Rep" else m,"value",e) =>
1003    (v.expr is ["Union",:.] => v.expr; nil)
1004  nil
1005
1006compFromIf(a,m,E) ==
1007  a="noBranch" => ["noBranch",m,E]
1008  true => comp(a,m,E)
1009
1010compImport(["import",:doms],m,e) ==
1011  for dom in doms repeat e:=addDomain(dom,e)
1012  ["/throwAway",$NoValueMode,e]
1013
1014--Will the jerk who commented out these two functions please NOT do so
1015--again.  These functions ARE needed, and case can NOT be done by
1016--modemap alone.  The reason is that A case B requires to take A
1017--evaluated, but B unevaluated.  Therefore a special function is
1018--required.  You may have thought that you had tested this on "failed"
1019--etc., but "failed" evaluates to it's own mode.  Try it on x case $
1020--next time.
1021--                An angry JHD - August 15th., 1984
1022
1023compCase(["case",x,m'],m,e) ==
1024  e:= addDomain(m',e)
1025  T:= compCase1(x,m',e) => coerce(T,m)
1026  nil
1027
1028compCase1(x,m,e) ==
1029  [x',m',e']:= comp(x,$EmptyMode,e) or return nil
1030  u:=
1031    [cexpr
1032      for (modemap:= [map,cexpr]) in getModemapList("case",2,e') | map is [.,.,s,
1033        t] and modeEqual(t,m) and modeEqual(s,m')] or return nil
1034  fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
1035  [["call",fn,x'],$Boolean,e']
1036
1037compColon([":",f,t],m,e) ==
1038  t:=
1039    atom t and (t':= assoc(t,getDomainsInScope e)) => t'
1040    isDomainForm(t,e) and not $insideCategoryIfTrue =>
1041      (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t)
1042    isDomainForm(t, e) or isCategoryForm(t) => t
1043    t is ["Mapping",m',:r] => t
1044    unknownTypeError t
1045    t
1046  f is ["LISTOF",:l] =>
1047    (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T)
1048  e:=
1049    f is [op,:argl] =>
1050      --for MPOLY--replace parameters by formal arguments: RDJ 3/83
1051      newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList),
1052        [(x is [":",a,m] => a; x) for x in argl],t)
1053      signature:=
1054        ["Mapping",newTarget,:
1055          [(x is [":",a,m] => m;
1056              getmode(x,e) or systemErrorHere '"compColon") for x in argl]]
1057      put(op,"mode",signature,e)
1058    put(f,"mode",t,e)
1059  if not $bootStrapMode and $insideFunctorIfTrue and
1060    makeCategoryForm(t,e) is [catform,e] then
1061        e:= put(f,"value",[genSomeVariable(),t,$noEnv],e)
1062  ["/throwAway",getmode(f,e),e]
1063
1064unknownTypeError name ==
1065  name:=
1066    name is [op,:.] => op
1067    name
1068  stackSemanticError(["%b",name,"%d","is not a known type"],nil)
1069
1070compPretend(["pretend",x,t],m,e) ==
1071  e:= addDomain(t,e)
1072  T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil
1073  if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"]
1074  if opOf(T.mode) = 'Union and opOf(m) ~= 'Union then
1075     stackWarning(["cannot pretend ",x," of mode ",T.mode," to mode ",m])
1076  T:= [T.expr,t,T.env]
1077  T':= coerce(T,m) => (if warningMessage then stackWarning warningMessage; T')
1078
1079compIs(["is",a,b],m,e) ==
1080  [aval,am,e] := comp(a,$EmptyMode,e) or return nil
1081  [bval,bm,e] := comp(b,$EmptyMode,e) or return nil
1082  T:= [["domainEqual",aval,bval],$Boolean,e]
1083  coerce(T,m)
1084
1085--%  Functions for coercion by the compiler
1086
1087--  The function coerce is used by the old compiler for coercions.
1088--  The function coerceInteractive is used by the interpreter.
1089--  One should always call the correct function, since the represent-
1090--  ation of basic objects may not be the same.
1091--
1092-- Type in returned triple is m when m is not $EmptyMode,
1093-- otherwise it is type from T
1094coerce(T,m) ==
1095  $InteractiveMode =>
1096    keyedSystemError("S2GE0016",['"coerce",
1097      '"function coerce called from the interpreter."])
1098  rplac(CADR T,substitute("$",$Rep,CADR T))
1099  T':= coerceEasy(T,m) => T'
1100  T' := constant_coerce(T, m) => T'
1101  T':= coerceSubset(T,m) => T'
1102  T':= coerceHard(T,m) => T'
1103  T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil
1104      -- if from coerceable, this coerce was just a trial coercion
1105      -- from compFormWithModemap to filter through the modemaps
1106  stackMessage fn(T.expr,T.mode,m) where
1107    fn(x,m1,m2) ==
1108      ["Cannot coerce","%b",x,"%d","%l","      of mode","%b",m1,"%d","%l",
1109        "      to mode","%b",m2,"%d"]
1110
1111coerceEasy(T,m) ==
1112  m=$EmptyMode => T
1113  m=$NoValueMode or m=$Void => [T.expr,m,T.env]
1114  T.mode =m => T
1115  T.mode =$Exit =>
1116      [["PROGN", T.expr, ["userError", '"Did not really exit."]],
1117        m,T.env]
1118  T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) =>
1119    [T.expr,m,T.env]
1120
1121coerceSubset([x,m,e],m') ==
1122  isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e]
1123  m is ['SubDomain,=m',:.] => [x,m',e]
1124  INTEGERP x and (pred:= isSubset(m',maxSuperType(m,e),e)) -- again temporary
1125    and eval substitute(x,"*",pred) =>
1126      [x,m',e]
1127  nil
1128
1129check_prop(pl, m) ==
1130    (QLASSQ("value", pl) is [m'', :.] or
1131      QLASSQ("mode", pl) is ["Mapping", m'']) and modeEqual(m'', m)
1132
1133coerceHard(T,m) ==
1134  e := T.env
1135  m':= T.mode
1136  STRINGP m' and modeEqual(m, $String) => [T.expr, m, e]
1137  STRINGP T.expr and modeEqual(m', $String) and modeEqual(m, $Symbol) =>
1138      [["QUOTE", INTERN(T.expr, "BOOT")], m, e]
1139  modeEqual(m', m) => [T.expr, m, e]
1140  STRINGP T.expr and T.expr = m => [T.expr, m, e]
1141  pl' := getProplist(m', e)
1142  check_prop(pl', m) => [T.expr, m, e]
1143  pl := getProplist(m, e)
1144  check_prop(pl, m') => [T.expr, m, e]
1145  isCategoryForm(m) =>
1146      $bootStrapMode = true => [T.expr, m, e]
1147      extendsCategoryForm(T.expr, T.mode, m, e) => [T.expr, m, e]
1148      coerceExtraHard(T, m, pl, pl')
1149  coerceExtraHard(T, m, pl, pl')
1150
1151getmode_pl(x, pl) ==
1152  u := QLASSQ("value", pl) => u.mode
1153  QLASSQ("mode", pl)
1154
1155isUnionMode2(m, e, pl) ==
1156  m is ["Union",:.] => m
1157  (m' := getmode_pl(m, pl)) is ["Mapping", ["UnionCategory", :.]] => CADR m'
1158  -- FIXME: Hardcoded assumprion about Rep
1159  v :=
1160      m = "$" => get("Rep", "value", e)
1161      QLASSQ("value", pl)
1162  v => (v.expr is ["Union",:.] => v.expr; nil)
1163  nil
1164
1165coerceExtraHard(T is [x, m', e], m, pl, pl') ==
1166  T':= autoCoerceByModemap(T,m) => T'
1167  isUnionMode2(m', e, pl') is ["Union",:l] and (t:= hasType(x,e)) and
1168    member(t,l) and (T':= autoCoerceByModemap(T,t)) and
1169      (T'':= coerce(T',m)) => T''
1170  m' is ['Record, :.] and m = $OutputForm =>
1171      [['coerceRe2E,x,['ELT,COPY m',0]],m,e]
1172  nil
1173
1174coerceable(m,m',e) ==
1175  m=m' => m
1176  -- must find any free parameters in m
1177  sl:= pmatch(m',m) => SUBLIS(sl,m')
1178  coerce(["$fromCoerceable$",m,e],m') => m'
1179  nil
1180
1181coerceExit([x,m,e],m') ==
1182  m':= resolve(m,m')
1183  x':= replaceExitEtc(x,catchTag:= MKQ GENSYM(),"TAGGEDexit",$exitMode)
1184  coerce([["CATCH",catchTag,x'],m,e],m')
1185
1186compAtSign(["@",x,m'],m,e) ==
1187  e:= addDomain(m',e)
1188  T:= comp(x,m',e) or return nil
1189  coerce(T,m)
1190
1191compCoerce(["::",x,m'],m,e) ==
1192  e:= addDomain(m',e)
1193  T:= compCoerce1(x,m',e) => coerce(T,m)
1194
1195compCoerce1(x,m',e) ==
1196  T:= comp(x,m',e) or comp(x,$EmptyMode,e) or return nil
1197  m1:=
1198    STRINGP T.mode => $String
1199    T.mode
1200  T1 := constant_coerce(T, m') => T1
1201  m':=resolve(m1,m')
1202  T:=[T.expr,m1,T.env]
1203  T':= coerce(T,m') => T'
1204  T':= coerceByModemap(T,m') => T'
1205  pred:=isSubset(m',T.mode,e) =>
1206    gg:=GENSYM()
1207    pred:= substitute(gg,"*",pred)
1208    code := ['PROG1, ['LET, gg, T.expr],
1209                     ['check_subtype2, pred, MKQ m', MKQ T.mode, gg]]
1210    [code,m',T.env]
1211
1212constant_coerce([x, m, e], m') ==
1213    m' = $SingleInteger =>
1214        if x = ["Zero"] then x = 0
1215        if x = ["One"] then x = 1
1216        not(INTEGERP(x)) => nil
1217        -- Check if in range of FIXNUM on all supported implementations
1218        x > 8000000 or x < -8000000 => nil
1219        m = $Integer or m = $PositiveInteger or $NonNegativeInteger =>
1220            [x, m', e]
1221        nil
1222    m' = $DoubleFloat and m = $Float =>
1223        x is [["Sel", ["Float"], "float"], mant, exp, 10] =>
1224            try_constant_DF(mant, exp, m, e)
1225        nil
1226    nil
1227
1228coerceByModemap([x,m,e],m') ==
1229--+ modified 6/27 for new runtime system
1230  u:=
1231    [modemap
1232      for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t,
1233        s] and (modeEqual(t,m') or isSubset(t,m',e))
1234           and (modeEqual(s,m) or isSubset(m,s,e))] or return nil
1235
1236  --mm:= (or/[mm for (mm:=[.,[cond,.]]) in u | cond=true]) or return nil
1237  mm:=first u  -- patch for non-trival conditions
1238  fn :=
1239      genDeltaEntry(['coerce, :mm], e)
1240  [["call",fn,x],m',e]
1241
1242autoCoerceByModemap([x,source,e],target) ==
1243  u:=
1244    [cexpr
1245      for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [
1246        .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil
1247  fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
1248  source is ["Union",:l] and member(target,l) =>
1249    (y:= get(x,"condition",e)) and (or/[u is ["case",., =target] for u in y])
1250       => [["call",fn,x],target,e]
1251    x="$fromCoerceable$" => nil
1252    stackMessage ["cannot coerce: ",x,"%l","      of mode: ",source,"%l",
1253      "      to: ",target," without a case statement"]
1254  [["call",fn,x],target,e]
1255
1256--% Very old resolve
1257-- should only be used in the old (preWATT) compiler
1258
1259resolve(din,dout) ==
1260  din=$NoValueMode or dout=$NoValueMode => $NoValueMode
1261  dout=$EmptyMode => din
1262  din ~= dout and STRINGP dout and modeEqual(din, $String) => nil
1263  dout
1264
1265modeEqual(x,y) ==
1266  EQ(x, y) => true
1267  -- FIXME: we should eliminate confusion due to 0 and 1 instead
1268  -- of hacks like below
1269  atom x =>
1270      x = y => true
1271      x = 0 => y = ["Zero"]
1272      x = 1 => y = ["One"]
1273      false
1274  atom y =>
1275      x = y => true
1276      y = 0 => x = ["Zero"]
1277      y = 1 => x = ["One"]
1278      false
1279  #x ~=#y => nil
1280  (and/[modeEqual(u,v) for u in x for v in y])
1281
1282modeEqualSubst(m1,m,e) ==
1283  atom m1 and EQ(m1, m) => true
1284  if atom m1 then
1285      m1 :=
1286          get(m1,"value",e) is [m0,:.] => m0
1287          m1
1288  if atom m then
1289      m :=
1290          get(m,"value",e) is [m2,:.] => m2
1291          m
1292  atom m1 or atom m => m1 = m
1293  modeEqual(m1, m) => true
1294  -- atom m1 => get(m1,"value",e) is [m',:.] and modeEqual(m',m)
1295  m1 is [op,:l1] and m is [=op,:l2]  and # l1 = # l2 =>
1296-- Above length test inserted JHD 4:47 on 15/8/86
1297-- Otherwise Records can get fouled up - consider expressIdealElt
1298-- in the DEFAULTS package
1299        and/[modeEqualSubst(xm1,xm2,e) for xm1 in l1 for xm2 in l2]
1300  nil
1301
1302--% Things to support )compile
1303
1304compileSpad2Cmd args ==
1305    -- This is the old compiler
1306    -- Assume we entered from the "compiler" function, so args ~= nil
1307    -- and is a file with file extension .spad.
1308
1309    path := pathname args
1310    pathnameType path ~= '"spad" => throwKeyedMsg("S2IZ0082", nil)
1311    not PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args])
1312
1313    $edit_file := path
1314    sayKeyedMsg("S2IZ0038",[namestring args])
1315
1316    optList :=  '( _
1317      break _
1318      constructor _
1319      functions _
1320      library _
1321      lisp _
1322      new _
1323      old _
1324      nobreak _
1325      nolibrary _
1326      noquiet _
1327      vartrace _
1328      quiet _
1329        )
1330
1331    -- next three are for the OLD NEW compiler
1332    -- should be unhooked
1333
1334    $scanIfTrue              : local := nil
1335    $f                       : local := nil  -- compiler
1336    $m                       : local := nil  --   variables
1337
1338    -- following are for )quick option for code generation
1339    $QuickLet   : local := true
1340    $QuickCode  : local := true
1341
1342    fun         := ['rq, 'lib]
1343    constructor := nil
1344
1345    for opt in $options repeat
1346        [optname,:optargs] := opt
1347        fullopt := selectOptionLC(optname,optList,nil)
1348
1349        fullopt = 'new         => error "Internal error: compileSpad2Cmd got )new"
1350        fullopt = 'old         => NIL     -- no opt
1351
1352        fullopt = 'library     => fun.1 := 'lib
1353        fullopt = 'nolibrary   => fun.1 := 'nolib
1354
1355        -- Ignore quiet/nonquiet if "constructor" is given.
1356        fullopt = 'quiet       => if fun.0 ~= 'c then fun.0 := 'rq
1357        fullopt = 'noquiet     => if fun.0 ~= 'c then fun.0 := 'rf
1358        fullopt = 'nobreak     => $scanIfTrue := true
1359        fullopt = 'break       => $scanIfTrue := nil
1360        fullopt = 'vartrace      =>
1361          $QuickLet  := false
1362        fullopt = 'lisp        =>
1363          throwKeyedMsg("S2IZ0036",['")lisp"])
1364        fullopt = 'functions   =>
1365            null optargs =>
1366              throwKeyedMsg("S2IZ0037",['")functions"])
1367            throwKeyedMsg(")functions unsupported", [])
1368        fullopt = 'constructor =>
1369            null optargs =>
1370              throwKeyedMsg("S2IZ0037",['")constructor"])
1371            fun.0       := 'c
1372            constructor := [unabbrev o for o in optargs]
1373        throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)])
1374
1375    $InteractiveMode : local := nil
1376    compilerDoit(constructor, fun)
1377    extendLocalLibdb $newConlist
1378    terminateSystemCommand()
1379    spadPrompt()
1380
1381compilerDoit(constructor, fun) ==
1382    $byConstructors : local := []
1383    $constructorsSeen : local := []
1384    fun = ['rf, 'lib]   => read_or_compile(true, true)    -- Ignore "noquiet".
1385    fun = ['rf, 'nolib] => read_or_compile(false, false)
1386    fun = ['rq, 'lib]   => read_or_compile(true, true)
1387    fun = ['rq, 'nolib] => read_or_compile(true, false)
1388    fun = ['c,  'lib]   =>
1389      $byConstructors := [opOf x for x in constructor]
1390      read_or_compile(true, true)
1391      for ii in $byConstructors repeat
1392        null member(ii,$constructorsSeen) =>
1393          sayBrightly ['">>> Warning ",'%b,ii,'%d,'" was not found"]
1394
1395