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
34-- Functions which require special handlers (also see end of file)
35DEFPARAMETER($specialOps, [ _
36  "ADEF", "AlgExtension", "and", "case", "COERCE", "COLLECT", "construct", "Declare", "DEF", "Dollar", _
37     "equation", "error", "free", "has", "IF", "is", "isnt", "iterate", "break", "LET", "local", "MDEF", "or", _
38       "pretend", "QUOTE", "REDUCE", "REPEAT", "return", "SEQ", "TARGET", "Tuple", "typeOf", "where" ])
39
40--% Handlers for map definitions
41
42upDEF t ==
43  -- performs map definitions.  value is thrown away
44  t isnt [op,def,pred,.] => nil
45  v:=addDefMap(['DEF,:def],pred)
46  null(LISTP(def)) or null(def) =>
47    keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
48  mapOp := first def
49  if LISTP(mapOp) then
50    null mapOp =>
51      keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
52    mapOp := first mapOp
53  put(mapOp,'value,v,$e)
54  putValue(op,objNew(voidValue(), $Void))
55  putModeSet(op,[$Void])
56
57--% Handler for package calling and $ constants
58
59upDollar t ==
60  -- Puts "dollar" property in atree node, and calls bottom up
61  t isnt [op,D,form] => nil
62  t2 := t
63  (not $genValue) and or/[CONTAINED(var,D) for var in $localVars] =>
64    keyedMsgCompFailure("S2IS0032",NIL)
65  EQ(D,'Lisp) => upLispCall(op,form)
66  if VECP D and (SIZE(D) > 0) then D := D.0
67  t := evaluateType unabbrev D
68  categoryForm? t =>
69    throwKeyedMsg("S2IE0012", [t])
70  f := getUnname form
71  if f = $immediateDataSymbol then
72    f := objValUnwrap coerceInteractive(getValue form,$OutputForm)
73    if f = '(construct) then f := "nil"
74  ATOM(form) and (f ~= $immediateDataSymbol) and
75    (u := findUniqueOpInDomain(op,f,t)) => u
76  f in '(One Zero true false nil) and constantInDomain?([f],t) =>
77    isPartialMode t => throwKeyedMsg("S2IS0020",NIL)
78    if $genValue then
79      val := wrap getConstantFromDomain([f],t)
80    else val := ['getConstantFromDomain,['LIST,MKQ f],MKQ t]
81    putValue(op,objNew(val,t))
82    putModeSet(op,[t])
83
84  nargs := #rest form
85
86  (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms
87
88  f ~= 'construct and null isOpInDomain(f,t,nargs) =>
89    throwKeyedMsg("S2IS0023",[f,t])
90  if (sig := findCommonSigInDomain(f,t,nargs)) then
91    for x in sig for y in form repeat
92      if x then putTarget(y,x)
93  putAtree(first form,'dollar,t)
94  ms := bottomUp form
95  f in '(One Zero) and PAIRP(ms) and first(ms) = $OutputForm =>
96    throwKeyedMsg("S2IS0021",[f,t])
97  putValue(op,getValue first form)
98  putModeSet(op,ms)
99
100
101upDollarTuple(op, f, t, t2, args, nargs) ==
102  -- this function tries to find a tuple function to use
103  nargs = 1 and getUnname first args = "Tuple" => NIL
104  nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL
105  null (singles := isOpInDomain(f,t,1)) => NIL
106  tuple := NIL
107  for [[.,arg], :.] in singles while null tuple repeat
108    if arg is ['Tuple,.] then tuple := arg
109  null tuple => NIL
110  [.,D,form] := t2
111  newArg := [mkAtreeNode "Tuple",:args]
112  putTarget(newArg, tuple)
113  ms := bottomUp newArg
114  first ms ~= tuple => NIL
115  form := [first form, newArg]
116  putAtree(first form,'dollar,t)
117  ms := bottomUp form
118  putValue(op,getValue first form)
119  putModeSet(op,ms)
120
121upLispCall(op,t) ==
122  -- process $Lisp calls
123  if atom t then code:=getUnname t else
124    [lispOp,:argl]:= t
125    not(functionp(lispOp.0) or macrop(lispOp.0)) =>
126      throwKeyedMsg("S2IS0024",[lispOp.0])
127    for arg in argl repeat bottomUp arg
128    code:=[getUnname lispOp,
129      :[getArgValue(arg,computedMode arg) for arg in argl]]
130  code :=
131    $genValue => wrap timedEVALFUN code
132    code
133  rt := '(SExpression)
134  putValue(op,objNew(code,rt))
135  putModeSet(op,[rt])
136
137--% Handlers for equation
138
139upequation tree ==
140  -- only handle this if there is a target of Boolean
141  -- this should speed things up a bit
142  tree isnt [op,lhs,rhs] => NIL
143  $Boolean ~= getTarget(op) => NIL
144  null VECP op => NIL
145  -- change equation into '='
146  op.0 := "="
147  bottomUp tree
148
149--% Handler for error
150
151uperror t ==
152  -- when compiling a function, this merely inserts another argument
153  -- which is the name of the function.
154  not $compilingMap => NIL
155  t isnt [op,msg] => NIL
156  msgMs := bottomUp msg
157  msgMs isnt [=$String] => NIL
158  RPLACD(t,[mkAtree object2String $mapName,msg])
159  bottomUp t
160
161--% Handlers for free and local
162
163upfree t ==
164  putValue(t,objNew('(voidValue),$Void))
165  putModeSet(t,[$Void])
166
167uplocal t ==
168  putValue(t,objNew('(voidValue),$Void))
169  putModeSet(t,[$Void])
170
171upfreeWithType(var,type) ==
172  sayKeyedMsg("S2IS0055",['"free",var])
173  var
174
175uplocalWithType(var,type) ==
176  sayKeyedMsg("S2IS0055",['"local",var])
177  var
178
179--% Handlers for has
180
181uphas t ==
182  t isnt [op,type,prop] => nil
183  -- handler for category and attribute queries
184  type :=
185    isLocalVar(type) => ['unabbrev, type]
186    MKQ unabbrev type
187  catCode :=
188    prop := unabbrev SUBST('$, '%, prop)
189    prop is [":", :.] => MKQ prop
190    ['evaluateType, MKQ prop]
191  code:=['newHasTest,['evaluateType, type], catCode]
192  if $genValue then code := wrap timedEVALFUN code
193  putValue(op,objNew(code,$Boolean))
194  putModeSet(op,[$Boolean])
195
196--% Handlers for IF
197
198upIF t ==
199  t isnt [op,cond,a,b] => nil
200  bottomUpPredicate(cond,'"if/when")
201  $genValue => interpIF(op,cond,a,b)
202  compileIF(op,cond,a,b,t)
203
204compileIF(op,cond,a,b,t) ==
205  -- type analyzer for compiled case where types of both branches of
206  --  IF are resolved.
207  ms1 := bottomUp a
208  [m1] := ms1
209  b = 'noBranch =>
210    evalIF(op,rest t,$Void)
211    putModeSet(op,[$Void])
212  b = 'noMapVal =>
213    -- if this was a return statement, we take the mode to be that
214    -- of what is being returned.
215    if getUnname a = "return" then
216      ms1 := bottomUp CADR a
217      [m1] := ms1
218    evalIF(op,rest t,m1)
219    putModeSet(op,ms1)
220  ms2 := bottomUp b
221  [m2] := ms2
222  m:=
223    m2=m1 => m1
224    m2 = $Exit => m1
225    m1 = $Exit => m2
226    if EQCAR(m1,'Symbol) then
227      m1:=getMinimalVarMode(getUnname a,$declaredMode)
228    if EQCAR(m2,'Symbol) then
229      m2:=getMinimalVarMode(getUnname b,$declaredMode)
230    (r := resolveTTAny(m2,m1)) => r
231    rempropI($mapName,'localModemap)
232    rempropI($mapName,'localVars)
233    rempropI($mapName,'mapBody)
234    throwKeyedMsg("S2IS0026",[m2,m1])
235  evalIF(op,rest t,m)
236  putModeSet(op,[m])
237
238evalIF(op,[cond,a,b],m) ==
239  -- generate code form compiled IF
240  elseCode:=
241    b='noMapVal =>
242      [[MKQ true, ['throwKeyedMsg,MKQ "S2IM0018",
243        ['CONS,MKQ object2Identifier $mapName,NIL]]]]
244    b = 'noBranch => [[MKQ true, ['voidValue]]]
245    [[MKQ true,genIFvalCode(b,m)]]
246  code:=['COND,[getArgValue(cond,$Boolean),
247    genIFvalCode(a,m)],:elseCode]
248  triple:= objNew(code,m)
249  putValue(op,triple)
250
251genIFvalCode(t,m) ==
252  -- passes type information down braches of IF statement
253  --  So that coercions can be performed on data at branches of IF.
254  m1 := computedMode t
255  m1=m => getArgValue(t,m)
256  code:=objVal getValue t
257  IFcodeTran(code,m,m1)
258
259IFcodeTran(code,m,m1) ==
260  -- coerces values at branches of IF
261  null code => code
262  code is ['spadThrowBrightly,:.] => code
263  m1 = $Exit => code
264  code isnt ['COND,[p1,a1],[''T,a2]] =>
265    m = $Void => code
266    code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) =>
267      wrapped2Quote objVal code'
268    throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m)
269  a1:=IFcodeTran(a1,m,m1)
270  a2:=IFcodeTran(a2,m,m1)
271  ['COND,[p1,a1],[''T,a2]]
272
273interpIF(op,cond,a,b) ==
274  -- non-compiled version of IF type analyzer.  Doesn't resolve across
275  --  branches of the IF.
276  val:= getValue cond
277  val:= coerceInteractive(val,$Boolean) =>
278    objValUnwrap(val) => upIFgenValue(op,a)
279    EQ(b,'noBranch) =>
280      putValue(op,objNew(voidValue(), $Void))
281      putModeSet(op,[$Void])
282    upIFgenValue(op,b)
283  throwKeyedMsg("S2IS0031",NIL)
284
285upIFgenValue(op,tree) ==
286  -- evaluates tree and transfers the results to op
287  ms:=bottomUp tree
288  val:= getValue tree
289  putValue(op,val)
290  putModeSet(op,ms)
291
292--% Handlers for is
293
294upis t ==
295  t isnt [op,a,pattern] => nil
296  $opIsIs : local := true
297  upisAndIsnt t
298
299upisnt t ==
300  t isnt [op,a,pattern] => nil
301  $opIsIs : local := nil
302  upisAndIsnt t
303
304upisAndIsnt(t:=[op,a,pattern]) ==
305  -- handler for "is" pattern matching
306  mS:= bottomUp a
307  mS isnt [m] =>
308    keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"])
309  putPvarModes(removeConstruct pattern,m)
310  evalis(op,rest t,m)
311  putModeSet(op,[$Boolean])
312
313putPvarModes(pattern,m) ==
314  -- Puts the modes for the pattern variables into $env
315  m isnt ['List,um] => throwKeyedMsg("S2IS0030",NIL)
316  for pvar in pattern repeat
317      IDENTP pvar => put(pvar, 'mode, um, $env)
318      pvar is ['_:, var] => put(var, 'mode, m, $env)
319      pvar is ['_=, var] => put(var, 'mode, um, $env)
320      putPvarModes(pvar, um)
321
322evalis(op,[a,pattern],mode) ==
323  -- actually handles is and isnt
324  if $opIsIs
325    then fun := 'evalIsPredicate
326    else fun := 'evalIsntPredicate
327  if isLocalPred pattern then
328    code:= compileIs(a,pattern)
329  else code:=[fun,getArgValue(a,mode),
330    MKQ pattern,MKQ mode]
331  triple:=
332    $genValue => objNewWrap(timedEVALFUN code,$Boolean)
333    objNew(code,$Boolean)
334  putValue(op,triple)
335
336isLocalPred pattern ==
337  -- returns true if the is predicate is to be compiled
338  for pat in pattern repeat
339    IDENTP pat and isLocalVar(pat) => return true
340    pat is ['_:,var] and isLocalVar(var) => return true
341    pat is ['_=,var] and isLocalVar(var) => return true
342
343compileIs(val,pattern) ==
344  -- produce code for compiled "is" predicate.  makes pattern variables
345  --  into local variables of the function
346  vars:= NIL
347  for pat in rest pattern repeat
348    IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars]
349    pat is ['_:,var] => vars:= [var,:vars]
350    pat is ['_=,var] => vars:= [var,:vars]
351  predCode:=['LET,g:=GENSYM(),['isPatternMatch,
352    getArgValue(val,computedMode val),MKQ removeConstruct pattern]]
353  for var in REMDUP vars repeat
354    assignCode:=[['LET,var,['CDR,['ASSQ,MKQ var,g]]],:assignCode]
355  null $opIsIs =>
356    ['COND,[['EQ,predCode,MKQ 'failed],['SEQ,:assignCode,MKQ 'T]]]
357  ['COND,[['NOT,['EQ,predCode,MKQ 'failed]],['SEQ,:assignCode,MKQ 'T]]]
358
359evalIsPredicate(value,pattern,mode) ==
360  --This function pattern matches value to pattern, and returns
361  --true if it matches, and false otherwise.  As a side effect
362  --if the pattern matches then the bindings given in the pattern
363  --are made
364  pattern:= removeConstruct pattern
365  not ((valueAlist:=isPatternMatch(value,pattern))='failed) =>
366    for [id,:value] in valueAlist repeat
367      evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env)))
368    true
369  false
370
371evalIsntPredicate(value,pattern,mode) ==
372  evalIsPredicate(value,pattern,mode) => NIL
373  'TRUE
374
375removeConstruct pat ==
376  -- removes the "construct" from the beginning of patterns
377  if pat is ['construct,:p] then pat:=p
378  if pat is ['cons, a, b] then pat := [a, ['_:, b]]
379  atom pat => pat
380  RPLACA(pat, removeConstruct first pat)
381  RPLACD(pat, removeConstruct rest pat)
382  pat
383
384isPatternMatch(l,pats) ==
385  -- perform the actual pattern match
386  $subs: local := NIL
387  isPatMatch(l,pats)
388  $subs
389
390isPatMatch(l,pats) ==
391  null pats =>
392    null l => $subs
393    $subs:='failed
394  null l =>
395    null pats => $subs
396    pats is [['_:,var]] =>
397      $subs := [[var],:$subs]
398    $subs:='failed
399  pats is [pat,:restPats] =>
400    IDENTP pat =>
401      $subs:=[[pat,:first l],:$subs]
402      isPatMatch(rest l,restPats)
403    pat is ['_=,var] =>
404      p:=ASSQ(var,$subs) =>
405        first l = rest p => isPatMatch(rest l, restPats)
406        $subs:='failed
407      $subs:='failed
408    pat is ['_:,var] =>
409      n:=#restPats
410      m:=#l-n
411      m<0 => $subs:='failed
412      ZEROP n => $subs:=[[var,:l],:$subs]
413      $subs:=[[var,:[x for x in l for i in 1..m]],:$subs]
414      isPatMatch(DROP(m,l),restPats)
415    isPatMatch(first l,pat) = 'failed => 'failed
416    isPatMatch(rest l,restPats)
417  keyedSystemError("S2GE0016",['"isPatMatch",
418     '"unknown form of is predicate"])
419
420--% Handler for iterate
421
422upiterate t ==
423  null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"])
424  $iterateCount := $iterateCount + 1
425  code := ['THROW,$repeatBodyLabel,'(voidValue)]
426  $genValue => THROW(eval $repeatBodyLabel,voidValue())
427  putValue(t,objNew(code,$Void))
428  putModeSet(t,[$Void])
429
430--% Handler for break
431
432upbreak t ==
433  t isnt [op,.] => nil
434  null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"])
435  $breakCount := $breakCount + 1
436  code := ['THROW,$repeatLabel,'(voidValue)]
437  $genValue => THROW(eval $repeatLabel,voidValue())
438  putValue(op,objNew(code,$Void))
439  putModeSet(op,[$Void])
440
441--% Handlers for LET
442
443upLET t ==
444  -- analyzes and evaluates the righthand side, and does the variable
445  -- binding
446  t isnt [op,lhs,rhs] => nil
447  $declaredMode: local := NIL
448  PAIRP lhs =>
449    var:= getUnname first lhs
450    var = 'construct => upLETWithPatternOnLhs t
451    var = 'QUOTE => throwKeyedMsg("S2IS0027",['"A quoted form"])
452    upLETWithFormOnLhs(op,lhs,rhs)
453  var:= getUnname lhs
454  var = $immediateDataSymbol =>
455    -- following will be immediate data, so probably ok to not
456    -- specially format it
457    obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm)
458    throwKeyedMsg("S2IS0027",[obj])
459  var in '(% %%) =>               -- for history
460    throwKeyedMsg("S2IS0027",[var])
461  (IDENTP var) and not (var in '(true false elt QUOTE)) =>
462    var ~= (var' := unabbrev(var)) =>  -- constructor abbreviation
463      throwKeyedMsg("S2IS0028",[var,var'])
464    if get(var,'isInterpreterFunction,$e) then
465      putHist(var,'isInterpreterFunction,false,$e)
466      sayKeyedMsg("S2IS0049",['"Function",var])
467    else if get(var,'isInterpreterRule,$e) then
468      putHist(var,'isInterpreterRule,false,$e)
469      sayKeyedMsg("S2IS0049",['"Rule",var])
470    not isTupleForm(rhs) and (m := isType rhs) => upLETtype(op,lhs,m)
471    transferPropsToNode(var,lhs)
472    if ( m:= getMode(lhs) ) then
473      $declaredMode := m
474      putTarget(rhs,m)
475    if (val := getValue lhs) and (objMode val = $Boolean) and
476      getUnname(rhs) = 'equation then putTarget(rhs,$Boolean)
477    (rhsMs:= bottomUp rhs) = [$Void] =>
478      throwKeyedMsg("S2IS0034",[var])
479    val:=evalLET(lhs,rhs)
480    putValue(op,val)
481    putModeSet(op,[objMode(val)])
482  throwKeyedMsg("S2IS0027",[var])
483
484isTupleForm f ==
485    -- have to do following since "Tuple" is an internal form name
486    getUnname f ~= "Tuple" => false
487    f is [op,:args] and VECP(op) and getUnname(op) = "Tuple" =>
488        #args ~= 1 => true
489        isTupleForm first args => true
490        isType first args => false
491        true
492    false
493
494evalLET(lhs,rhs) ==
495  -- lhs is a vector for a variable, and rhs is the evaluated atree
496  --  for the value which is coerced to the mode of lhs
497  $useConvertForCoercions: local := true
498  v' := (v:= getValue rhs)
499  ((not getMode lhs) and (getModeSet rhs is [.])) or
500    get(getUnname lhs,'autoDeclare,$env) =>
501      v:=
502        $genValue => v
503        objNew(wrapped2Quote objVal v,objMode v)
504      evalLETput(lhs,v)
505  t1:= objMode v
506  t2' := (t2 := getMode lhs)
507  value:=
508    t1 = t2 =>
509      $genValue => v
510      objNew(wrapped2Quote objVal v,objMode v)
511    if isPartialMode t2 then
512      if EQCAR(t1,'Symbol) and $declaredMode then
513        t1:= getMinimalVarMode(objValUnwrap v,$declaredMode)
514      t' := t2
515      null (t2 := resolveTM(t1,t2)) =>
516        if not t2 then t2 := t'
517        throwKeyedMsg("S2IS0035",[t1,t2])
518    null (v := getArgValue(rhs,t2)) =>
519      isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) =>
520        throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2])
521      throwKeyedMsg("S2IS0037",[t2])
522    t2 and objNew(($genValue => wrap timedEVALFUN v ; v),t2)
523  value => evalLETput(lhs,value)
524  throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs)
525
526evalLETput(lhs,value) ==
527  -- put value into the cell for lhs
528  name:= getUnname lhs
529  if not $genValue then
530    code:=
531      isLocalVar(name) =>
532        om := objMode(value)
533        dm := get(name,'mode,$env)
534        dm and not ((om = dm) or isSubDomain(om,dm) or
535          isSubDomain(dm,om)) =>
536            compFailure ['"   The type of the local variable",
537              :bright name,'"has changed in the computation."]
538        if dm and isSubDomain(dm,om) then put(name,'mode,om,$env)
539        ['LET,name,objVal value,$mapName]
540               -- $mapName is set in analyzeMap
541      om := objMode value
542      dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e))
543      dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) =>
544        THROW('loopCompiler,'tryInterpOnly)
545      ['unwrap,['evalLETchangeValue,MKQ name,
546        objNewCode(['wrap,objVal value],objMode value)]]
547    value:= objNew(code,objMode value)
548    isLocalVar(name) =>
549      if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env)
550      put(name,'mode,objMode(value),$env)
551    put(name,'automode,objMode(value),$env)
552  $genValue and evalLETchangeValue(name,value)
553  putValue(lhs,value)
554
555upLETWithPatternOnLhs(t := [op,pattern,a]) ==
556  $opIsIs : local := true
557  [m] := bottomUp a
558  putPvarModes(pattern,m)
559  object := evalis(op,[a,pattern],m)
560  -- have to change code to return value of a
561  failCode :=
562    ['spadThrowBrightly,['concat,
563      '"   Pattern",['QUOTE,bright form2String pattern],
564        '"is not matched in assignment to right-hand side."]]
565  if $genValue
566    then
567      null objValUnwrap object => eval failCode
568      putValue(op,getValue a)
569    else
570      code := ['COND,[objVal object,objVal getValue a],[''T,failCode]]
571      putValue(op,objNew(code,m))
572  putModeSet(op,[m])
573
574evalLETchangeValue(name,value) ==
575  -- write the value of name into the environment, clearing dependent
576  --  maps if its type changes from its last value
577  localEnv := PAIRP $env
578  clearCompilationsFlag :=
579    val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e)
580    null val =>
581      not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e))
582    objMode val ~= objMode(value)
583  if clearCompilationsFlag then
584    clearDependencies(name)
585  if localEnv and isLocalVar(name)
586    then $env:= putHist(name,'value,value,$env)
587    else putIntSymTab(name,'value,value,$e)
588  objVal value
589
590upLETWithFormOnLhs(op,lhs,rhs) ==
591  -- bottomUp for assignment to forms (setelt, table or tuple)
592  lhs' := getUnnameIfCan lhs
593  rhs' := getUnnameIfCan rhs
594  lhs' = 'Tuple =>
595    rhs' ~= 'Tuple => throwKeyedMsg("S2IS0039",NIL)
596    #(lhs) ~= #(rhs) => throwKeyedMsg("S2IS0038",NIL)
597    -- generate a sequence of assignments, using local variables
598    -- to first hold the assignments so that things like
599    -- (t1,t2) := (t2,t1) will work.
600    seq := []
601    temps := [GENSYM() for l in rest lhs]
602    for lvar in temps repeat mkLocalVar($mapName,lvar)
603    for l in reverse rest lhs for t in temps repeat
604      transferPropsToNode(getUnname l,l)
605      let := mkAtreeNode 'LET
606      t'  := mkAtreeNode t
607      if m := getMode(l) then putMode(t',m)
608      seq := cons([let,l,t'],seq)
609    for t in temps for r in reverse rest rhs
610      for l in reverse rest lhs repeat
611        let := mkAtreeNode 'LET
612        t'  := mkAtreeNode t
613        if m := getMode(l) then putMode(t',m)
614        seq := cons([let,t',r],seq)
615    seq := cons(mkAtreeNode 'SEQ,seq)
616    ms := bottomUp seq
617    putValue(op,getValue seq)
618    putModeSet(op,ms)
619  rhs' = 'Tuple => throwKeyedMsg("S2IS0039",NIL)
620  tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree)
621  throwKeyedMsg("S2IS0060", NIL)
622--  upTableSetelt(op,lhs,rhs)
623
624get_opname_if_can(f) ==
625    VECP(f) => f.0
626    nil
627
628seteltable(lhs is [f,:argl],rhs) ==
629  -- produces the setelt form for trees such as "l.2:= 3"
630  g := get_opname_if_can f
631  EQ(g,'elt) => altSeteltable [:argl, rhs]
632  altSeteltable [:lhs,rhs]
633
634altSeteltable args ==
635    for x in args repeat bottomUp x
636    newOps := [mkAtreeNode "setelt!", mkAtreeNode "set!"]
637    form := NIL
638
639    -- first look for exact matches for any of the possibilities
640    while not form for newOp in newOps  repeat
641        if selectMms(newOp, args, NIL) then form := [newOp, :args]
642
643    -- now try retracting arguments after the first
644    while not form and ( "and"/[retractAtree(a) for a in rest args] ) repeat
645        while not form for newOp in newOps  repeat
646            if selectMms(newOp, args, NIL) then form := [newOp, :args]
647
648    form
649
650
651upSetelt(op,lhs,tree) ==
652  -- type analyzes implicit setelt forms
653  var:=opOf lhs
654  transferPropsToNode(getUnname var,var)
655  if (m1:=getMode var) then $declaredMode:= m1
656  if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then
657    putModeSet(var,[m1])
658  ms := bottomUp tree
659  putValue(op,getValue tree)
660  putModeSet(op,ms)
661
662upTableSetelt(op,lhs is [htOp,:args],rhs) ==
663  -- called only for undeclared, uninitialized table setelts
664  ("*" = (PNAME getUnname htOp).0) and (1 ~= # args) =>
665    throwKeyedMsg("S2IS0040",NIL)
666  # args ~= 1 =>
667    throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[",
668      getUnname first args,
669        ['",",getUnname arg for arg in rest args],'"]"]])
670  keyMode := '(Any)
671  putMode (htOp,['Table,keyMode,'(Any)])
672  -- if we are to use a new table, we must call the "table"
673  -- function to give it an initial value.
674  bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]]
675  tableCode := objVal getValue htOp
676  r := upSetelt(op, lhs, [mkAtreeNode "setelt!", :lhs, rhs])
677  $genValue => r
678  -- construct code
679  t := getValue op
680  putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t))
681  r
682
683isType t ==
684  -- Returns the evaluated type if t is a tree representing a type,
685  -- and NIL otherwise
686   op:=opOf t
687   VECP op =>
688     isMap(op:= getUnname op) => NIL
689     op = 'Mapping =>
690       argTypes := [isType type for type in rest t]
691       "or"/[null type for type in argTypes] => nil
692       ['Mapping, :argTypes]
693     isLocalVar(op) => NIL
694     d := isDomainValuedVariable op => d
695     type:=
696       -- next line handles subscripted vars
697         (abbreviation?(op) or (op = 'typeOf) or
698           constructor?(op) or (op in '(Record Union Enumeration))) and
699             unabbrev unVectorize t
700     type and evaluateType type
701   d := isDomainValuedVariable op => d
702   NIL
703
704upLETtype(op,lhs,type) ==
705  -- performs type assignment
706  opName:= getUnname lhs
707  (not $genValue) and or/[CONTAINED(var,type) for var in $localVars] =>
708    compFailure ['"   Cannot compile type assignment to",:bright opName]
709  mode :=
710    if isPartialMode type then '(Mode)
711    else if categoryForm?(type) then '(Category)
712         else '(Type)
713  val:= objNew(type,mode)
714  if isLocalVar(opName) then put(opName,'value,val,$env)
715  else putHist(opName,'value,val,$e)
716  putValue(op,val)
717  -- have to fix the following
718  putModeSet(op,[mode])
719
720assignSymbol(symbol, value, domain) ==
721-- Special function for binding an interpreter variable from within algebra
722-- code.  Does not do the assignment and returns nil, if the variable is
723-- already assigned
724  val := get(symbol, 'value, $e) => nil
725  obj := objNew(wrap value, devaluate domain)
726  put(symbol, 'value, obj, $e)
727  true
728
729--% Handler for Interpreter Macros
730
731getInterpMacroNames() ==
732  names := [n for [n,:.] in $InterpreterMacroAlist]
733  if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then
734    names := append(names, [n for [n, :.] in rest m])
735  MSORT names
736
737isInterpMacro name ==
738  -- look in local and then global environment for a macro
739  null IDENTP name => NIL
740  name in $specialOps => NIL
741  (m := get("--macros--",name,$env)) => m
742  (m := get("--macros--",name,$e))   => m
743  (m := get("--macros--",name,$InteractiveFrame))   => m
744  -- $InterpreterMacroAlist will probably be phased out soon
745  (sv := assoc(name, $InterpreterMacroAlist)) => CONS(NIL, rest sv)
746  NIL
747
748--% Handlers for prefix QUOTE
749
750upQUOTE t ==
751  t isnt [op,expr] => NIL
752  ms:= list
753    m:= getBasicMode expr => m
754    IDENTP expr =>
755--    $useSymbolNotVariable => $Symbol
756      ['Variable,expr]
757    $OutputForm
758  evalQUOTE(op,[expr],ms)
759  putModeSet(op,ms)
760
761evalQUOTE(op,[expr],[m]) ==
762  triple:=
763    $genValue => objNewWrap(expr,m)
764    objNew(['QUOTE,expr],m)
765  putValue(op,triple)
766
767--% Handler for pretend
768
769uppretend t ==
770  t isnt [op,expr,type] => NIL
771  mode := evaluateType unabbrev type
772  not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode])
773  bottomUp expr
774  putValue(op,objNew(objVal getValue expr,mode))
775  putModeSet(op,[mode])
776
777--% Handlers for REDUCE
778
779getReduceFunction(op,type,result, locale) ==
780  -- return the function cell for operation with the signature
781  --  (type,type) -> type, possible from locale
782  if type is ['Variable,var] then
783    args := [arg := mkAtreeNode var,arg]
784    putValue(arg,objNewWrap(var,type))
785  else
786    args := [arg := mkAtreeNode "%1",arg]
787    if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol))
788  putModeSet(arg,[type])
789  vecOp:=mkAtreeNode op
790  transferPropsToNode(op,vecOp)
791  if locale then putAtree(vecOp,'dollar,locale)
792  mmS:= selectMms(vecOp,args,result)
793  mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS |
794    (isHomogeneousArgs sig) and and/[null c for c in cond]]
795  null mm => 'failed
796  [[dc,:sig],fun,:.]:=mm
797  dc = 'local => [MKQ [fun, :'local], :first sig]
798  dcVector := evalDomain dc
799  $compilingMap =>
800    k := NRTgetMinivectorIndex(
801      NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector)
802    ['ELT,"$$$",k]  --$$$ denotes minivector
803  env:=
804    NRTcompiledLookup(op,sig,dcVector)
805  MKQ env
806
807isHomogeneous sig ==
808  --return true if sig describes a homogeneous binary operation
809  sig.0=sig.1 and sig.1=sig.2
810
811isHomogeneousArgs sig ==
812  --return true if sig describes a homogeneous binary operation
813  sig.1=sig.2
814
815--% Handlers for REPEAT
816
817transformREPEAT [:itrl,body] ==
818  -- syntactic transformation of repeat iterators, called from mkAtree2
819  iterList:=[:iterTran1 for it in itrl] where iterTran1 ==
820    it is ['STEP,index,lower,step,:upperList] =>
821      [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
822        for upper in upperList]]]
823    it is ['IN,index,s] =>
824      [['IN,index,mkAtree1 s]]
825    it is ['ON,index,s] =>
826      [['IN,index,mkAtree1 ['tails,s]]]
827    it is ['WHILE,b] =>
828      [['WHILE,mkAtree1 b]]
829    it is ['_|,pred] =>
830      [['SUCHTHAT,mkAtree1 pred]]
831    it is [op,:.] and (op in '(VALUE UNTIL)) => nil
832  bodyTree:=mkAtree1 body
833  iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2 ==
834    it is ['STEP,:.] => nil
835    it is ['IN,:.] => nil
836    it is ['ON,:.] => nil
837    it is ['WHILE,:.] => nil
838    it is [op,b] and (op in '(UNTIL VALUE)) =>
839      [[op,mkAtree1 b]]
840    it is ['_|,pred] => nil
841    keyedSystemError("S2GE0016",
842      ['"transformREPEAT",'"Unknown type of iterator"])
843  [:iterList,bodyTree]
844
845upREPEAT t ==
846  -- REPEATS always return void() of Void
847  -- assures throw to interpret-code mode goes to outermost loop
848  $repeatLabel : local := MKQ GENSYM()
849  $breakCount  : local := 0
850  $repeatBodyLabel : local := MKQ GENSYM()
851  $iterateCount    : local := 0
852  $compilingLoop => upREPEAT1 t
853  upREPEAT0 t
854
855upREPEAT0 t ==
856  -- sets up catch point for interp-only mode
857  $compilingLoop: local := true
858  ms := CATCH('loopCompiler,upREPEAT1 t)
859  ms = 'tryInterpOnly => interpOnlyREPEAT t
860  ms
861
862upREPEAT1 t ==
863  -- repeat loop handler with compiled body
864  -- see if it has the expected form
865  t isnt [op,:itrl,body] => NIL
866  -- determine the mode of the repeat loop. At the moment, if there
867  -- there are no iterators and there are no "break" statements, then
868  -- the return type is Exit, otherwise Void.
869  repeatMode :=
870    null(itrl) and ($breakCount=0) => $Void
871    $Void
872
873  -- if interpreting, go do that
874  $interpOnly => interpREPEAT(op,itrl,body,repeatMode)
875
876  -- analyze iterators and loop body
877  upLoopIters itrl
878  bottomUpCompile body
879
880  -- now that the body is analyzed, we should know everything that
881  -- is in the UNTIL clause
882  for itr in itrl repeat
883    itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until")
884
885  -- now go do it
886  evalREPEAT(op,rest t,repeatMode)
887  putModeSet(op,[repeatMode])
888
889evalREPEAT(op,[:itrl,body],repeatMode) ==
890  -- generate code for loop
891  bodyMode := computedMode body
892  bodyCode := getArgValue(body,bodyMode)
893  if $iterateCount > 0 then
894    bodyCode := ['CATCH,$repeatBodyLabel,bodyCode]
895  code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode]
896  if repeatMode = $Void then code := ['OR,code,'(voidValue)]
897  code := timedOptimization code
898  if $breakCount > 0 then code := ['CATCH,$repeatLabel,code]
899  val:=
900    $genValue =>
901      timedEVALFUN code
902      objNewWrap(voidValue(),repeatMode)
903    objNew(code,repeatMode)
904  putValue(op,val)
905
906interpOnlyREPEAT t ==
907  -- interpret-code mode call to upREPEAT
908  $genValue: local := true
909  $interpOnly: local := true
910  upREPEAT1 t
911
912interpREPEAT(op,itrl,body,repeatMode) ==
913  -- performs interpret-code repeat
914  $indexVars: local := NIL
915  $indexTypes: local := NIL
916  code :=
917      -- we must insert a CATCH for the iterate clause
918      ['REPEAT,:[interpIter itr for itr in itrl],
919        ['CATCH,$repeatBodyLabel,interpLoop(body,$indexVars,
920          $indexTypes,nil)]]
921  CATCH($repeatLabel,timedEVALFUN code)
922  val:= objNewWrap(voidValue(),repeatMode)
923  putValue(op,val)
924  putModeSet(op,[repeatMode])
925
926interpLoop(expr,indexList,indexTypes,requiredType) ==
927  -- generates code for interp-only repeat body
928  ['interpLoopIter,MKQ expr,MKQ indexList,['LIST,:indexList],
929    MKQ indexTypes, MKQ requiredType]
930
931interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) ==
932  -- call interpreter on exp with loop vars in indexList with given
933  --  values and types, requiredType is used from interpCOLLECT
934  --  to indicate the required type of the result
935  emptyAtree exp
936  for i in indexList for val in indexVals for type in indexTypes repeat
937    put(i,'value,objNewWrap(val,type),$env)
938  bottomUp exp
939  v:= getValue exp
940  val :=
941    null requiredType => v
942    coerceInteractive(v,requiredType)
943  null val =>
944    throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType)
945  objValUnwrap val
946
947--% Handler for return
948
949upreturn t ==
950  -- make sure we are in a user function
951  t isnt [op,val] => NIL
952  (null $compilingMap) and (null $interpOnly) =>
953    throwKeyedMsg("S2IS0047",NIL)
954  if $mapTarget then putTarget(val,$mapTarget)
955  bottomUp val
956  if $mapTarget
957    then
958      val' := getArgValue(val, $mapTarget)
959      m := $mapTarget
960    else
961      val' := wrapped2Quote objVal getValue val
962      m := computedMode val
963  cn := mapCatchName $mapName
964  $mapReturnTypes := insert(m, $mapReturnTypes)
965  $mapThrowCount := $mapThrowCount + 1
966  -- if $genValue then we are interpreting the map
967  $genValue => THROW(cn,objNewWrap(removeQuote val',m))
968  putValue(op,objNew(['THROW,MKQ cn,val'],m))
969  putModeSet(op,[$Exit])
970
971--% Handler for SEQ
972
973upSEQ u ==
974  -- assumes that exits were translated into if-then-elses
975  -- handles flat SEQs and embedded returns
976  u isnt [op,:args] => NIL
977  if (target := getTarget(op)) then putTarget(last args, target)
978  for x in args repeat bottomUp x
979  null (m := computedMode last args) =>
980    keyedSystemError("S2GE0016",['"upSEQ",
981      '"last line of SEQ has no mode"])
982  evalSEQ(op,args,m)
983  putModeSet(op,[m])
984
985evalSEQ(op,args,m) ==
986  -- generate code for SEQ
987  [:argl,last] := args
988  val:=
989    $genValue => getValue last
990    bodyCode := nil
991    for x in args repeat
992      (m1 := computedMode x) =>
993        (av := getArgValue(x,m1)) ~= voidValue() =>
994          bodyCode := [av,:bodyCode]
995    code:=
996      bodyCode is [c] => c
997      ['PROGN,:reverse bodyCode]
998    objNew(code,m)
999  putValue(op,val)
1000
1001--% Handlers for Tuple
1002
1003upTuple t ==
1004  --Computes the common mode set of the construct by resolving across
1005  --the argument list, and evaluating
1006  t isnt [op,:l] => nil
1007  dol := getAtree(op,'dollar)
1008  tar := getTarget(op) or dol
1009  null l => upNullTuple(op,l,tar)
1010  isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar)
1011  aggs := '(List)
1012  if tar and PAIRP(tar) and not isPartialMode(tar) then
1013    first(tar) in aggs =>
1014      ud := CADR tar
1015      for x in l repeat if not getTarget(x) then putTarget(x,ud)
1016    first(tar) in '(Matrix SquareMatrix RectangularMatrix) =>
1017      vec := ['List,underDomainOf tar]
1018      for x in l repeat if not getTarget(x) then putTarget(x,vec)
1019  argModeSetList:= [bottomUp x for x in l]
1020  eltTypes := replaceSymbols([first x for x in argModeSetList],l)
1021  if not isPartialMode(tar) and tar is ['Tuple,ud] then
1022    mode := ['Tuple, resolveTypeListAny cons(ud,eltTypes)]
1023  else mode := ['Tuple, resolveTypeListAny eltTypes]
1024  if isPartialMode tar then tar:=resolveTM(mode,tar)
1025  evalTuple(op,l,mode,tar)
1026
1027evalTuple(op,l,m,tar) ==
1028  [agg,:.,underMode]:= m
1029  code := asTupleNewCode(#l,
1030    [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l])
1031  val :=
1032    $genValue => objNewWrap(timedEVALFUN code,m)
1033    objNew(code,m)
1034  if tar then val1 := coerceInteractive(val,tar) else val1 := val
1035
1036  val1 =>
1037    putValue(op,val1)
1038    putModeSet(op,[tar or m])
1039  putValue(op,val)
1040  putModeSet(op,[m])
1041
1042upNullTuple(op,l,tar) ==
1043  -- handler for the empty tuple
1044  defMode :=
1045    tar and tar is [a,b] and (a in '(Stream Vector List)) and
1046      not isPartialMode(b) => ['Tuple,b]
1047    '(Tuple (None))
1048  val := objNewWrap(asTupleNew(0,NIL), defMode)
1049  tar and not isPartialMode(tar) =>
1050    null (val' := coerceInteractive(val,tar)) =>
1051      throwKeyedMsg("S2IS0013",[tar])
1052    putValue(op,val')
1053    putModeSet(op,[tar])
1054  putValue(op,val)
1055  putModeSet(op,[defMode])
1056
1057--% Handler for typeOf
1058
1059uptypeOf form ==
1060  form isnt [op, arg] => NIL
1061  if VECP arg then transferPropsToNode(getUnname arg,arg)
1062  if m := isType(arg) then
1063    m :=
1064      categoryForm?(m) => '(Category)
1065      isPartialMode m  => '(Mode)
1066      '(Type)
1067  else if not (m := getMode arg) then [m] := bottomUp arg
1068  t := typeOfType m
1069  putValue(op, objNew(m,t))
1070  putModeSet(op,[t])
1071
1072typeOfType type ==
1073  type in '((Mode) (Type)) => '(Category)
1074  '(Type)
1075
1076--% Handler for where
1077
1078upwhere t ==
1079  -- upwhere does the puts in where into a local environment
1080  t isnt [op,tree,clause] => NIL
1081  -- since the "clause" might be a local macro, we now call mkAtree
1082  -- on the "tree" part (it is not yet a vat)
1083  not $genValue =>
1084    compFailure [:bright '"  where",
1085      '"for compiled code is not yet implemented."]
1086  $whereCacheList : local := nil
1087  [env,:e] := upwhereClause(clause,$env,$e)
1088  tree := upwhereMkAtree(tree,env,e)
1089  if x := getAtree(op,'dollar) then
1090    atom tree => throwKeyedMsg("S2IS0048",NIL)
1091    putAtree(first tree, 'dollar, x)
1092  upwhereMain(tree,env,e)
1093  val := getValue tree
1094  putValue(op,val)
1095  result := putModeSet(op,getModeSet tree)
1096  wcl := [op for op in $whereCacheList]
1097  for op in wcl repeat clearDependencies(op)
1098  result
1099
1100upwhereClause(tree,env,e) ==
1101  -- uses the variable bindings from env and e and returns an environment
1102  -- of its own bindings
1103  $env: local := copyHack env
1104  $e: local := copyHack e
1105  bottomUp tree
1106  [$env,:$e]
1107
1108upwhereMkAtree(tree,$env,$e) == mkAtree tree
1109
1110upwhereMain(tree,$env,$e) ==
1111  -- uses local copies of $env and $e while evaluating tree
1112  bottomUp tree
1113
1114copyHack(env) ==
1115  -- makes a copy of an environment with the exception of pairs
1116  -- (localModemap . something)
1117  c:= CAAR env
1118  d:= [fn p for p in c] where fn(p) ==
1119    CONS(first p, [(EQCAR(q, 'localModemap) => q; copy q) for q in rest p])
1120  [[d]]
1121
1122-- Creates the function names of the special function handlers and puts
1123--  them on the property list of the function name
1124
1125
1126for name in $specialOps repeat
1127    (
1128      functionName := INTERNL1('up, name) ;
1129      MAKEPROP(name,'up,functionName) ;
1130      functionName
1131     )
1132