aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2011-02-27 17:27:35 +0000
committerdos-reis <gdr@axiomatics.org>2011-02-27 17:27:35 +0000
commitcdf162160d3055657578dcc09bec96411bbff793 (patch)
tree07807665c20638e7b244a2083b6f91fe9fcc5c6d /src/interp
parentb38be75faf9e735aaa0baae8ff0118c897128656 (diff)
downloadopen-axiom-cdf162160d3055657578dcc09bec96411bbff793.tar.gz
* interp/Makefile.in (OBJS): Remove i-spec1.$(FASLEXT) and
i-spec2.$(FASLEXT). Add i-special.$(FASLEXT). * interp/i-spec1.boot, interp/i-spec2.boot: Move content to i-special.boot. Remove.
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/Makefile.in7
-rw-r--r--src/interp/i-spec2.boot1228
-rw-r--r--src/interp/i-special.boot (renamed from src/interp/i-spec1.boot)1196
3 files changed, 1198 insertions, 1233 deletions
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 94a6fe83..00a0a2ad 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -94,8 +94,8 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
i-funsel.$(FASLEXT) \
i-intern.$(FASLEXT) i-map.$(FASLEXT) \
i-output.$(FASLEXT) \
- i-spec1.$(FASLEXT) \
- i-spec2.$(FASLEXT) i-syscmd.$(FASLEXT) \
+ i-special.$(FASLEXT) \
+ i-syscmd.$(FASLEXT) \
i-toplev.$(FASLEXT) i-util.$(FASLEXT) \
incl.$(FASLEXT) int-top.$(FASLEXT) \
intfile.$(FASLEXT) c-util.$(FASLEXT) \
@@ -328,8 +328,7 @@ int-top.$(FASLEXT): incl.$(FASLEXT) i-toplev.$(FASLEXT) unlisp.$(FASLEXT)
i-toplev.$(FASLEXT): i-analy.$(FASLEXT)
i-syscmd.$(FASLEXT): i-object.$(FASLEXT)
i-output.$(FASLEXT): sys-macros.$(FASLEXT)
-i-spec2.$(FASLEXT): i-spec1.$(FASLEXT)
-i-spec1.$(FASLEXT): i-analy.$(FASLEXT)
+i-special.$(FASLEXT): i-analy.$(FASLEXT)
i-funsel.$(FASLEXT): i-coerfn.$(FASLEXT)
i-map.$(FASLEXT): i-object.$(FASLEXT)
i-eval.$(FASLEXT): i-analy.$(FASLEXT)
diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot
deleted file mode 100644
index 9e46ef6b..00000000
--- a/src/interp/i-spec2.boot
+++ /dev/null
@@ -1,1228 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
--- All rights reserved.
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- - Redistributions of source code must retain the above copyright
--- notice, this list of conditions and the following disclaimer.
---
--- - Redistributions in binary form must reproduce the above copyright
--- notice, this list of conditions and the following disclaimer in
--- the documentation and/or other materials provided with the
--- distribution.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
--- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
--- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
--- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
--- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
--- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
--- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
--- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
--- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
--- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
--- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-
-import i_-spec1
-namespace BOOT
-
-++ The `void' value object (an oxymoron). There really are constants.
-$VoidValueObject := objNew(voidValue(), $Void)
-$VoidCodeObject := objNew('(voidValue), $Void)
-
-setValueToVoid t ==
- putValue(t,$VoidValueObject)
- putModeSet(t,[$Void])
-
-setCodeToVoid t ==
- putValue(t,$VoidCodeObject)
- putModeSet(t,[$Void])
-
-++ Interpreter macros
-$InterpreterMacroAlist ==
- '((%i . (complex 0 1))
- (%e . (exp 1))
- (%pi . (pi))
- (SF . (DoubleFloat))
- (%infinity . (infinity))
- (%plusInfinity . (plusInfinity))
- (%minusInfinity . (minusInfinity)))
-
-
--- Functions which require special handlers (also see end of file)
-
---% Handlers for map definitions
-
-upDEF t ==
- -- performs map definitions. value is thrown away
- t isnt [op,def,pred,.] => nil
- v:=addDefMap(["DEF",:def],pred)
- not(LISTP(def)) or null(def) =>
- keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
- mapOp := first def
- if LISTP(mapOp) then
- null mapOp =>
- keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
- mapOp := first mapOp
- put(mapOp,"value",v,$e)
- setValueToVoid op
-
---% Handler for package calling and $ constants
-
-++ Return non-nil if `form' designate a constant defined in the
-++ domain designated by `domainForm'. More specifically, returns:
-++ nil: no such constant
-++ <%Mode>: the type of the constant.
-++ T: too many constants designated by `form'.
-constantInDomain?(form,domainForm) ==
- opAlist := getConstructorOperationsFromDB domainForm.op
- key := opOf form
- entryList := [entry for (entry := [.,.,.,k]) in LASSOC(key,opAlist)
- | k in '(CONST ASCONST)]
- entryList is [[sig,.,.,.]] => sig.target
- #entryList > 2 => true
- key = "One" => constantInDomain?(["1"], domainForm)
- key = "Zero" => constantInDomain?(["0"], domainForm)
- nil
-
-++ Constant `c' of `type' is referenced from domain `d'; return its value
-++ in the VAT `op'.
-findConstantInDomain(op,c,type,d) ==
- isPartialMode d => throwKeyedMsg("S2IS0020",NIL)
- val :=
- $genValue => wrap getConstantFromDomain([c],d)
- ["getConstantFromDomain",["LIST",MKQ c],MKQ d]
- type := substitute(d,"$",type)
- putValue(op,objNew(val,type))
- putModeSet(op,[type])
-
-upDollar t ==
- -- Puts "dollar" property in atree node, and calls bottom up
- t isnt [op,D,form] => nil
- t2 := t
- (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] =>
- keyedMsgCompFailure("S2IS0032",NIL)
- D="Lisp" => upLispCall(op,form)
- if vector? D and (# D > 0) then D := D.0
- t := evaluateType unabbrev D
- categoryForm? t =>
- throwKeyedMsg("S2IE0012", [t])
- f := getUnname form
- if f = $immediateDataSymbol then
- f := objValUnwrap coerceInteractive(getValue form,$OutputForm)
- if f = '(construct) then f := "nil"
- atom form and (f ~= $immediateDataSymbol) =>
- type := constantInDomain?([f],t) =>
- type ~= true => findConstantInDomain(op,f,type,t)
- -- Ambiguous constant. FIXME: try to narrow before giving up.
- throwKeyedMsg("S2IB0008h",[f,t])
- findUniqueOpInDomain(op,f,t)
-
- nargs := #rest form
-
- (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms
-
- f ~= "construct" and null isOpInDomain(f,t,nargs) =>
- throwKeyedMsg("S2IS0023",[f,t])
- if (sig := findCommonSigInDomain(f,t,nargs)) then
- for x in sig for y in form repeat
- if x then putTarget(y,x)
- putAtree(first form,"dollar",t)
- ms := bottomUp form
- f in '(One Zero) and cons? (ms) and first(ms) = $OutputForm =>
- throwKeyedMsg("S2IS0021",[f,t])
- putValue(op,getValue first form)
- putModeSet(op,ms)
-
-
-upDollarTuple(op, f, t, t2, args, nargs) ==
- -- this function tries to find a tuple function to use
- -- nargs = 1 and getUnname first args = "Tuple" => NIL
- -- nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL
- null (singles := isOpInDomain(f,t,1)) => NIL
- tuple := NIL
- for [[.,arg], :.] in singles while null tuple repeat
- if arg is ['Tuple,.] then tuple := arg
- null tuple => NIL
- [.,D,form] := t2
- newArg := [mkAtreeNode "tuple",:args]
- putTarget(newArg, tuple)
- ms := bottomUp newArg
- first ms ~= tuple => NIL
- form := [first form, newArg]
- putAtree(first form,"dollar",t)
- ms := bottomUp form
- putValue(op,getValue first form)
- putModeSet(op,ms)
-
-upLispCall(op,t) ==
- -- process $Lisp calls
- if atom t then code:=getUnname t else
- [lispOp,:argl]:= t
- null functionp lispOp.0 =>
- throwKeyedMsg("S2IS0024",[lispOp.0])
- for arg in argl repeat bottomUp arg
- code:=[getUnname lispOp,
- :[getArgValue(arg,computedMode arg) for arg in argl]]
- rt := '(SExpression)
- putValue(op,object(code,rt))
- putModeSet(op,[rt])
-
---% Handlers for equation
-
-upequation tree ==
- -- only handle this if there is a target of Boolean
- -- this should speed things up a bit
- tree isnt [op,lhs,rhs] => NIL
- $Boolean ~= getTarget(op) => NIL
- not vector? op => NIL
- -- change equation into '='
- op.0 := "="
- bottomUp tree
-
---% Handler for error
-
-uperror t ==
- -- when compiling a function, this merely inserts another argument
- -- which is the name of the function.
- not $compilingMap => NIL
- t isnt [op,msg] => NIL
- msgMs := bottomUp putCallInfo(msg,"error",1,1)
- msgMs isnt [=$String] => NIL
- t.rest := [mkAtree object2String $mapName,msg]
- bottomUp t
-
---% Handlers for free and local
-
-upfree t ==
- setCodeToVoid t
-
-uplocal t ==
- setCodeToVoid t
-
-upfreeWithType(var,type) ==
- sayKeyedMsg("S2IS0055",['"free",var])
- var
-
-uplocalWithType(var,type) ==
- sayKeyedMsg("S2IS0055",['"local",var])
- var
-
---% Handlers for has
-
-uphas t ==
- t isnt [op,type,prop] => nil
- -- handler for category and attribute queries
- type :=
- x := elaborateForm type
- getModeSet x is [m] and (conceptualType m = $Type or categoryForm? m) =>
- val := objValUnwrap getValue x
- $genValue => MKQ val
- ["devaluate",val]
- throwKeyedMsg("S2IE0021",[type])
- catCode :=
- -- FIXME: when we come to support category valued variable
- -- this code needs to be adapted.
- prop := unabbrev prop
- evaluateType0 prop => ["evaluateType", MKQ prop]
- MKQ prop
- code := ["NOT",["NULL",["newHasTest",type, catCode]]]
- putValue(op,object(code,$Boolean))
- putModeSet(op,[$Boolean])
-
---hasTest(a,b) ==
--- newHasTest(a,b) --see NRUNFAST BOOT
-
---% Handlers for IF
-
-upIF t ==
- t isnt [op,cond,a,b] => nil
- bottomUpPredicate(cond,'"if/when")
- $genValue => interpIF(op,cond,a,b)
- compileIF(op,cond,a,b,t)
-
-compileIF(op,cond,a,b,t) ==
- -- type analyzer for compiled case where types of both branches of
- -- IF are resolved.
- ms1 := bottomUp a
- [m1] := ms1
- b = "%noBranch" =>
- evalIF(op,rest t,$Void)
- putModeSet(op,[$Void])
- b = "%noMapVal" =>
- -- if this was a return statement, we take the mode to be that
- -- of what is being returned.
- if getUnname a = 'return then
- ms1 := bottomUp second a
- [m1] := ms1
- evalIF(op,rest t,m1)
- putModeSet(op,ms1)
- ms2 := bottomUp b
- [m2] := ms2
- m:=
- m2=m1 => m1
- m2 = $Exit => m1
- m1 = $Exit => m2
- if m1 = $Symbol then
- m1:=getMinimalVarMode(getUnname a,$declaredMode)
- if m2 = $Symbol then
- m2:=getMinimalVarMode(getUnname b,$declaredMode)
- (r := resolveTTAny(m2,m1)) => r
- rempropI($mapName,'localModemap)
- rempropI($mapName,'localVars)
- rempropI($mapName,'mapBody)
- throwKeyedMsg("S2IS0026",[m2,m1])
- evalIF(op,rest t,m)
- putModeSet(op,[m])
-
-evalIF(op,[cond,a,b],m) ==
- -- generate code form compiled IF
- elseCode:=
- b="%noMapVal" =>
- [[MKQ true, ["throwKeyedMsg",MKQ "S2IM0018",
- ["CONS",MKQ object2Identifier $mapName,NIL]]]]
- b='%noBranch =>
- $lastLineInSEQ => [[MKQ true,["voidValue"]]]
- NIL
- [[MKQ true,genIFvalCode(b,m)]]
- code:=['%when,[getArgValue(cond,$Boolean),
- genIFvalCode(a,m)],:elseCode]
- triple:= objNew(code,m)
- putValue(op,triple)
-
-genIFvalCode(t,m) ==
- -- passes type information down braches of IF statement
- -- So that coercions can be performed on data at branches of IF.
- m1 := computedMode t
- m1=m => getArgValue(t,m)
- code:=objVal getValue t
- IFcodeTran(code,m,m1)
-
-IFcodeTran(code,m,m1) ==
- -- coerces values at branches of IF
- null code => code
- code is ["spadThrowBrightly",:.] => code
- m1 = $Exit => code
- code isnt ['%when,[p1,a1],['%otherwise,a2]] =>
- m = $Void => code
- code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) =>
- getValueNormalForm code'
- throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m)
- a1:=IFcodeTran(a1,m,m1)
- a2:=IFcodeTran(a2,m,m1)
- ['%when,[p1,a1],['%otherwise,a2]]
-
-interpIF(op,cond,a,b) ==
- -- non-compiled version of IF type analyzer. Doesn't resolve accross
- -- branches of the IF.
- val:= getValue cond
- val:= coerceInteractive(val,$Boolean) =>
- objValUnwrap(val) => upIFgenValue(op,a)
- b="%noBranch" => setValueToVoid op
- upIFgenValue(op,b)
- throwKeyedMsg("S2IS0031",NIL)
-
-upIFgenValue(op,tree) ==
- -- evaluates tree and transfers the results to op
- ms:=bottomUp tree
- val:= getValue tree
- putValue(op,val)
- putModeSet(op,ms)
-
---% Handlers for is
-
-upis t ==
- t isnt [op,a,pattern] => nil
- $opIsIs : local := true
- upisAndIsnt t
-
-upisnt t ==
- t isnt [op,a,pattern] => nil
- $opIsIs : local := nil
- upisAndIsnt t
-
-upisAndIsnt(t:=[op,a,pattern]) ==
- -- handler for "is" pattern matching
- mS:= bottomUp a
- mS isnt [m] =>
- keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"])
- putPvarModes(removeConstruct pattern,m)
- evalis(op,rest t,m)
- putModeSet(op,[$Boolean])
-
-putPvarModes(pattern,m) ==
- -- Puts the modes for the pattern variables into $env
- m isnt ["List",um] => throwKeyedMsg("S2IS0030",NIL)
- for pvar in pattern repeat
- IDENTP pvar => (not (pvar=$quadSymbol)) and put(pvar,'mode,um,$env)
- pvar is ['_:,var] =>
- null (var=$quadSymbol) and put(var,"mode",m,$env)
- pvar is ['_=,var] =>
- null (var=$quadSymbol) and put(var,"mode",um,$env)
- putPvarModes(pvar,um)
-
-evalis(op,[a,pattern],mode) ==
- -- actually handles is and isnt
- if $opIsIs
- then fun := 'evalIsPredicate
- else fun := 'evalIsntPredicate
- if isLocalPred pattern then
- code:= compileIs(a,pattern)
- else code:=[fun,getArgValue(a,mode),
- MKQ pattern,MKQ mode]
- triple := object(code,$Boolean)
- putValue(op,triple)
-
-isLocalPred pattern ==
- -- returns true if this predicate is to be compiled
- for pat in pattern repeat
- IDENTP pat and isLocallyBound pat => return true
- pat is [":",var] and isLocallyBound var => return true
- pat is ["=",var] and isLocallyBound var => return true
-
-compileIs(val,pattern) ==
- -- produce code for compiled "is" predicate. makes pattern variables
- -- into local variables of the function
- vars:= NIL
- for pat in rest pattern repeat
- IDENTP(pat) and isLocallyBound pat => vars:=[pat,:vars]
- pat is [":",var] => vars:= [var,:vars]
- pat is ["=",var] => vars:= [var,:vars]
- predCode:=["%LET",g:=gensym(),["isPatternMatch",
- getArgValue(val,computedMode val),MKQ removeConstruct pattern]]
- for var in removeDuplicates vars repeat
- assignCode:=[["%LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode]
- null $opIsIs =>
- ['%when,[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,'%true]]]
- ['%when,[['%not,["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,'%true]]]
-
-evalIsPredicate(value,pattern,mode) ==
- --This function pattern matches value to pattern, and returns
- --true if it matches, and false otherwise. As a side effect
- --if the pattern matches then the bindings given in the pattern
- --are made
- pattern:= removeConstruct pattern
- not ((valueAlist:=isPatternMatch(value,pattern))='failed) =>
- for [id,:value] in valueAlist repeat
- evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env)))
- true
- false
-
-evalIsntPredicate(value,pattern,mode) ==
- evalIsPredicate(value,pattern,mode) => false
- true
-
-removeConstruct pat ==
- -- removes the "construct" from the beginning of patterns
- if pat is ["construct",:p] then pat:=p
- if pat is ["cons", a, b] then pat := [a, [":", b]]
- atom pat => pat
- pat.first := removeConstruct first pat
- pat.rest := removeConstruct rest pat
- pat
-
-isPatternMatch(l,pats) ==
- -- perform the actual pattern match
- $subs: local := NIL
- isPatMatch(l,pats)
- $subs
-
-isPatMatch(l,pats) ==
- null pats =>
- null l => $subs
- $subs:='failed
- null l =>
- null pats => $subs
- pats is [[":",var]] =>
- $subs := [[var],:$subs]
- $subs:='failed
- pats is [pat,:restPats] =>
- IDENTP pat =>
- $subs:=[[pat,:first l],:$subs]
- isPatMatch(rest l,restPats)
- pat is ["=",var] =>
- p:=ASSQ(var,$subs) =>
- first l = rest p => isPatMatch(rest l, restPats)
- $subs:="failed"
- $subs:="failed"
- pat is [":",var] =>
- n:=#restPats
- m:=#l-n
- m<0 => $subs:="failed"
- ZEROP n => $subs:=[[var,:l],:$subs]
- $subs:=[[var,:[x for x in l for i in 1..m]],:$subs]
- isPatMatch(DROP(m,l),restPats)
- isPatMatch(first l,pat) = "failed" => "failed"
- isPatMatch(rest l,restPats)
- keyedSystemError("S2GE0016",['"isPatMatch",
- '"unknown form of is predicate"])
-
---% Handler for iterate
-
-upiterate t ==
- null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"])
- $iterateCount := $iterateCount + 1
- code := ["THROW",$repeatBodyLabel,'(voidValue)]
- $genValue => THROW(eval $repeatBodyLabel,voidValue())
- putValue(t,objNew(code,$Void))
- putModeSet(t,[$Void])
-
---% Handler for break
-
-upbreak t ==
- t isnt [op,.] => nil
- null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"])
- $breakCount := $breakCount + 1
- code := ["THROW",$repeatLabel,'(voidValue)]
- $genValue => THROW(eval $repeatLabel,voidValue())
- putValue(op,objNew(code,$Void))
- putModeSet(op,[$Void])
-
---% Handlers for %LET
-
-up%LET t ==
- -- analyzes and evaluates the righthand side, and does the variable
- -- binding
- t isnt [op,lhs,rhs] => nil
- $declaredMode: local := NIL
- cons? lhs =>
- var:= getUnname first lhs
- var = "construct" => upLETWithPatternOnLhs t
- var = "QUOTE" => throwKeyedMsg("S2IS0027",['"A quoted form"])
- upLETWithFormOnLhs(op,lhs,rhs)
- var:= getUnname lhs
- var = $immediateDataSymbol =>
- -- following will be immediate data, so probably ok to not
- -- specially format it
- obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm)
- throwKeyedMsg("S2IS0027",[obj])
- var in '(% %%) => -- for history
- throwKeyedMsg("S2IS0027",[var])
- (IDENTP var) and not (var in '(true false elt QUOTE)) =>
- var ~= (var' := unabbrev(var)) => -- constructor abbreviation
- throwKeyedMsg("S2IS0028",[var,var'])
- if get(var,'isInterpreterFunction,$e) then
- putHist(var,'isInterpreterFunction,false,$e)
- sayKeyedMsg("S2IS0049",['"Function",var])
- else if get(var,'isInterpreterRule,$e) then
- putHist(var,'isInterpreterRule,false,$e)
- sayKeyedMsg("S2IS0049",['"Rule",var])
- (m := isType rhs) => upLETtype(op,lhs,m)
- transferPropsToNode(var,lhs)
- if ( m:= getMode(lhs) ) then
- $declaredMode := m
- putTarget(rhs,m)
- if (val := getValue lhs) and (objMode val = $Boolean) and
- getUnname(rhs) = 'equation then putTarget(rhs,$Boolean)
- (rhsMs:= bottomUp rhs) = [$Void] =>
- throwKeyedMsg("S2IS0034",[var])
- val:=evalLET(lhs,rhs)
- putValue(op,val)
- putModeSet(op,[objMode(val)])
- throwKeyedMsg("S2IS0027",[var])
-
-evalLET(lhs,rhs) ==
- -- lhs is a vector for a variable, and rhs is the evaluated atree
- -- for the value which is coerced to the mode of lhs
- $useConvertForCoercions: local := true
- v' := (v:= getValue rhs)
- ((not getMode lhs) and (getModeSet rhs is [.])) or
- get(getUnname lhs,'autoDeclare,$env) =>
- v:=
- $genValue => v
- objNew(getValueNormalForm v,objMode v)
- evalLETput(lhs,v)
- t1:= objMode v
- t2' := (t2 := getMode lhs)
- value:=
- t1 = t2 =>
- $genValue => v
- objNew(getValueNormalForm v,objMode v)
- if isPartialMode t2 then
- if t1 = $Symbol and $declaredMode then
- t1:= getMinimalVarMode(objValUnwrap v,$declaredMode)
- t' := t2
- null (t2 := resolveTM(t1,t2)) =>
- if not t2 then t2 := t'
- throwKeyedMsg("S2IS0035",[t1,t2])
- null (v := getArgValue(rhs,t2)) =>
- isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) =>
- throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2])
- throwKeyedMsg("S2IS0037",[t2])
- t2 and object(v,t2)
- value => evalLETput(lhs,value)
- throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs)
-
-evalLETput(lhs,value) ==
- -- put value into the cell for lhs
- name:= getUnname lhs
- if not $genValue then
- code:=
- isLocallyBound name =>
- om := objMode(value)
- dm := get(name,'mode,$env)
- dm and not ((om = dm) or isSubDomain(om,dm) or
- isSubDomain(dm,om)) =>
- compFailure ['" The type of the local variable",
- :bright name,'"has changed in the computation."]
- if dm and isSubDomain(dm,om) then put(name,'mode,om,$env)
- ["%LET",name,objVal value,$mapName]
- -- $mapName is set in analyzeMap
- om := objMode value
- dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e))
- dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) =>
- THROW('loopCompiler,'tryInterpOnly)
- ['unwrap,['evalLETchangeValue,MKQ name,
- objNewCode(['wrap,objVal value],objMode value)]]
- value:= objNew(code,objMode value)
- isLocallyBound name =>
- if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env)
- put(name,'mode,objMode(value),$env)
- put(name,'automode,objMode(value),$env)
- $genValue and evalLETchangeValue(name,value)
- putValue(lhs,value)
-
-upLETWithPatternOnLhs(t := [op,pattern,a]) ==
- $opIsIs : local := true
- [m] := bottomUp a
- putPvarModes(pattern,m)
- object := evalis(op,[a,pattern],m)
- -- have to change code to return value of a
- failCode :=
- ['spadThrowBrightly,['concat,
- '" Pattern",['QUOTE,bright form2String pattern],
- '"is not matched in assignment to right-hand side."]]
- if $genValue
- then
- null objValUnwrap object => eval failCode
- putValue(op,getValue a)
- else
- code := ['%when,[objVal object,objVal getValue a],['%otherwise,failCode]]
- putValue(op,objNew(code,m))
- putModeSet(op,[m])
-
-evalLETchangeValue(name,value) ==
- -- write the value of name into the environment, clearing dependent
- -- maps if its type changes from its last value
- localEnv := cons? $env
- clearCompilationsFlag :=
- val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e)
- null val =>
- not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e))
- objMode val ~= objMode(value)
- if clearCompilationsFlag then
- clearDependencies(name,true)
- if localEnv and isLocallyBound name
- then $env:= putHist(name,'value,value,$env)
- else putIntSymTab(name,'value,value,$e)
- objVal value
-
-upLETWithFormOnLhs(op,lhs,rhs) ==
- -- bottomUp for assignment to forms (setelt, table or tuple)
- lhs' := getUnnameIfCan lhs
- rhs' := getUnnameIfCan rhs
- lhs' = "tuple" =>
- rhs' ~= "tuple" => throwKeyedMsg("S2IS0039",NIL)
- #(lhs) ~= #(rhs) => throwKeyedMsg("S2IS0038",NIL)
- -- generate a sequence of assignments, using local variables
- -- to first hold the assignments so that things like
- -- (t1,t2) := (t2,t1) will work.
- seq := []
- temps := [gensym() for l in rest lhs]
- for lvar in temps repeat mkLocalVar($mapName,lvar)
- for l in reverse rest lhs for t in temps repeat
- transferPropsToNode(getUnname l,l)
- let := mkAtreeNode "%LET"
- t' := mkAtreeNode t
- if m := getMode(l) then putMode(t',m)
- seq := [[let,l,t'],:seq]
- for t in temps for r in reverse rest rhs
- for l in reverse rest lhs repeat
- let := mkAtreeNode "%LET"
- t' := mkAtreeNode t
- if m := getMode(l) then putMode(t',m)
- seq := [[let,t',r],:seq]
- seq := [mkAtreeNode 'SEQ,:seq]
- ms := bottomUp seq
- putValue(op,getValue seq)
- putModeSet(op,ms)
- rhs' = "tuple" => throwKeyedMsg("S2IS0039",NIL)
- tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree)
- throwKeyedMsg("S2IS0060", NIL)
--- upTableSetelt(op,lhs,rhs)
-
-seteltable(lhs is [f,:argl],rhs) ==
- -- produces the setelt form for trees such as "l.2:= 3"
- null (g := getUnnameIfCan f) => NIL
- g="elt" => altSeteltable [:argl, rhs]
- get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL
- transferPropsToNode(g,f)
- getValue(lhs) or getMode(lhs) =>
- f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs]
- altSeteltable [:lhs,rhs]
- NIL
-
-altSeteltable args ==
- for x in args repeat bottomUp x
- newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"]
- form := NIL
-
- -- first look for exact matches for any of the possibilities
- while null form for newOp in newOps repeat
- if selectMms(newOp, args, NIL) then form := [newOp, :args]
-
- -- now try retracting arguments after the first
- while null form and ( "and"/[retractAtree(a) for a in rest args] ) repeat
- while null form for newOp in newOps repeat
- if selectMms(newOp, args, NIL) then form := [newOp, :args]
-
- form
-
-
-upSetelt(op,lhs,tree) ==
- -- type analyzes implicit setelt forms
- var:=opOf lhs
- transferPropsToNode(getUnname var,var)
- if (m1:=getMode var) then $declaredMode:= m1
- if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then
- putModeSet(var,[m1])
- ms := bottomUp tree
- putValue(op,getValue tree)
- putModeSet(op,ms)
-
-upTableSetelt(op,lhs is [htOp,:args],rhs) ==
- -- called only for undeclared, uninitialized table setelts
- ("*" = (PNAME getUnname htOp).0) and (1 ~= # args) =>
- throwKeyedMsg("S2IS0040",NIL)
- # args ~= 1 =>
- throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[",
- getUnname first args,
- ['",",getUnname arg for arg in rest args],'"]"]])
- keyMode := $Any
- putMode (htOp,['Table,keyMode,$Any])
- -- if we are to use a new table, we must call the "table"
- -- function to give it an initial value.
- bottomUp [mkAtreeNode "%LET",htOp,[mkAtreeNode 'table]]
- tableCode := objVal getValue htOp
- r := upSetelt(op, lhs, [mkAtreeNode "setelt",:lhs,rhs])
- $genValue => r
- -- construct code
- t := getValue op
- putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t))
- r
-
-unVectorize body ==
- -- transforms from an atree back into a tree
- vector? body =>
- name := getUnname body
- name ~= $immediateDataSymbol => name
- objValUnwrap getValue body
- atom body => body
- body is [op,:argl] =>
- newOp:=unVectorize op
- if newOp = 'SUCHTHAT then newOp := "|"
- if newOp = 'COERCE then newOp := "::"
- if newOp = 'Dollar then newOp := "$elt"
- [newOp,:unVectorize argl]
- systemErrorHere ["unVectorize",body]
-
-isType t ==
- -- Returns the evaluated type if t is a tree representing a type,
- -- and NIL otherwise
- op:=opOf t
- vector? op =>
- isMap(op:= getUnname op) => NIL
- op = 'Mapping and cons? t =>
- argTypes := [isType type for type in rest t]
- "or"/[null type for type in argTypes] => nil
- ['Mapping, :argTypes]
- isLocallyBound op => NIL
- d := isDomainValuedVariable op => d
- type:=
- -- next line handles subscripted vars
- (abbreviation?(op) or (op = 'typeOf) or
- constructor?(op) or (op in '(Record Union Enumeration))) and
- unabbrev unVectorize t
- type and evaluateType type
- d := isDomainValuedVariable op => d
- NIL
-
-upLETtype(op,lhs,type) ==
- -- performs type assignment
- opName:= getUnname lhs
- (not $genValue) and "or"/[CONTAINED(var,type) for var in $localVars] =>
- compFailure ['" Cannot compile type assignment to",:bright opName]
- mode := conceptualType type
- val:= objNew(type,mode)
- if isLocallyBound opName then put(opName,'value,val,$env)
- else putHist(opName,'value,val,$e)
- putValue(op,val)
- -- have to fix the following
- putModeSet(op,[mode])
-
-assignSymbol(symbol, value, domain) ==
--- Special function for binding an interpreter variable from within algebra
--- code. Does not do the assignment and returns nil, if the variable is
--- already assigned
- val := get(symbol, 'value, $e) => nil
- obj := objNew(wrap value, devaluate domain)
- put(symbol, 'value, obj, $e)
- true
-
---% Handler for Interpreter Macros
-
-getInterpMacroNames() ==
- names := [n for [n,:.] in $InterpreterMacroAlist]
- if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then
- names := append(names,[n for [n,:.] in rest m])
- MSORT names
-
-isInterpMacro name ==
- -- look in local and then global environment for a macro
- not IDENTP name => NIL
- name in $specialOps => NIL
- (m := get("--macros--",name,$env)) => m
- (m := get("--macros--",name,$e)) => m
- (m := get("--macros--",name,$InteractiveFrame)) => m
- -- $InterpreterMacroAlist will probably be phased out soon
- (sv := assoc(name,$InterpreterMacroAlist)) => [NIL,:rest sv]
- NIL
-
---% Handlers for prefix QUOTE
-
-upQUOTE t ==
- t isnt [op,expr] => NIL
- ms:= list
- m:= getBasicMode expr => m
- IDENTP expr =>
--- $useSymbolNotVariable => $Symbol
- getTarget t = $Identifier => $Identifier
- ['Variable,expr]
- $InputForm
- evalQUOTE(op,[expr],ms)
- putModeSet(op,ms)
-
-evalQUOTE(op,[expr],[m]) ==
- triple:=
- $genValue => objNewWrap(expr,m)
- objNew(['QUOTE,expr],m)
- putValue(op,triple)
-
---% Quasiquotation
-up_[_|_|_] t ==
- t isnt [op, x] => nil
- mode := getTypeOfSyntax x
- putValue(op, objNewWrap(x, mode))
- putModeSet(op, [mode])
-
---% Handler for pretend
-
-uppretend t ==
- t isnt [op,expr,type] => NIL
- mode := evaluateType unabbrev type
- not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode])
- bottomUp expr
- putValue(op,objNew(objVal getValue expr,mode))
- putModeSet(op,[mode])
-
---% Handlers for REDUCE
-
-getReduceFunction(op,type,result, locale) ==
- -- return the function cell for operation with the signature
- -- (type,type) -> type, possible from locale
- if type is ['Variable,var] then
- args := [arg := mkAtreeNode var,arg]
- putValue(arg,objNewWrap(var,type))
- else
- args := [arg := mkAtreeNode "%1",arg]
- if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol))
- putModeSet(arg,[type])
- vecOp:=mkAtreeNode op
- transferPropsToNode(op,vecOp)
- if locale then putAtree(vecOp,'dollar,locale)
- mmS:= selectMms(vecOp,args,result)
- mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS |
- (isHomogeneousArgs sig) and "and"/[null c for c in cond]]
- null mm => 'failed
- [[dc,:sig],fun,:.]:=mm
- dc='local => [MKQ [fun,:'local],:first sig]
- dcVector := evalDomain dc
- $compilingMap =>
- k := NRTgetMinivectorIndex(
- NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector)
- ['ELT,"$$$",k] --$$$ denotes minivector
- env:=
- NRTcompiledLookup(op,sig,dcVector)
- MKQ env
-
-isHomogeneous sig ==
- --return true if sig describes a homogeneous binary operation
- sig.0=sig.1 and sig.1=sig.2
-
-isHomogeneousArgs sig ==
- --return true if sig describes a homogeneous binary operation
- sig.1=sig.2
-
---% Handlers for REPEAT
-
-transformREPEAT [:itrl,body] ==
- -- syntactic transformation of repeat iterators, called from mkAtree2
- iterList:=[:iterTran1 for it in itrl] where iterTran1() ==
- it is ["STEP",index,lower,step,:upperList] =>
- [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
- for upper in upperList]]]
- it is ["IN",index,s] =>
- [['IN,index,mkAtree1 s]]
- it is ["ON",index,s] =>
- [['IN,index,mkAtree1 ['tails,s]]]
- it is ["WHILE",b] =>
- [["WHILE",mkAtree1 b]]
- it is ["|",pred] =>
- [["SUCHTHAT",mkAtree1 pred]]
- it is [op,:.] and (op in '(VALUE UNTIL)) => nil
- bodyTree:=mkAtree1 body
- iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2() ==
- it is ["STEP",:.] => nil
- it is ["IN",:.] => nil
- it is ["ON",:.] => nil
- it is ["WHILE",:.] => nil
- it is [op,b] and (op in '(UNTIL VALUE)) =>
- [[op,mkAtree1 b]]
- it is ['_|,pred] => nil
- keyedSystemError("S2GE0016",
- ['"transformREPEAT",'"Unknown type of iterator"])
- [:iterList,bodyTree]
-
-upREPEAT t ==
- -- REPEATS always return void() of Void
- -- assures throw to interpret-code mode goes to outermost loop
- $repeatLabel : local := MKQ gensym()
- $breakCount : local := 0
- $repeatBodyLabel : local := MKQ gensym()
- $iterateCount : local := 0
- $compilingLoop => upREPEAT1 t
- upREPEAT0 t
-
-upREPEAT0 t ==
- -- sets up catch point for interp-only mode
- $compilingLoop: local := true
- ms := CATCH('loopCompiler,upREPEAT1 t)
- ms = 'tryInterpOnly => interpOnlyREPEAT t
- ms
-
-upREPEAT1 t ==
- -- repeat loop handler with compiled body
- -- see if it has the expected form
- t isnt [op,:itrl,body] => NIL
- -- determine the mode of the repeat loop. At the moment, if there
- -- there are no iterators and there are no "break" statements, then
- -- the return type is Exit, otherwise Void.
- repeatMode :=
- null(itrl) and ($breakCount=0) => $Void
- $Void
-
- -- if interpreting, go do that
- $interpOnly => interpREPEAT(op,itrl,body,repeatMode)
-
- -- analyze iterators and loop body
- $iteratorVars: local := nil
- upLoopIters itrl
- bottomUpCompile body
-
- -- now that the body is analyzed, we should know everything that
- -- is in the UNTIL clause
- for itr in itrl repeat
- itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until")
-
- -- now go do it
- evalREPEAT(op,rest t,repeatMode)
- putModeSet(op,[repeatMode])
-
-evalREPEAT(op,[:itrl,body],repeatMode) ==
- -- generate code for loop
- bodyMode := computedMode body
- bodyCode := getArgValue(body,bodyMode)
- if $iterateCount > 0 then
- bodyCode := ["CATCH",$repeatBodyLabel,bodyCode]
- code := ['%loop,:[evalLoopIter itr for itr in itrl],bodyCode,voidValue()]
- code := timedOptimization code
- if $breakCount > 0 then code := ['CATCH,$repeatLabel,code]
- val :=
- $genValue =>
- timedEVALFUN code
- objNewWrap(voidValue(),repeatMode)
- objNew(code,repeatMode)
- putValue(op,val)
-
-interpOnlyREPEAT t ==
- -- interpret-code mode call to upREPEAT
- $genValue: local := true
- $interpOnly: local := true
- upREPEAT1 t
-
-interpREPEAT(op,itrl,body,repeatMode) ==
- -- performs interpret-code repeat
- $indexVars: local := NIL
- $indexTypes: local := NIL
- code :=
- -- we must insert a CATCH for the iterate clause
- ['%loop,:[interpIter itr for itr in itrl],
- ["CATCH",$repeatBodyLabel,interpLoop(body,$indexVars,
- $indexTypes,nil)],voidValue()]
- SPADCATCH(eval $repeatLabel,timedEVALFUN code)
- val:= objNewWrap(voidValue(),repeatMode)
- putValue(op,val)
- putModeSet(op,[repeatMode])
-
-interpLoop(expr,indexList,indexTypes,requiredType) ==
- -- generates code for interp-only repeat body
- ['interpLoopIter,MKQ expr,MKQ indexList,["LIST",:indexList],
- MKQ indexTypes, MKQ requiredType]
-
-interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) ==
- -- call interpreter on exp with loop vars in indexList with given
- -- values and types, requiredType is used from interpCOLLECT
- -- to indicate the required type of the result
- emptyAtree exp
- for i in indexList for val in indexVals for type in indexTypes repeat
- put(i,'value,objNewWrap(val,type),$env)
- bottomUp exp
- v:= getValue exp
- val :=
- null requiredType => v
- coerceInteractive(v,requiredType)
- null val =>
- throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType)
- objValUnwrap val
-
---% Handler for return
-
-upreturn t ==
- -- make sure we are in a user function
- t isnt [op,val] => NIL
- (null $compilingMap) and (null $interpOnly) =>
- throwKeyedMsg("S2IS0047",NIL)
- if $mapTarget then putTarget(val,$mapTarget)
- bottomUp val
- if $mapTarget
- then
- val' := getArgValue(val, $mapTarget)
- m := $mapTarget
- else
- val' := getValueNormalForm getValue val
- m := computedMode val
- cn := mapCatchName $mapName
- $mapReturnTypes := insert(m, $mapReturnTypes)
- $mapThrowCount := $mapThrowCount + 1
- -- if $genValue then we are interpreting the map
- $genValue => THROW(cn,objNewWrap(removeQuote val',m))
- putValue(op,objNew(['THROW,MKQ cn,val'],m))
- putModeSet(op,[$Exit])
-
---% Handler for SEQ
-
-upSEQ u ==
- -- assumes that exits were translated into if-then-elses
- -- handles flat SEQs and embedded returns
- u isnt [op,:args] => NIL
- if (target := getTarget(op)) then putTarget(last args, target)
- for x in args repeat bottomUp x
- null (m := computedMode last args) =>
- keyedSystemError("S2GE0016",['"upSEQ",
- '"last line of SEQ has no mode"])
- evalSEQ(op,args,m)
- putModeSet(op,[m])
-
-evalSEQ(op,args,m) ==
- -- generate code for SEQ
- [:argl,last] := args
- val:=
- $genValue => getValue last
- bodyCode := nil
- for x in args repeat
- (m1 := computedMode x) and (m1 ~= '$ThrowAwayMode) =>
- (av := getArgValue(x,m1)) ~= voidValue() =>
- bodyCode := [av,:bodyCode]
- code:=
- bodyCode is [c] => c
- ['PROGN,:reverse bodyCode]
- objNew(code,m)
- putValue(op,val)
-
---% Handlers for tuple
-
-uptuple t ==
- --Computes the common mode set of the construct by resolving across
- --the argument list, and evaluating
- t isnt [op,:l] => nil
- dol := getAtree(op,'dollar)
- tar := getTarget(op) or dol
- null l => upNullTuple(op,l,tar)
- isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar)
- aggs := '(List)
- if tar and cons?(tar) and not isPartialMode(tar) then
- first(tar) in aggs =>
- ud := second tar
- for x in l repeat if not getTarget(x) then putTarget(x,ud)
- first(tar) in '(Matrix SquareMatrix RectangularMatrix) =>
- vec := ['List,underDomainOf tar]
- for x in l repeat if not getTarget(x) then putTarget(x,vec)
- argModeSetList:= [bottomUp x for x in l]
- eltTypes := replaceSymbols([first x for x in argModeSetList],l)
- if not isPartialMode(tar) and tar is ['Tuple,ud] then
- mode := ['Tuple, resolveTypeListAny [ud,:eltTypes]]
- else mode := ['Tuple, resolveTypeListAny eltTypes]
- if isPartialMode tar then tar:=resolveTM(mode,tar)
- evalTuple(op,l,mode,tar)
-
-evalTuple(op,l,m,tar) ==
- [agg,:.,underMode]:= m
- code := asTupleNewCode(underMode, #l,
- [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l])
- val := object(code,m)
- if tar then val1 := coerceInteractive(val,tar) else val1 := val
-
- val1 =>
- putValue(op,val1)
- putModeSet(op,[tar or m])
- putValue(op,val)
- putModeSet(op,[m])
-
-upNullTuple(op,l,tar) ==
- -- handler for the empty tuple
- defMode :=
- tar and tar is [a,b] and (a in '(Stream Vector List)) and
- not isPartialMode(b) => ['Tuple,b]
- '(Tuple (None))
- val := objNewWrap(asTupleNew(getVMType second defMode,0,NIL), defMode)
- tar and not isPartialMode(tar) =>
- null (val' := coerceInteractive(val,tar)) =>
- throwKeyedMsg("S2IS0013",[tar])
- putValue(op,val')
- putModeSet(op,[tar])
- putValue(op,val)
- putModeSet(op,[defMode])
-
---% Handler for typeOf
-
-uptypeOf form ==
- form isnt [op, arg] => NIL
- if vector? arg then transferPropsToNode(getUnname arg,arg)
- if m := isType(arg) then
- m := conceptualType m
- else if not (m := getMode arg) then [m] := bottomUp arg
- t := conceptualType m -- ??? shall we reveal more impl. details?
- putValue(op, objNew(m,t))
- putModeSet(op,[t])
-
---% Handler for where
-
-upwhere t ==
- -- upwhere does the puts in where into a local environment
- t isnt [op,tree,clause] => NIL
- -- since the "clause" might be a local macro, we now call mkAtree
- -- on the "tree" part (it is not yet a vat)
- not $genValue =>
- compFailure [:bright '" where",
- '"for compiled code is not yet implemented."]
- $whereCacheList : local := nil
- [env,:e] := upwhereClause(clause,$env,$e)
- tree := upwhereMkAtree(tree,env,e)
- if x := getAtree(op,'dollar) then
- atom tree => throwKeyedMsg("S2IS0048",NIL)
- putAtree(first tree,'dollar,x)
- upwhereMain(tree,env,e)
- val := getValue tree
- putValue(op,val)
- result := putModeSet(op,getModeSet tree)
- wcl := [op for op in $whereCacheList]
- for op in wcl repeat clearDependencies(op,'T)
- result
-
-upwhereClause(tree,env,e) ==
- -- uses the variable bindings from env and e and returns an environment
- -- of its own bindings
- $env: local := copyHack env
- $e: local := copyHack e
- bottomUp tree
- [$env,:$e]
-
-upwhereMkAtree(tree,$env,$e) == mkAtree tree
-
-upwhereMain(tree,$env,$e) ==
- -- uses local copies of $env and $e while evaluating tree
- bottomUp tree
-
-copyHack(env) ==
- -- makes a copy of an environment with the exception of pairs
- -- (localModemap . something)
- c:= CAAR env
- d:= [fn p for p in c] where fn(p) ==
- [first p,:[(q is ["localModemap",:.] => q; copy q) for q in rest p]]
- [[d]]
-
-
---% Case patterns
-
-up%Match t ==
- sorry '"case pattern"
-
-
---% importing domains
-up%Import t ==
- t isnt [.,:types] => nil
- -- ??? shall we error in case types is nil?
- for x in types repeat
- $e := addDomain(devaluate objVal getValue x,$e)
- setValueToVoid t
-
---% Macro handling
-
--- Well, in fact we never handle macros in the interpreter directly.
--- Rather, they are saved in the `macro processing phase' (phMacro)
--- to be used in future macro expansions, and the AST we get at this
--- point already went through the macro expansion massage. So, all we
--- have to do is to the rubber stamp.
-up%Macro t ==
- setValueToVoid t
-
-up%MLambda t ==
- setValueToVoid t
-
-
---% Sorry for unhandled input constructs
-sorry kind ==
- throwKeyedMsg("S2IP0006",[kind])
-
---% Export
-up%Export t ==
- sorry '"export declaration"
-
---% Inline
-up%Inline t ==
- sorry '"inline declaration"
-
---% Category
-up%With t ==
- sorry '"category definition"
-
---% Domain
-up%Add t ==
- sorry '"domain definition"
-
--- Creates the function names of the special function handlers and puts
--- them on the property list of the function name
-
-for name in $specialOps repeat
- functionName:=INTERNL('up,name)
- property(name,'up) := functionName
-
diff --git a/src/interp/i-spec1.boot b/src/interp/i-special.boot
index ebc27251..6eb04e47 100644
--- a/src/interp/i-spec1.boot
+++ b/src/interp/i-special.boot
@@ -38,7 +38,7 @@ namespace BOOT
-- Functions which require special handlers (also see end of file)
-$specialOps := '(
+$specialOps == '(
ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar
equation error free _has IF _is _isnt iterate _break %LET _local MDEF _or
pretend QUOTE REDUCE REPEAT _return SEQ TARGET tuple typeOf _where
@@ -1269,3 +1269,1197 @@ $iteratorVars := nil
mkIteratorVariable id ==
$iteratorVars := [id,:$iteratorVars]
-- mkLocalVar('"the iterator expression",id)
+
+
+++ The `void' value object (an oxymoron). There really are constants.
+$VoidValueObject := objNew(voidValue(), $Void)
+$VoidCodeObject := objNew('(voidValue), $Void)
+
+setValueToVoid t ==
+ putValue(t,$VoidValueObject)
+ putModeSet(t,[$Void])
+
+setCodeToVoid t ==
+ putValue(t,$VoidCodeObject)
+ putModeSet(t,[$Void])
+
+++ Interpreter macros
+$InterpreterMacroAlist ==
+ '((%i . (complex 0 1))
+ (%e . (exp 1))
+ (%pi . (pi))
+ (SF . (DoubleFloat))
+ (%infinity . (infinity))
+ (%plusInfinity . (plusInfinity))
+ (%minusInfinity . (minusInfinity)))
+
+
+-- Functions which require special handlers (also see end of file)
+
+--% Handlers for map definitions
+
+upDEF t ==
+ -- performs map definitions. value is thrown away
+ t isnt [op,def,pred,.] => nil
+ v:=addDefMap(["DEF",:def],pred)
+ not(LISTP(def)) or null(def) =>
+ keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
+ mapOp := first def
+ if LISTP(mapOp) then
+ null mapOp =>
+ keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
+ mapOp := first mapOp
+ put(mapOp,"value",v,$e)
+ setValueToVoid op
+
+--% Handler for package calling and $ constants
+
+++ Return non-nil if `form' designate a constant defined in the
+++ domain designated by `domainForm'. More specifically, returns:
+++ nil: no such constant
+++ <%Mode>: the type of the constant.
+++ T: too many constants designated by `form'.
+constantInDomain?(form,domainForm) ==
+ opAlist := getConstructorOperationsFromDB domainForm.op
+ key := opOf form
+ entryList := [entry for (entry := [.,.,.,k]) in LASSOC(key,opAlist)
+ | k in '(CONST ASCONST)]
+ entryList is [[sig,.,.,.]] => sig.target
+ #entryList > 2 => true
+ key = "One" => constantInDomain?(["1"], domainForm)
+ key = "Zero" => constantInDomain?(["0"], domainForm)
+ nil
+
+++ Constant `c' of `type' is referenced from domain `d'; return its value
+++ in the VAT `op'.
+findConstantInDomain(op,c,type,d) ==
+ isPartialMode d => throwKeyedMsg("S2IS0020",NIL)
+ val :=
+ $genValue => wrap getConstantFromDomain([c],d)
+ ["getConstantFromDomain",["LIST",MKQ c],MKQ d]
+ type := substitute(d,"$",type)
+ putValue(op,objNew(val,type))
+ putModeSet(op,[type])
+
+upDollar t ==
+ -- Puts "dollar" property in atree node, and calls bottom up
+ t isnt [op,D,form] => nil
+ t2 := t
+ (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] =>
+ keyedMsgCompFailure("S2IS0032",NIL)
+ D="Lisp" => upLispCall(op,form)
+ if vector? D and (# D > 0) then D := D.0
+ t := evaluateType unabbrev D
+ categoryForm? t =>
+ throwKeyedMsg("S2IE0012", [t])
+ f := getUnname form
+ if f = $immediateDataSymbol then
+ f := objValUnwrap coerceInteractive(getValue form,$OutputForm)
+ if f = '(construct) then f := "nil"
+ atom form and (f ~= $immediateDataSymbol) =>
+ type := constantInDomain?([f],t) =>
+ type ~= true => findConstantInDomain(op,f,type,t)
+ -- Ambiguous constant. FIXME: try to narrow before giving up.
+ throwKeyedMsg("S2IB0008h",[f,t])
+ findUniqueOpInDomain(op,f,t)
+
+ nargs := #rest form
+
+ (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms
+
+ f ~= "construct" and null isOpInDomain(f,t,nargs) =>
+ throwKeyedMsg("S2IS0023",[f,t])
+ if (sig := findCommonSigInDomain(f,t,nargs)) then
+ for x in sig for y in form repeat
+ if x then putTarget(y,x)
+ putAtree(first form,"dollar",t)
+ ms := bottomUp form
+ f in '(One Zero) and cons? (ms) and first(ms) = $OutputForm =>
+ throwKeyedMsg("S2IS0021",[f,t])
+ putValue(op,getValue first form)
+ putModeSet(op,ms)
+
+
+upDollarTuple(op, f, t, t2, args, nargs) ==
+ -- this function tries to find a tuple function to use
+ -- nargs = 1 and getUnname first args = "Tuple" => NIL
+ -- nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL
+ null (singles := isOpInDomain(f,t,1)) => NIL
+ tuple := NIL
+ for [[.,arg], :.] in singles while null tuple repeat
+ if arg is ['Tuple,.] then tuple := arg
+ null tuple => NIL
+ [.,D,form] := t2
+ newArg := [mkAtreeNode "tuple",:args]
+ putTarget(newArg, tuple)
+ ms := bottomUp newArg
+ first ms ~= tuple => NIL
+ form := [first form, newArg]
+ putAtree(first form,"dollar",t)
+ ms := bottomUp form
+ putValue(op,getValue first form)
+ putModeSet(op,ms)
+
+upLispCall(op,t) ==
+ -- process $Lisp calls
+ if atom t then code:=getUnname t else
+ [lispOp,:argl]:= t
+ null functionp lispOp.0 =>
+ throwKeyedMsg("S2IS0024",[lispOp.0])
+ for arg in argl repeat bottomUp arg
+ code:=[getUnname lispOp,
+ :[getArgValue(arg,computedMode arg) for arg in argl]]
+ rt := '(SExpression)
+ putValue(op,object(code,rt))
+ putModeSet(op,[rt])
+
+--% Handlers for equation
+
+upequation tree ==
+ -- only handle this if there is a target of Boolean
+ -- this should speed things up a bit
+ tree isnt [op,lhs,rhs] => NIL
+ $Boolean ~= getTarget(op) => NIL
+ not vector? op => NIL
+ -- change equation into '='
+ op.0 := "="
+ bottomUp tree
+
+--% Handler for error
+
+uperror t ==
+ -- when compiling a function, this merely inserts another argument
+ -- which is the name of the function.
+ not $compilingMap => NIL
+ t isnt [op,msg] => NIL
+ msgMs := bottomUp putCallInfo(msg,"error",1,1)
+ msgMs isnt [=$String] => NIL
+ t.rest := [mkAtree object2String $mapName,msg]
+ bottomUp t
+
+--% Handlers for free and local
+
+upfree t ==
+ setCodeToVoid t
+
+uplocal t ==
+ setCodeToVoid t
+
+upfreeWithType(var,type) ==
+ sayKeyedMsg("S2IS0055",['"free",var])
+ var
+
+uplocalWithType(var,type) ==
+ sayKeyedMsg("S2IS0055",['"local",var])
+ var
+
+--% Handlers for has
+
+uphas t ==
+ t isnt [op,type,prop] => nil
+ -- handler for category and attribute queries
+ type :=
+ x := elaborateForm type
+ getModeSet x is [m] and (conceptualType m = $Type or categoryForm? m) =>
+ val := objValUnwrap getValue x
+ $genValue => MKQ val
+ ["devaluate",val]
+ throwKeyedMsg("S2IE0021",[type])
+ catCode :=
+ -- FIXME: when we come to support category valued variable
+ -- this code needs to be adapted.
+ prop := unabbrev prop
+ evaluateType0 prop => ["evaluateType", MKQ prop]
+ MKQ prop
+ code := ["NOT",["NULL",["newHasTest",type, catCode]]]
+ putValue(op,object(code,$Boolean))
+ putModeSet(op,[$Boolean])
+
+--hasTest(a,b) ==
+-- newHasTest(a,b) --see NRUNFAST BOOT
+
+--% Handlers for IF
+
+upIF t ==
+ t isnt [op,cond,a,b] => nil
+ bottomUpPredicate(cond,'"if/when")
+ $genValue => interpIF(op,cond,a,b)
+ compileIF(op,cond,a,b,t)
+
+compileIF(op,cond,a,b,t) ==
+ -- type analyzer for compiled case where types of both branches of
+ -- IF are resolved.
+ ms1 := bottomUp a
+ [m1] := ms1
+ b = "%noBranch" =>
+ evalIF(op,rest t,$Void)
+ putModeSet(op,[$Void])
+ b = "%noMapVal" =>
+ -- if this was a return statement, we take the mode to be that
+ -- of what is being returned.
+ if getUnname a = 'return then
+ ms1 := bottomUp second a
+ [m1] := ms1
+ evalIF(op,rest t,m1)
+ putModeSet(op,ms1)
+ ms2 := bottomUp b
+ [m2] := ms2
+ m:=
+ m2=m1 => m1
+ m2 = $Exit => m1
+ m1 = $Exit => m2
+ if m1 = $Symbol then
+ m1:=getMinimalVarMode(getUnname a,$declaredMode)
+ if m2 = $Symbol then
+ m2:=getMinimalVarMode(getUnname b,$declaredMode)
+ (r := resolveTTAny(m2,m1)) => r
+ rempropI($mapName,'localModemap)
+ rempropI($mapName,'localVars)
+ rempropI($mapName,'mapBody)
+ throwKeyedMsg("S2IS0026",[m2,m1])
+ evalIF(op,rest t,m)
+ putModeSet(op,[m])
+
+evalIF(op,[cond,a,b],m) ==
+ -- generate code form compiled IF
+ elseCode:=
+ b="%noMapVal" =>
+ [[MKQ true, ["throwKeyedMsg",MKQ "S2IM0018",
+ ["CONS",MKQ object2Identifier $mapName,NIL]]]]
+ b='%noBranch =>
+ $lastLineInSEQ => [[MKQ true,["voidValue"]]]
+ NIL
+ [[MKQ true,genIFvalCode(b,m)]]
+ code:=['%when,[getArgValue(cond,$Boolean),
+ genIFvalCode(a,m)],:elseCode]
+ triple:= objNew(code,m)
+ putValue(op,triple)
+
+genIFvalCode(t,m) ==
+ -- passes type information down braches of IF statement
+ -- So that coercions can be performed on data at branches of IF.
+ m1 := computedMode t
+ m1=m => getArgValue(t,m)
+ code:=objVal getValue t
+ IFcodeTran(code,m,m1)
+
+IFcodeTran(code,m,m1) ==
+ -- coerces values at branches of IF
+ null code => code
+ code is ["spadThrowBrightly",:.] => code
+ m1 = $Exit => code
+ code isnt ['%when,[p1,a1],['%otherwise,a2]] =>
+ m = $Void => code
+ code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) =>
+ getValueNormalForm code'
+ throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m)
+ a1:=IFcodeTran(a1,m,m1)
+ a2:=IFcodeTran(a2,m,m1)
+ ['%when,[p1,a1],['%otherwise,a2]]
+
+interpIF(op,cond,a,b) ==
+ -- non-compiled version of IF type analyzer. Doesn't resolve accross
+ -- branches of the IF.
+ val:= getValue cond
+ val:= coerceInteractive(val,$Boolean) =>
+ objValUnwrap(val) => upIFgenValue(op,a)
+ b="%noBranch" => setValueToVoid op
+ upIFgenValue(op,b)
+ throwKeyedMsg("S2IS0031",NIL)
+
+upIFgenValue(op,tree) ==
+ -- evaluates tree and transfers the results to op
+ ms:=bottomUp tree
+ val:= getValue tree
+ putValue(op,val)
+ putModeSet(op,ms)
+
+--% Handlers for is
+
+upis t ==
+ t isnt [op,a,pattern] => nil
+ $opIsIs : local := true
+ upisAndIsnt t
+
+upisnt t ==
+ t isnt [op,a,pattern] => nil
+ $opIsIs : local := nil
+ upisAndIsnt t
+
+upisAndIsnt(t:=[op,a,pattern]) ==
+ -- handler for "is" pattern matching
+ mS:= bottomUp a
+ mS isnt [m] =>
+ keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"])
+ putPvarModes(removeConstruct pattern,m)
+ evalis(op,rest t,m)
+ putModeSet(op,[$Boolean])
+
+putPvarModes(pattern,m) ==
+ -- Puts the modes for the pattern variables into $env
+ m isnt ["List",um] => throwKeyedMsg("S2IS0030",NIL)
+ for pvar in pattern repeat
+ IDENTP pvar => (not (pvar=$quadSymbol)) and put(pvar,'mode,um,$env)
+ pvar is ['_:,var] =>
+ null (var=$quadSymbol) and put(var,"mode",m,$env)
+ pvar is ['_=,var] =>
+ null (var=$quadSymbol) and put(var,"mode",um,$env)
+ putPvarModes(pvar,um)
+
+evalis(op,[a,pattern],mode) ==
+ -- actually handles is and isnt
+ if $opIsIs
+ then fun := 'evalIsPredicate
+ else fun := 'evalIsntPredicate
+ if isLocalPred pattern then
+ code:= compileIs(a,pattern)
+ else code:=[fun,getArgValue(a,mode),
+ MKQ pattern,MKQ mode]
+ triple := object(code,$Boolean)
+ putValue(op,triple)
+
+isLocalPred pattern ==
+ -- returns true if this predicate is to be compiled
+ for pat in pattern repeat
+ IDENTP pat and isLocallyBound pat => return true
+ pat is [":",var] and isLocallyBound var => return true
+ pat is ["=",var] and isLocallyBound var => return true
+
+compileIs(val,pattern) ==
+ -- produce code for compiled "is" predicate. makes pattern variables
+ -- into local variables of the function
+ vars:= NIL
+ for pat in rest pattern repeat
+ IDENTP(pat) and isLocallyBound pat => vars:=[pat,:vars]
+ pat is [":",var] => vars:= [var,:vars]
+ pat is ["=",var] => vars:= [var,:vars]
+ predCode:=["%LET",g:=gensym(),["isPatternMatch",
+ getArgValue(val,computedMode val),MKQ removeConstruct pattern]]
+ for var in removeDuplicates vars repeat
+ assignCode:=[["%LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode]
+ null $opIsIs =>
+ ['%when,[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,'%true]]]
+ ['%when,[['%not,["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,'%true]]]
+
+evalIsPredicate(value,pattern,mode) ==
+ --This function pattern matches value to pattern, and returns
+ --true if it matches, and false otherwise. As a side effect
+ --if the pattern matches then the bindings given in the pattern
+ --are made
+ pattern:= removeConstruct pattern
+ not ((valueAlist:=isPatternMatch(value,pattern))='failed) =>
+ for [id,:value] in valueAlist repeat
+ evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env)))
+ true
+ false
+
+evalIsntPredicate(value,pattern,mode) ==
+ evalIsPredicate(value,pattern,mode) => false
+ true
+
+removeConstruct pat ==
+ -- removes the "construct" from the beginning of patterns
+ if pat is ["construct",:p] then pat:=p
+ if pat is ["cons", a, b] then pat := [a, [":", b]]
+ atom pat => pat
+ pat.first := removeConstruct first pat
+ pat.rest := removeConstruct rest pat
+ pat
+
+isPatternMatch(l,pats) ==
+ -- perform the actual pattern match
+ $subs: local := NIL
+ isPatMatch(l,pats)
+ $subs
+
+isPatMatch(l,pats) ==
+ null pats =>
+ null l => $subs
+ $subs:='failed
+ null l =>
+ null pats => $subs
+ pats is [[":",var]] =>
+ $subs := [[var],:$subs]
+ $subs:='failed
+ pats is [pat,:restPats] =>
+ IDENTP pat =>
+ $subs:=[[pat,:first l],:$subs]
+ isPatMatch(rest l,restPats)
+ pat is ["=",var] =>
+ p:=ASSQ(var,$subs) =>
+ first l = rest p => isPatMatch(rest l, restPats)
+ $subs:="failed"
+ $subs:="failed"
+ pat is [":",var] =>
+ n:=#restPats
+ m:=#l-n
+ m<0 => $subs:="failed"
+ ZEROP n => $subs:=[[var,:l],:$subs]
+ $subs:=[[var,:[x for x in l for i in 1..m]],:$subs]
+ isPatMatch(DROP(m,l),restPats)
+ isPatMatch(first l,pat) = "failed" => "failed"
+ isPatMatch(rest l,restPats)
+ keyedSystemError("S2GE0016",['"isPatMatch",
+ '"unknown form of is predicate"])
+
+--% Handler for iterate
+
+upiterate t ==
+ null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"])
+ $iterateCount := $iterateCount + 1
+ code := ["THROW",$repeatBodyLabel,'(voidValue)]
+ $genValue => THROW(eval $repeatBodyLabel,voidValue())
+ putValue(t,objNew(code,$Void))
+ putModeSet(t,[$Void])
+
+--% Handler for break
+
+upbreak t ==
+ t isnt [op,.] => nil
+ null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"])
+ $breakCount := $breakCount + 1
+ code := ["THROW",$repeatLabel,'(voidValue)]
+ $genValue => THROW(eval $repeatLabel,voidValue())
+ putValue(op,objNew(code,$Void))
+ putModeSet(op,[$Void])
+
+--% Handlers for %LET
+
+up%LET t ==
+ -- analyzes and evaluates the righthand side, and does the variable
+ -- binding
+ t isnt [op,lhs,rhs] => nil
+ $declaredMode: local := NIL
+ cons? lhs =>
+ var:= getUnname first lhs
+ var = "construct" => upLETWithPatternOnLhs t
+ var = "QUOTE" => throwKeyedMsg("S2IS0027",['"A quoted form"])
+ upLETWithFormOnLhs(op,lhs,rhs)
+ var:= getUnname lhs
+ var = $immediateDataSymbol =>
+ -- following will be immediate data, so probably ok to not
+ -- specially format it
+ obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm)
+ throwKeyedMsg("S2IS0027",[obj])
+ var in '(% %%) => -- for history
+ throwKeyedMsg("S2IS0027",[var])
+ (IDENTP var) and not (var in '(true false elt QUOTE)) =>
+ var ~= (var' := unabbrev(var)) => -- constructor abbreviation
+ throwKeyedMsg("S2IS0028",[var,var'])
+ if get(var,'isInterpreterFunction,$e) then
+ putHist(var,'isInterpreterFunction,false,$e)
+ sayKeyedMsg("S2IS0049",['"Function",var])
+ else if get(var,'isInterpreterRule,$e) then
+ putHist(var,'isInterpreterRule,false,$e)
+ sayKeyedMsg("S2IS0049",['"Rule",var])
+ (m := isType rhs) => upLETtype(op,lhs,m)
+ transferPropsToNode(var,lhs)
+ if ( m:= getMode(lhs) ) then
+ $declaredMode := m
+ putTarget(rhs,m)
+ if (val := getValue lhs) and (objMode val = $Boolean) and
+ getUnname(rhs) = 'equation then putTarget(rhs,$Boolean)
+ (rhsMs:= bottomUp rhs) = [$Void] =>
+ throwKeyedMsg("S2IS0034",[var])
+ val:=evalLET(lhs,rhs)
+ putValue(op,val)
+ putModeSet(op,[objMode(val)])
+ throwKeyedMsg("S2IS0027",[var])
+
+evalLET(lhs,rhs) ==
+ -- lhs is a vector for a variable, and rhs is the evaluated atree
+ -- for the value which is coerced to the mode of lhs
+ $useConvertForCoercions: local := true
+ v' := (v:= getValue rhs)
+ ((not getMode lhs) and (getModeSet rhs is [.])) or
+ get(getUnname lhs,'autoDeclare,$env) =>
+ v:=
+ $genValue => v
+ objNew(getValueNormalForm v,objMode v)
+ evalLETput(lhs,v)
+ t1:= objMode v
+ t2' := (t2 := getMode lhs)
+ value:=
+ t1 = t2 =>
+ $genValue => v
+ objNew(getValueNormalForm v,objMode v)
+ if isPartialMode t2 then
+ if t1 = $Symbol and $declaredMode then
+ t1:= getMinimalVarMode(objValUnwrap v,$declaredMode)
+ t' := t2
+ null (t2 := resolveTM(t1,t2)) =>
+ if not t2 then t2 := t'
+ throwKeyedMsg("S2IS0035",[t1,t2])
+ null (v := getArgValue(rhs,t2)) =>
+ isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) =>
+ throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2])
+ throwKeyedMsg("S2IS0037",[t2])
+ t2 and object(v,t2)
+ value => evalLETput(lhs,value)
+ throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs)
+
+evalLETput(lhs,value) ==
+ -- put value into the cell for lhs
+ name:= getUnname lhs
+ if not $genValue then
+ code:=
+ isLocallyBound name =>
+ om := objMode(value)
+ dm := get(name,'mode,$env)
+ dm and not ((om = dm) or isSubDomain(om,dm) or
+ isSubDomain(dm,om)) =>
+ compFailure ['" The type of the local variable",
+ :bright name,'"has changed in the computation."]
+ if dm and isSubDomain(dm,om) then put(name,'mode,om,$env)
+ ["%LET",name,objVal value,$mapName]
+ -- $mapName is set in analyzeMap
+ om := objMode value
+ dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e))
+ dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) =>
+ THROW('loopCompiler,'tryInterpOnly)
+ ['unwrap,['evalLETchangeValue,MKQ name,
+ objNewCode(['wrap,objVal value],objMode value)]]
+ value:= objNew(code,objMode value)
+ isLocallyBound name =>
+ if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env)
+ put(name,'mode,objMode(value),$env)
+ put(name,'automode,objMode(value),$env)
+ $genValue and evalLETchangeValue(name,value)
+ putValue(lhs,value)
+
+upLETWithPatternOnLhs(t := [op,pattern,a]) ==
+ $opIsIs : local := true
+ [m] := bottomUp a
+ putPvarModes(pattern,m)
+ object := evalis(op,[a,pattern],m)
+ -- have to change code to return value of a
+ failCode :=
+ ['spadThrowBrightly,['concat,
+ '" Pattern",['QUOTE,bright form2String pattern],
+ '"is not matched in assignment to right-hand side."]]
+ if $genValue
+ then
+ null objValUnwrap object => eval failCode
+ putValue(op,getValue a)
+ else
+ code := ['%when,[objVal object,objVal getValue a],['%otherwise,failCode]]
+ putValue(op,objNew(code,m))
+ putModeSet(op,[m])
+
+evalLETchangeValue(name,value) ==
+ -- write the value of name into the environment, clearing dependent
+ -- maps if its type changes from its last value
+ localEnv := cons? $env
+ clearCompilationsFlag :=
+ val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e)
+ null val =>
+ not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e))
+ objMode val ~= objMode(value)
+ if clearCompilationsFlag then
+ clearDependencies(name,true)
+ if localEnv and isLocallyBound name
+ then $env:= putHist(name,'value,value,$env)
+ else putIntSymTab(name,'value,value,$e)
+ objVal value
+
+upLETWithFormOnLhs(op,lhs,rhs) ==
+ -- bottomUp for assignment to forms (setelt, table or tuple)
+ lhs' := getUnnameIfCan lhs
+ rhs' := getUnnameIfCan rhs
+ lhs' = "tuple" =>
+ rhs' ~= "tuple" => throwKeyedMsg("S2IS0039",NIL)
+ #(lhs) ~= #(rhs) => throwKeyedMsg("S2IS0038",NIL)
+ -- generate a sequence of assignments, using local variables
+ -- to first hold the assignments so that things like
+ -- (t1,t2) := (t2,t1) will work.
+ seq := []
+ temps := [gensym() for l in rest lhs]
+ for lvar in temps repeat mkLocalVar($mapName,lvar)
+ for l in reverse rest lhs for t in temps repeat
+ transferPropsToNode(getUnname l,l)
+ let := mkAtreeNode "%LET"
+ t' := mkAtreeNode t
+ if m := getMode(l) then putMode(t',m)
+ seq := [[let,l,t'],:seq]
+ for t in temps for r in reverse rest rhs
+ for l in reverse rest lhs repeat
+ let := mkAtreeNode "%LET"
+ t' := mkAtreeNode t
+ if m := getMode(l) then putMode(t',m)
+ seq := [[let,t',r],:seq]
+ seq := [mkAtreeNode 'SEQ,:seq]
+ ms := bottomUp seq
+ putValue(op,getValue seq)
+ putModeSet(op,ms)
+ rhs' = "tuple" => throwKeyedMsg("S2IS0039",NIL)
+ tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree)
+ throwKeyedMsg("S2IS0060", NIL)
+-- upTableSetelt(op,lhs,rhs)
+
+seteltable(lhs is [f,:argl],rhs) ==
+ -- produces the setelt form for trees such as "l.2:= 3"
+ null (g := getUnnameIfCan f) => NIL
+ g="elt" => altSeteltable [:argl, rhs]
+ get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL
+ transferPropsToNode(g,f)
+ getValue(lhs) or getMode(lhs) =>
+ f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs]
+ altSeteltable [:lhs,rhs]
+ NIL
+
+altSeteltable args ==
+ for x in args repeat bottomUp x
+ newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"]
+ form := NIL
+
+ -- first look for exact matches for any of the possibilities
+ while null form for newOp in newOps repeat
+ if selectMms(newOp, args, NIL) then form := [newOp, :args]
+
+ -- now try retracting arguments after the first
+ while null form and ( "and"/[retractAtree(a) for a in rest args] ) repeat
+ while null form for newOp in newOps repeat
+ if selectMms(newOp, args, NIL) then form := [newOp, :args]
+
+ form
+
+
+upSetelt(op,lhs,tree) ==
+ -- type analyzes implicit setelt forms
+ var:=opOf lhs
+ transferPropsToNode(getUnname var,var)
+ if (m1:=getMode var) then $declaredMode:= m1
+ if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then
+ putModeSet(var,[m1])
+ ms := bottomUp tree
+ putValue(op,getValue tree)
+ putModeSet(op,ms)
+
+upTableSetelt(op,lhs is [htOp,:args],rhs) ==
+ -- called only for undeclared, uninitialized table setelts
+ ("*" = (PNAME getUnname htOp).0) and (1 ~= # args) =>
+ throwKeyedMsg("S2IS0040",NIL)
+ # args ~= 1 =>
+ throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[",
+ getUnname first args,
+ ['",",getUnname arg for arg in rest args],'"]"]])
+ keyMode := $Any
+ putMode (htOp,['Table,keyMode,$Any])
+ -- if we are to use a new table, we must call the "table"
+ -- function to give it an initial value.
+ bottomUp [mkAtreeNode "%LET",htOp,[mkAtreeNode 'table]]
+ tableCode := objVal getValue htOp
+ r := upSetelt(op, lhs, [mkAtreeNode "setelt",:lhs,rhs])
+ $genValue => r
+ -- construct code
+ t := getValue op
+ putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t))
+ r
+
+unVectorize body ==
+ -- transforms from an atree back into a tree
+ vector? body =>
+ name := getUnname body
+ name ~= $immediateDataSymbol => name
+ objValUnwrap getValue body
+ atom body => body
+ body is [op,:argl] =>
+ newOp:=unVectorize op
+ if newOp = 'SUCHTHAT then newOp := "|"
+ if newOp = 'COERCE then newOp := "::"
+ if newOp = 'Dollar then newOp := "$elt"
+ [newOp,:unVectorize argl]
+ systemErrorHere ["unVectorize",body]
+
+isType t ==
+ -- Returns the evaluated type if t is a tree representing a type,
+ -- and NIL otherwise
+ op:=opOf t
+ vector? op =>
+ isMap(op:= getUnname op) => NIL
+ op = 'Mapping and cons? t =>
+ argTypes := [isType type for type in rest t]
+ "or"/[null type for type in argTypes] => nil
+ ['Mapping, :argTypes]
+ isLocallyBound op => NIL
+ d := isDomainValuedVariable op => d
+ type:=
+ -- next line handles subscripted vars
+ (abbreviation?(op) or (op = 'typeOf) or
+ constructor?(op) or (op in '(Record Union Enumeration))) and
+ unabbrev unVectorize t
+ type and evaluateType type
+ d := isDomainValuedVariable op => d
+ NIL
+
+upLETtype(op,lhs,type) ==
+ -- performs type assignment
+ opName:= getUnname lhs
+ (not $genValue) and "or"/[CONTAINED(var,type) for var in $localVars] =>
+ compFailure ['" Cannot compile type assignment to",:bright opName]
+ mode := conceptualType type
+ val:= objNew(type,mode)
+ if isLocallyBound opName then put(opName,'value,val,$env)
+ else putHist(opName,'value,val,$e)
+ putValue(op,val)
+ -- have to fix the following
+ putModeSet(op,[mode])
+
+assignSymbol(symbol, value, domain) ==
+-- Special function for binding an interpreter variable from within algebra
+-- code. Does not do the assignment and returns nil, if the variable is
+-- already assigned
+ val := get(symbol, 'value, $e) => nil
+ obj := objNew(wrap value, devaluate domain)
+ put(symbol, 'value, obj, $e)
+ true
+
+--% Handler for Interpreter Macros
+
+getInterpMacroNames() ==
+ names := [n for [n,:.] in $InterpreterMacroAlist]
+ if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then
+ names := append(names,[n for [n,:.] in rest m])
+ MSORT names
+
+isInterpMacro name ==
+ -- look in local and then global environment for a macro
+ not IDENTP name => NIL
+ name in $specialOps => NIL
+ (m := get("--macros--",name,$env)) => m
+ (m := get("--macros--",name,$e)) => m
+ (m := get("--macros--",name,$InteractiveFrame)) => m
+ -- $InterpreterMacroAlist will probably be phased out soon
+ (sv := assoc(name,$InterpreterMacroAlist)) => [NIL,:rest sv]
+ NIL
+
+--% Handlers for prefix QUOTE
+
+upQUOTE t ==
+ t isnt [op,expr] => NIL
+ ms:= list
+ m:= getBasicMode expr => m
+ IDENTP expr =>
+-- $useSymbolNotVariable => $Symbol
+ getTarget t = $Identifier => $Identifier
+ ['Variable,expr]
+ $InputForm
+ evalQUOTE(op,[expr],ms)
+ putModeSet(op,ms)
+
+evalQUOTE(op,[expr],[m]) ==
+ triple:=
+ $genValue => objNewWrap(expr,m)
+ objNew(['QUOTE,expr],m)
+ putValue(op,triple)
+
+--% Quasiquotation
+up_[_|_|_] t ==
+ t isnt [op, x] => nil
+ mode := getTypeOfSyntax x
+ putValue(op, objNewWrap(x, mode))
+ putModeSet(op, [mode])
+
+--% Handler for pretend
+
+uppretend t ==
+ t isnt [op,expr,type] => NIL
+ mode := evaluateType unabbrev type
+ not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode])
+ bottomUp expr
+ putValue(op,objNew(objVal getValue expr,mode))
+ putModeSet(op,[mode])
+
+--% Handlers for REDUCE
+
+getReduceFunction(op,type,result, locale) ==
+ -- return the function cell for operation with the signature
+ -- (type,type) -> type, possible from locale
+ if type is ['Variable,var] then
+ args := [arg := mkAtreeNode var,arg]
+ putValue(arg,objNewWrap(var,type))
+ else
+ args := [arg := mkAtreeNode "%1",arg]
+ if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol))
+ putModeSet(arg,[type])
+ vecOp:=mkAtreeNode op
+ transferPropsToNode(op,vecOp)
+ if locale then putAtree(vecOp,'dollar,locale)
+ mmS:= selectMms(vecOp,args,result)
+ mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS |
+ (isHomogeneousArgs sig) and "and"/[null c for c in cond]]
+ null mm => 'failed
+ [[dc,:sig],fun,:.]:=mm
+ dc='local => [MKQ [fun,:'local],:first sig]
+ dcVector := evalDomain dc
+ $compilingMap =>
+ k := NRTgetMinivectorIndex(
+ NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector)
+ ['ELT,"$$$",k] --$$$ denotes minivector
+ env:=
+ NRTcompiledLookup(op,sig,dcVector)
+ MKQ env
+
+isHomogeneous sig ==
+ --return true if sig describes a homogeneous binary operation
+ sig.0=sig.1 and sig.1=sig.2
+
+isHomogeneousArgs sig ==
+ --return true if sig describes a homogeneous binary operation
+ sig.1=sig.2
+
+--% Handlers for REPEAT
+
+transformREPEAT [:itrl,body] ==
+ -- syntactic transformation of repeat iterators, called from mkAtree2
+ iterList:=[:iterTran1 for it in itrl] where iterTran1() ==
+ it is ["STEP",index,lower,step,:upperList] =>
+ [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
+ for upper in upperList]]]
+ it is ["IN",index,s] =>
+ [['IN,index,mkAtree1 s]]
+ it is ["ON",index,s] =>
+ [['IN,index,mkAtree1 ['tails,s]]]
+ it is ["WHILE",b] =>
+ [["WHILE",mkAtree1 b]]
+ it is ["|",pred] =>
+ [["SUCHTHAT",mkAtree1 pred]]
+ it is [op,:.] and (op in '(VALUE UNTIL)) => nil
+ bodyTree:=mkAtree1 body
+ iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2() ==
+ it is ["STEP",:.] => nil
+ it is ["IN",:.] => nil
+ it is ["ON",:.] => nil
+ it is ["WHILE",:.] => nil
+ it is [op,b] and (op in '(UNTIL VALUE)) =>
+ [[op,mkAtree1 b]]
+ it is ['_|,pred] => nil
+ keyedSystemError("S2GE0016",
+ ['"transformREPEAT",'"Unknown type of iterator"])
+ [:iterList,bodyTree]
+
+upREPEAT t ==
+ -- REPEATS always return void() of Void
+ -- assures throw to interpret-code mode goes to outermost loop
+ $repeatLabel : local := MKQ gensym()
+ $breakCount : local := 0
+ $repeatBodyLabel : local := MKQ gensym()
+ $iterateCount : local := 0
+ $compilingLoop => upREPEAT1 t
+ upREPEAT0 t
+
+upREPEAT0 t ==
+ -- sets up catch point for interp-only mode
+ $compilingLoop: local := true
+ ms := CATCH('loopCompiler,upREPEAT1 t)
+ ms = 'tryInterpOnly => interpOnlyREPEAT t
+ ms
+
+upREPEAT1 t ==
+ -- repeat loop handler with compiled body
+ -- see if it has the expected form
+ t isnt [op,:itrl,body] => NIL
+ -- determine the mode of the repeat loop. At the moment, if there
+ -- there are no iterators and there are no "break" statements, then
+ -- the return type is Exit, otherwise Void.
+ repeatMode :=
+ null(itrl) and ($breakCount=0) => $Void
+ $Void
+
+ -- if interpreting, go do that
+ $interpOnly => interpREPEAT(op,itrl,body,repeatMode)
+
+ -- analyze iterators and loop body
+ $iteratorVars: local := nil
+ upLoopIters itrl
+ bottomUpCompile body
+
+ -- now that the body is analyzed, we should know everything that
+ -- is in the UNTIL clause
+ for itr in itrl repeat
+ itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until")
+
+ -- now go do it
+ evalREPEAT(op,rest t,repeatMode)
+ putModeSet(op,[repeatMode])
+
+evalREPEAT(op,[:itrl,body],repeatMode) ==
+ -- generate code for loop
+ bodyMode := computedMode body
+ bodyCode := getArgValue(body,bodyMode)
+ if $iterateCount > 0 then
+ bodyCode := ["CATCH",$repeatBodyLabel,bodyCode]
+ code := ['%loop,:[evalLoopIter itr for itr in itrl],bodyCode,voidValue()]
+ code := timedOptimization code
+ if $breakCount > 0 then code := ['CATCH,$repeatLabel,code]
+ val :=
+ $genValue =>
+ timedEVALFUN code
+ objNewWrap(voidValue(),repeatMode)
+ objNew(code,repeatMode)
+ putValue(op,val)
+
+interpOnlyREPEAT t ==
+ -- interpret-code mode call to upREPEAT
+ $genValue: local := true
+ $interpOnly: local := true
+ upREPEAT1 t
+
+interpREPEAT(op,itrl,body,repeatMode) ==
+ -- performs interpret-code repeat
+ $indexVars: local := NIL
+ $indexTypes: local := NIL
+ code :=
+ -- we must insert a CATCH for the iterate clause
+ ['%loop,:[interpIter itr for itr in itrl],
+ ["CATCH",$repeatBodyLabel,interpLoop(body,$indexVars,
+ $indexTypes,nil)],voidValue()]
+ SPADCATCH(eval $repeatLabel,timedEVALFUN code)
+ val:= objNewWrap(voidValue(),repeatMode)
+ putValue(op,val)
+ putModeSet(op,[repeatMode])
+
+interpLoop(expr,indexList,indexTypes,requiredType) ==
+ -- generates code for interp-only repeat body
+ ['interpLoopIter,MKQ expr,MKQ indexList,["LIST",:indexList],
+ MKQ indexTypes, MKQ requiredType]
+
+interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) ==
+ -- call interpreter on exp with loop vars in indexList with given
+ -- values and types, requiredType is used from interpCOLLECT
+ -- to indicate the required type of the result
+ emptyAtree exp
+ for i in indexList for val in indexVals for type in indexTypes repeat
+ put(i,'value,objNewWrap(val,type),$env)
+ bottomUp exp
+ v:= getValue exp
+ val :=
+ null requiredType => v
+ coerceInteractive(v,requiredType)
+ null val =>
+ throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType)
+ objValUnwrap val
+
+--% Handler for return
+
+upreturn t ==
+ -- make sure we are in a user function
+ t isnt [op,val] => NIL
+ (null $compilingMap) and (null $interpOnly) =>
+ throwKeyedMsg("S2IS0047",NIL)
+ if $mapTarget then putTarget(val,$mapTarget)
+ bottomUp val
+ if $mapTarget
+ then
+ val' := getArgValue(val, $mapTarget)
+ m := $mapTarget
+ else
+ val' := getValueNormalForm getValue val
+ m := computedMode val
+ cn := mapCatchName $mapName
+ $mapReturnTypes := insert(m, $mapReturnTypes)
+ $mapThrowCount := $mapThrowCount + 1
+ -- if $genValue then we are interpreting the map
+ $genValue => THROW(cn,objNewWrap(removeQuote val',m))
+ putValue(op,objNew(['THROW,MKQ cn,val'],m))
+ putModeSet(op,[$Exit])
+
+--% Handler for SEQ
+
+upSEQ u ==
+ -- assumes that exits were translated into if-then-elses
+ -- handles flat SEQs and embedded returns
+ u isnt [op,:args] => NIL
+ if (target := getTarget(op)) then putTarget(last args, target)
+ for x in args repeat bottomUp x
+ null (m := computedMode last args) =>
+ keyedSystemError("S2GE0016",['"upSEQ",
+ '"last line of SEQ has no mode"])
+ evalSEQ(op,args,m)
+ putModeSet(op,[m])
+
+evalSEQ(op,args,m) ==
+ -- generate code for SEQ
+ [:argl,last] := args
+ val:=
+ $genValue => getValue last
+ bodyCode := nil
+ for x in args repeat
+ (m1 := computedMode x) and (m1 ~= '$ThrowAwayMode) =>
+ (av := getArgValue(x,m1)) ~= voidValue() =>
+ bodyCode := [av,:bodyCode]
+ code:=
+ bodyCode is [c] => c
+ ['PROGN,:reverse bodyCode]
+ objNew(code,m)
+ putValue(op,val)
+
+--% Handlers for tuple
+
+uptuple t ==
+ --Computes the common mode set of the construct by resolving across
+ --the argument list, and evaluating
+ t isnt [op,:l] => nil
+ dol := getAtree(op,'dollar)
+ tar := getTarget(op) or dol
+ null l => upNullTuple(op,l,tar)
+ isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar)
+ aggs := '(List)
+ if tar and cons?(tar) and not isPartialMode(tar) then
+ first(tar) in aggs =>
+ ud := second tar
+ for x in l repeat if not getTarget(x) then putTarget(x,ud)
+ first(tar) in '(Matrix SquareMatrix RectangularMatrix) =>
+ vec := ['List,underDomainOf tar]
+ for x in l repeat if not getTarget(x) then putTarget(x,vec)
+ argModeSetList:= [bottomUp x for x in l]
+ eltTypes := replaceSymbols([first x for x in argModeSetList],l)
+ if not isPartialMode(tar) and tar is ['Tuple,ud] then
+ mode := ['Tuple, resolveTypeListAny [ud,:eltTypes]]
+ else mode := ['Tuple, resolveTypeListAny eltTypes]
+ if isPartialMode tar then tar:=resolveTM(mode,tar)
+ evalTuple(op,l,mode,tar)
+
+evalTuple(op,l,m,tar) ==
+ [agg,:.,underMode]:= m
+ code := asTupleNewCode(underMode, #l,
+ [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l])
+ val := object(code,m)
+ if tar then val1 := coerceInteractive(val,tar) else val1 := val
+
+ val1 =>
+ putValue(op,val1)
+ putModeSet(op,[tar or m])
+ putValue(op,val)
+ putModeSet(op,[m])
+
+upNullTuple(op,l,tar) ==
+ -- handler for the empty tuple
+ defMode :=
+ tar and tar is [a,b] and (a in '(Stream Vector List)) and
+ not isPartialMode(b) => ['Tuple,b]
+ '(Tuple (None))
+ val := objNewWrap(asTupleNew(getVMType second defMode,0,NIL), defMode)
+ tar and not isPartialMode(tar) =>
+ null (val' := coerceInteractive(val,tar)) =>
+ throwKeyedMsg("S2IS0013",[tar])
+ putValue(op,val')
+ putModeSet(op,[tar])
+ putValue(op,val)
+ putModeSet(op,[defMode])
+
+--% Handler for typeOf
+
+uptypeOf form ==
+ form isnt [op, arg] => NIL
+ if vector? arg then transferPropsToNode(getUnname arg,arg)
+ if m := isType(arg) then
+ m := conceptualType m
+ else if not (m := getMode arg) then [m] := bottomUp arg
+ t := conceptualType m -- ??? shall we reveal more impl. details?
+ putValue(op, objNew(m,t))
+ putModeSet(op,[t])
+
+--% Handler for where
+
+upwhere t ==
+ -- upwhere does the puts in where into a local environment
+ t isnt [op,tree,clause] => NIL
+ -- since the "clause" might be a local macro, we now call mkAtree
+ -- on the "tree" part (it is not yet a vat)
+ not $genValue =>
+ compFailure [:bright '" where",
+ '"for compiled code is not yet implemented."]
+ $whereCacheList : local := nil
+ [env,:e] := upwhereClause(clause,$env,$e)
+ tree := upwhereMkAtree(tree,env,e)
+ if x := getAtree(op,'dollar) then
+ atom tree => throwKeyedMsg("S2IS0048",NIL)
+ putAtree(first tree,'dollar,x)
+ upwhereMain(tree,env,e)
+ val := getValue tree
+ putValue(op,val)
+ result := putModeSet(op,getModeSet tree)
+ wcl := [op for op in $whereCacheList]
+ for op in wcl repeat clearDependencies(op,'T)
+ result
+
+upwhereClause(tree,env,e) ==
+ -- uses the variable bindings from env and e and returns an environment
+ -- of its own bindings
+ $env: local := copyHack env
+ $e: local := copyHack e
+ bottomUp tree
+ [$env,:$e]
+
+upwhereMkAtree(tree,$env,$e) == mkAtree tree
+
+upwhereMain(tree,$env,$e) ==
+ -- uses local copies of $env and $e while evaluating tree
+ bottomUp tree
+
+copyHack(env) ==
+ -- makes a copy of an environment with the exception of pairs
+ -- (localModemap . something)
+ c:= CAAR env
+ d:= [fn p for p in c] where fn(p) ==
+ [first p,:[(q is ["localModemap",:.] => q; copy q) for q in rest p]]
+ [[d]]
+
+
+--% Case patterns
+
+up%Match t ==
+ sorry '"case pattern"
+
+
+--% importing domains
+up%Import t ==
+ t isnt [.,:types] => nil
+ -- ??? shall we error in case types is nil?
+ for x in types repeat
+ $e := addDomain(devaluate objVal getValue x,$e)
+ setValueToVoid t
+
+--% Macro handling
+
+-- Well, in fact we never handle macros in the interpreter directly.
+-- Rather, they are saved in the `macro processing phase' (phMacro)
+-- to be used in future macro expansions, and the AST we get at this
+-- point already went through the macro expansion massage. So, all we
+-- have to do is to the rubber stamp.
+up%Macro t ==
+ setValueToVoid t
+
+up%MLambda t ==
+ setValueToVoid t
+
+
+--% Sorry for unhandled input constructs
+sorry kind ==
+ throwKeyedMsg("S2IP0006",[kind])
+
+--% Export
+up%Export t ==
+ sorry '"export declaration"
+
+--% Inline
+up%Inline t ==
+ sorry '"inline declaration"
+
+--% Category
+up%With t ==
+ sorry '"category definition"
+
+--% Domain
+up%Add t ==
+ sorry '"domain definition"
+
+-- Creates the function names of the special function handlers and puts
+-- them on the property list of the function name
+
+for name in $specialOps repeat
+ functionName:=INTERNL('up,name)
+ property(name,'up) := functionName
+
+