aboutsummaryrefslogtreecommitdiff
path: root/src/interp/wi1.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/wi1.boot.pamphlet')
-rw-r--r--src/interp/wi1.boot.pamphlet1287
1 files changed, 1287 insertions, 0 deletions
diff --git a/src/interp/wi1.boot.pamphlet b/src/interp/wi1.boot.pamphlet
new file mode 100644
index 00000000..a86a7da2
--- /dev/null
+++ b/src/interp/wi1.boot.pamphlet
@@ -0,0 +1,1287 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/wi1.boot} Pamphlet}
+\author{The Axiom Team}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{License}
+
+<<license>>=
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- 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.
+
+@
+<<*>>=
+<<license>>
+
+)package "BOOT"
+
+-- !! do not delete the next function !
+
+spad2AsTranslatorAutoloadOnceTrigger() == nil
+
+pairList(u,v) == [[x,:y] for x in u for y in v]
+
+--======================================================================
+-- Temporary definitions---for tracing and debugging
+--======================================================================
+tr fn ==
+ $convertingSpadFile : local := true
+ $options: local := nil
+ sfn := STRINGIMAGE fn
+ newname := STRCONC(sfn,'".as")
+ $outStream :local := MAKE_-OUTSTREAM newname
+ markSay '"#pile"
+ markSay('"#include _"axiom.as_"")
+ markTerpri()
+ CATCH("SPAD__READER",compiler [INTERN sfn])
+ SHUT $outStream
+
+stackMessage msg ==
+--if msg isnt ["cannot coerce: ",:.] then foobum msg
+ $compErrorMessageStack:= [msg,:$compErrorMessageStack]
+ nil
+
+ppFull x ==
+ _*PRINT_-LEVEL_* : local := nil
+ _*PRINT_-DEPTH_* : local := nil
+ _*PRINT_-LENGTH_* : local := nil
+ pp x
+
+put(x,prop,val,e) ==
+--if prop = 'mode and CONTAINED('PART,val) then foobar val
+ $InteractiveMode and not EQ(e,$CategoryFrame) =>
+ putIntSymTab(x,prop,val,e)
+ --e must never be $CapsuleModemapFrame
+ null atom x => put(first x,prop,val,e)
+ newProplist:= augProplistOf(x,prop,val,e)
+ prop="modemap" and $insideCapsuleFunctionIfTrue=true =>
+ SAY ["**** modemap PUT on CapsuleModemapFrame: ",val]
+ $CapsuleModemapFrame:=
+ addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame),
+ $CapsuleModemapFrame)
+ e
+ addBinding(x,newProplist,e)
+
+addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
+--if CONTAINED('PART,proplist) then foobar proplist
+ EQ(proplist,getProplist(var,e)) => e
+ $InteractiveMode => addBindingInteractive(var,proplist,e)
+ if curContour is [[ =var,:.],:.] then curContour:= rest curContour
+ --Previous line should save some space
+ [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist]
+
+--======================================================================
+-- From define.boot
+--======================================================================
+compJoin(["Join",:argl],m,e) ==
+ catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl]
+ catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil)
+ catList':=
+ [extract for x in catList] where
+ extract() ==
+ x := markKillAll x
+ isCategoryForm(x,e) =>
+ parameters:=
+ union("append"/[getParms(y,e) for y in rest x],parameters)
+ where getParms(y,e) ==
+ atom y =>
+ isDomainForm(y,e) => LIST y
+ nil
+ y is ['LENGTH,y'] => [y,y']
+ LIST y
+ x
+ x is ["DomainSubstitutionMacro",pl,body] =>
+ (parameters:= union(pl,parameters); body)
+ x is ["mkCategory",:.] => x
+ atom x and getmode(x,e)=$Category => x
+ stackSemanticError(["invalid argument to Join: ",x],nil)
+ x
+ T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e]
+ convert(T,m)
+
+
+compDefineFunctor(dfOriginal,m,e,prefix,fal) ==
+ df := markInsertParts dfOriginal
+ $domainShell: local -- holds the category of the object being compiled
+ $profileCompiler: local := true
+ $profileAlist: local := nil
+ $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1)
+ compDefineFunctor1(df,m,e,prefix,fal)
+
+compDefineLisplib(df,m,e,prefix,fal,fn) ==
+ ["DEF",[op,:.],:.] := df
+ --fn= compDefineCategory OR compDefineFunctor
+ sayMSG fillerSpaces(72,'"-")
+ $LISPLIB: local := 'T
+ $op: local := op
+ $lisplibAttributes: local := NIL
+ $lisplibPredicates: local := NIL -- set by makePredicateBitVector
+ $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd)
+ $lisplibForm: local := NIL
+ $lisplibKind: local := NIL
+ $lisplibModemap: local := NIL
+ $lisplibModemapAlist: local := NIL
+ $lisplibSlot1 : local := NIL -- used by NRT mechanisms
+ $lisplibOperationAlist: local := NIL
+ $lisplibSuperDomain: local := NIL
+ $libFile: local := NIL
+ $lisplibVariableAlist: local := NIL
+ $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc
+ $lisplibCategory: local := nil
+ --for categories, is rhs of definition; otherwise, is target of functor
+ --will eventually become the "constructorCategory" property in lisplib
+ --set in compDefineCategory if category, otherwise in finalizeLisplib
+ libName := getConstructorAbbreviation op
+ -- $incrementalLisplibFlag seems never to be set so next line not used
+ -- originalLisplibCategory:= getLisplib(libName,'constructorCategory)
+ BOUNDP '$compileDocumentation and $compileDocumentation =>
+ compileDocumentation libName
+ sayMSG ['" initializing ",$spadLibFT,:bright libName,
+ '"for",:bright op]
+ initializeLisplib libName
+ sayMSG ['" compiling into ",$spadLibFT,:bright libName]
+ res:= FUNCALL(fn,df,m,e,prefix,fal)
+ sayMSG ['" finalizing ",$spadLibFT,:bright libName]
+--finalizeLisplib libName
+ FRESH_-LINE $algebraOutputStream
+ sayMSG fillerSpaces(72,'"-")
+ unloadOneConstructor(op,libName)
+ res
+
+compTopLevel(x,m,e) ==
+--+ signals that target is derived from lhs-- see NRTmakeSlot1Info
+ $NRTderivedTargetIfTrue: local := false
+ $killOptimizeIfTrue: local:= false
+ $forceAdd: local:= false
+ $compTimeSum: local := 0
+ $resolveTimeSum: local := 0
+ $packagesUsed: local := []
+ -- The next line allows the new compiler to be tested interactively.
+ compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak
+ if x is ["where",:.] then x := markWhereTran x
+ def :=
+ x is ["where",a,:.] => a
+ x
+ $originalTarget : local :=
+ def is ["DEF",.,[target,:.],:.] => target
+ 'sorry
+ x is ["DEF",:.] or x is ["where",["DEF",:.],:.] =>
+ ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e])
+ --keep old environment after top level function defs
+ FUNCALL(compFun,x,m,e)
+
+markWhereTran ["where",["DEF",form,sig,clist,body],:tail] ==
+ items :=
+ tail is [['SEQ,:l,['exit,n,x]]] => [:l,x]
+ [first tail]
+ [op,:argl] := form
+ [target,:atypeList] := sig
+ decls := [[":",a,b] for a in argl for b in atypeList | b]
+-- not (and/[null x for x in atypeList]) =>
+-- systemError ['"unexpected WHERE argument list: ",:atypeList]
+ for x in items repeat
+ x is [":",a,b] =>
+ a is ['LISTOF,:r] =>
+ for y in r repeat decls := [[":",y,b],:decls]
+ decls := [x,:decls]
+ x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) =>
+ fn = target or fn is [=target] => ttype := bd
+ fn = body or fn is [=body] => body := bd
+ macros := [x,:macros]
+ systemError ['"unexpected WHERE item: ",x]
+ nargtypes := [p for arg in argl |
+ p := or/[t for d in decls | d is [.,=arg,t]] or
+ systemError ['"Missing WHERE declaration for :", arg]]
+ nform := form
+ ntarget := ttype or target
+ ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body]
+ result :=
+ REVERSE macros is [:m,e] =>
+ mpart :=
+ m => ['SEQ,:m,['exit,1,e]]
+ e
+ ['where,ndef,mpart]
+ ndef
+ result
+
+compPART(u,m,e) ==
+--------new------------------------------------------94/10/11
+ ['PART,.,x] := u
+ T := comp(x,m,e) => markAny('compPART,u, T)
+ nil
+
+xxxxx x == x
+
+qt(n,T) ==
+ null T => nil
+ if null getProplist('R,T.env) then xxxxx n
+ T
+
+qe(n,e) ==
+ if null getProplist('R,e) then xxxxx n
+ e
+
+comp(x,m,e) ==
+ qe(7,e)
+ T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T))
+--T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m)
+ --------------------------------------------------------94/11/10
+ nil
+
+comp0(x,m,e) ==
+ qe(8,e)
+--version of comp which skips the marking (see compReduce1)
+ T:= compNoStacking(x,m,e) =>
+ $compStack:= nil
+ qt(10,T)
+ $compStack:= [[x,m,e,$exitModeStack],:$compStack]
+ nil
+
+compNoStacking(xOrig,m,e) ==
+ $partExpression: local := nil
+ xOrig := markKillAllRecursive xOrig
+-->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e)
+----------------------------------------------------------94/10/11
+ qt(11,compNoStacking0(xOrig,m,e))
+
+markKillAllRecursive x ==
+ x is [op,:r] =>
+--->op = 'PART => markKillAllRecursive CADR r
+ op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r]
+----------------------------------------------------------94/10/11
+ constructor? op => markKillAll x
+ op = 'elt and constructor? opOf CAR r =>
+ ['elt,markKillAllRecursive CAR r,CADR r]
+ x
+ x
+
+compNoStackingAux($partExpression,m,e) ==
+-----------------not used---------------------94/10/11
+ x := CADDR $partExpression
+ T := compNoStacking0(x,m,e) or return nil
+ markParts($partExpression,T)
+
+compNoStacking0(x,m,e) ==
+ qe(1,e)
+ T := compNoStacking01(x,m,qe(51,e))
+ qt(52,T)
+
+compNoStacking01(x,m,e) ==
+--compNoStacking0(x,m,e) ==
+ if CONTAINED('MI,m) then m := markKillAll(m)
+ T:= comp2(x,m,e) =>
+ (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) =>
+ [T.expr,"Rep",T.env]; qt(12,T))
+ --$Representation is bound in compDefineFunctor, set by doIt
+ --this hack says that when something is undeclared, $ is
+ --preferred to the underlying representation -- RDJ 9/12/83
+ T := compNoStacking1(x,m,e,$compStack)
+ qt(13,T)
+
+compNoStacking1(x,m,e,$compStack) ==
+ u:= get(if m="$" then "Rep" else m,"value",e) =>
+ m1 := markKillAll u.expr
+--------------------> new <-------------------------
+ T:= comp2(x,m1,e) => coerce(T,m)
+ nil
+--------------------> new <-------------------------
+ nil
+
+compWithMappingMode(x,m,oldE) ==
+ ["Mapping",m',:sl] := m
+ $killOptimizeIfTrue: local:= true
+ e:= oldE
+ x := markKillAll x
+ ------------------
+ m := markKillAll m
+ ------------------
+--if x is ['PART,.,y] then x := y
+---------------------------------
+ isFunctor x =>
+ if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and
+ (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl]
+ ) and extendsCategoryForm("$",target,m') then return [x,m,e]
+ if STRINGP x then x:= INTERN x
+ for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat
+ [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e)
+ not null vl and not hasFormalMapVariable(x, vl) => return
+ [u,.,.] := comp([x,:vl],m',e) or return nil
+ extractCodeAndConstructTriple(u, m, oldE)
+ null vl and (t := comp([x], m', e)) => return
+ [u,.,.] := t
+ extractCodeAndConstructTriple(u, m, oldE)
+ [u,.,.]:= comp(x,m',e) or return nil
+ originalFun := u
+ if originalFun is ['WI,a,b] then u := b
+ uu := ['LAMBDA,vl,u]
+ --------------------------> 11/28 drop COMP-TRAN, optimizations
+ T := [uu,m,oldE]
+ originalFun is ['WI,a,b] => markLambda(vl,a,m,T)
+ markLambda(vl,originalFun,m,T)
+
+compAtom(x,m,e) ==
+ T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T)
+ x="nil" =>
+ T:=
+ modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e)
+ modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e)
+ T => convert(T,m)
+-->
+ FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e]
+-- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T')
+ t:=
+ isSymbol x =>
+ compSymbol(x,m,e) or return nil
+ m = $Expression and primitiveType x => [x,m,e]
+ STRINGP x =>
+ x ^= '"failed" and (member('(Symbol), $localImportStack) or
+ member('(Symbol), $globalImportStack)) => markAt [x, '(String), e]
+ [x, x, e]
+ [x,primitiveType x or return nil,e]
+ convert(t,m)
+
+extractCodeAndConstructTriple(u, m, oldE) ==
+ u := markKillAll u
+ u is ["call",fn,:.] =>
+ if fn is ["applyFun",a] then fn := a
+ [fn,m,oldE]
+ [op,:.,env] := u
+ [["CONS",["function",op],env],m,oldE]
+
+compSymbol(s,m,e) ==
+ s="$NoValue" => ["$NoValue",$NoValueMode,e]
+ isFluid s => [s,getmode(s,e) or return nil,e]
+ s="true" => ['(QUOTE T),$Boolean,e]
+ s="false" => [false,$Boolean,e]
+ s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e]
+ v:= get(s,"value",e) =>
+--+
+ MEMQ(s,$functorLocalParameters) =>
+ NRTgetLocalIndex s
+ [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile
+ [s,v.mode,e] --s has been SETQd
+ m':= getmode(s,e) =>
+ if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and
+ not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s
+ [s,m',e] --s is a declared argument
+ MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s]
+--->
+ m = $Symbol or m = $Expression => [['QUOTE,s],m,e]
+ ---> was ['QUOTE, s]
+ not isFunction(s,e) => errorRef s
+
+compForm(form,m,e) ==
+ if form is [['PART,.,op],:r] then form := [op,:r]
+ ----------------------------------------------------- 94/10/16
+ T:=
+ compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return
+ stackMessageIfNone ["cannot compile","%b",form,"%d"]
+ T
+
+compForm1(form,m,e) ==
+ [op,:argl] := form
+ $NumberOfArgsIfInteger: local:= #argl --see compElt
+ op="error" =>
+ [[op,:[([.,.,e]:=outputComp(x,e)).expr
+ for x in argl]],m,e]
+ op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e)
+ op is ["elt",domain,op'] =>
+ domain := markKillAll domain
+ domain="Lisp" =>
+ --op'='QUOTE and null rest argl => [first argl,m,e]
+ val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]]
+ markLisp([val,m,e],m)
+-------> new <-------------
+-- foobar domain
+-- markImport(domain,true)
+-------> new <-------------
+ domain=$Expression and op'="construct" => compExpressionList(argl,m,e)
+ (op'="COLLECT") and coerceable(domain,m,e) =>
+ (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m))
+-------> new <-------------
+ domain= 'Rep and
+ (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e),
+ [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e)
+ | x is [[ =domain,:.],:.]])) => ans
+-------> new <-------------
+ ans := compForm2([op',:argl],m,e:= addDomain(domain,e),
+ [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans
+ (op'="construct") and coerceable(domain,m,e) =>
+ (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m))
+ nil
+
+ e:= addDomain(m,e) --???unneccessary because of comp2's call???
+ (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T
+ compToApply(op,argl,m,e)
+
+--% WI and MI
+
+compForm3(form is [op,:argl],m,e,modemapList) ==
+--order modemaps so that ones from Rep are moved to the front
+ modemapList := compFormOrderModemaps(modemapList,m = "$")
+ qe(22,e)
+ T:=
+ or/
+ [compFormWithModemap(form,m,e,first (mml:= ml))
+ for ml in tails modemapList] or return nil
+ qt(14,T)
+ result :=
+ $compUniquelyIfTrue =>
+ or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] =>
+ THROW("compUniquely",nil)
+ qt(15,T)
+ qt(16,T)
+ qt(17,markAny('compForm3,form,result))
+
+compFormOrderModemaps(mml,targetIsDollar?) ==
+--order modemaps so that ones from Rep are moved to the front
+--exceptions: if $ is the target and there are 2 modemaps with
+-- identical signatures, move the $ one ahead
+ repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep]
+ if repMms and targetIsDollar? then
+ dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$"
+ and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]]
+ repMms := [:dollarMms, :repMms]
+ null repMms => mml
+ [:repMms,:SETDIFFERENCE(mml,repMms)]
+
+compWI(["WI",a,b],m,E) ==
+ u := comp(b,m,E)
+ pp (u => "====> ok"; 'NO)
+ u
+
+compMI(["MI",a,b],m,E) ==
+ u := comp(b,m,E)
+ pp (u => "====> ok"; 'NO)
+ u
+
+compWhere([.,form,:exprList],m,eInit) ==
+ $insideExpressionIfTrue: local:= false
+ $insideWhereIfTrue: local:= true
+-- if not $insideFunctorIfTrue then
+-- $originalTarget :=
+-- form is ['DEF,a,osig,:.] and osig is [otarget,:.] =>
+-- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and
+-- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and
+-- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) =>
+-- [ntarget,:rest osig]
+-- osig
+-- nil
+-- foobum exprList
+ e:= eInit
+ u:=
+ for item in exprList repeat
+ [.,.,e]:= comp(item,$EmptyMode,e) or return "failed"
+ u="failed" => return nil
+ $insideWhereIfTrue:= false
+ [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil
+ eFinal:=
+ del:= deltaContour(eAfter,eBefore) => addContour(del,eInit)
+ eInit
+ [x,m,eFinal]
+
+compMacro(form,m,e) ==
+ $macroIfTrue: local:= true
+ ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form
+ firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs]
+ markMacro(first lhs,rhs)
+ rhs :=
+ rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
+ rhs is ['Join,:.] => ['"-- the constructor category"]
+ rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"]
+ rhs is ['add,:.] => ['"-- the constructor capsule"]
+ formatUnabbreviated rhs
+ sayBrightly ['" processing macro definition",'%b,
+ :formatUnabbreviated lhs,'" ==> ",:rhs,'%d]
+ ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
+ m=$EmptyMode or m=$NoValueMode =>
+ ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)]
+
+--compMacro(form,m,e) ==
+-- $macroIfTrue: local:= true
+-- ["MDEF",lhs,signature,specialCases,rhs]:= form
+-- rhs :=
+-- rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
+-- rhs is ['Join,:.] => ['"-- the constructor category"]
+-- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"]
+-- rhs is ['add,:.] => ['"-- the constructor capsule"]
+-- formatUnabbreviated rhs
+-- sayBrightly ['" processing macro definition",'%b,
+-- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d]
+-- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
+-- m=$EmptyMode or m=$NoValueMode =>
+-- rhs := markMacro(lhs,rhs)
+-- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)]
+
+compSetq(oform,m,E) ==
+ ["LET",form,val] := oform
+ T := compSetq1(form,val,m,E) => markSetq(oform,T)
+ nil
+
+compSetq1(oform,val,m,E) ==
+ form := markKillAll oform
+ IDENTP form => setqSingle(form,val,m,E)
+ form is [":",x,y] =>
+ [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E)
+ compSetq(["LET",x,val],m,E')
+ form is [op,:l] =>
+ op="CONS" => setqMultiple(uncons form,val,m,E)
+ op="Tuple" => setqMultiple(l,val,m,E)
+ setqSetelt(oform,form,val,m,E)
+
+setqSetelt(oform,[v,:s],val,m,E) ==
+ T:= comp0(["setelt",:oform,val],m,E) or return nil
+---> -------
+ markComp(oform,T)
+
+setqSingle(id,val,m,E) ==
+ $insideSetqSingleIfTrue: local:= true
+ --used for comping domain forms within functions
+ currentProplist:= getProplist(id,E)
+ m'':= get(id,'mode,E) or getmode(id,E) or
+ (if m=$NoValueMode then $EmptyMode else m)
+-----------------------> new <-------------------------
+ trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E)
+-----------------------> new <-------------------------
+ T:=
+ (trialT and coerce(trialT,m'')) or eval or return nil where
+ eval() ==
+ T:= comp(val,m'',E) => T
+ not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and
+ (T:=comp(val,maxm'',E)) => T
+ (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) =>
+ assignError(val,T.mode,id,m'')
+ T':= [x,m',e']:= convert(T,m) or return nil
+ if $profileCompiler = true then
+ null IDENTP id => nil
+ key :=
+ MEMQ(id,rest $form) => 'arguments
+ 'locals
+ profileRecord(key,id,T.mode)
+ newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T)
+ e':= (PAIRP id => e'; addBinding(id,newProplist,e'))
+ x1 := markKillAll x
+ if isDomainForm(x1,e') then
+ if isDomainInScope(id,e') then
+ stackWarning ["domain valued variable","%b",id,"%d",
+ "has been reassigned within its scope"]
+ e':= augModemapsFromDomain1(id,x1,e')
+ --all we do now is to allocate a slot number for lhs
+ --e.g. the LET form below will be changed by putInLocalDomainReferences
+--+
+ if (k:=NRTassocIndex(id))
+ then
+ $markFreeStack := [id,:$markFreeStack]
+ form:=['SETELT,"$",k,x]
+ else form:=
+ $QuickLet => ["LET",id,x]
+ ["LET",id,x,
+ (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))]
+ [form,m',e']
+
+setqMultiple(nameList,val,m,e) ==
+ val is ["CONS",:.] and m=$NoValueMode =>
+ setqMultipleExplicit(nameList,uncons val,m,e)
+ val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e)
+ --1. create a gensym, %add to local environment, compile and assign rhs
+ g:= genVariable()
+ e:= addBinding(g,nil,e)
+ T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil
+ e:= put(g,"mode",m1,e)
+ [x,m',e]:= convert(T,m) or return nil
+ --1.1 exit if result is a list
+ m1 is ["List",D] =>
+ for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e)
+ convert([["PROGN",x,["LET",nameList,g],g],m',e],m)
+ --2. verify that the #nameList = number of parts of right-hand-side
+ selectorModePairs:=
+ --list of modes
+ decompose(m1,#nameList,e) or return nil where
+ decompose(t,length,e) ==
+ t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l]
+ comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] =>
+ [[name,:mode] for [":",name,mode] in l]
+ stackMessage ["no multiple assigns to mode: ",t]
+ #nameList^=#selectorModePairs =>
+ stackMessage [val," must decompose into ",#nameList," components"]
+ -- 3.generate code; return
+ assignList:=
+ [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr
+ for x in nameList for [y,:z] in selectorModePairs]
+ if assignList="failed" then NIL
+ else [MKPROGN [x,:assignList,g],m',e]
+
+setqMultipleExplicit(nameList,valList,m,e) ==
+ #nameList^=#valList =>
+ stackMessage ["Multiple assignment error; # of items in: ",nameList,
+ "must = # in: ",valList]
+ gensymList:= [genVariable() for name in nameList]
+ for g in gensymList for name in nameList repeat
+ e := put(g,"mode",get(name,"mode",e),e)
+ assignList:=
+ --should be fixed to declare genVar when possible
+ [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed"
+ for g in gensymList for val in valList for name in nameList]
+ assignList="failed" => nil
+ reAssignList:=
+ [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed"
+ for g in gensymList for name in nameList]
+ reAssignList="failed" => nil
+ T := [["PROGN",:[T.expr for T in assignList],
+ :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env]
+ markMultipleExplicit(nameList,valList,T)
+
+canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends
+ atom expr => ValueFlag and level=exitCount
+ (op:= first expr)="QUOTE" => ValueFlag and level=exitCount
+ MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag)
+ op="TAGGEDexit" =>
+ expr is [.,count,data] => canReturn(data.expr,level,count,count=level)
+ level=exitCount and not ValueFlag => nil
+ op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr]
+ op="TAGGEDreturn" => nil
+ op="CATCH" =>
+ [.,gs,data]:= expr
+ (findThrow(gs,data,level,exitCount,ValueFlag) => true) where
+ findThrow(gs,expr,level,exitCount,ValueFlag) ==
+ atom expr => nil
+ expr is ["THROW", =gs,data] => true
+ --this is pessimistic, but I know of no more accurate idea
+ expr is ["SEQ",:l] =>
+ or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l]
+ or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr]
+ canReturn(data,level,exitCount,ValueFlag)
+ op = "COND" =>
+ level = exitCount =>
+ or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr]
+ or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v]
+ for v in rest expr]
+ op="IF" =>
+ expr is [.,a,b,c]
+ if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then
+ SAY "IF statement can not cause consequents to be executed"
+ pp expr
+ canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag)
+ or canReturn(c,level,exitCount,ValueFlag)
+ --now we have an ordinary form
+ atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
+ op is ["XLAM",args,bods] =>
+ and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
+ systemErrorHere '"canReturn" --for the time being
+
+compList(l,m is ["List",mUnder],e) ==
+ markImport m
+ markImport mUnder
+ null l => [NIL,m,e]
+ Tl:= [[.,mUnder,e]:=
+ comp(x,mUnder,e) or return "failed" for i in 1.. for x in l]
+ Tl="failed" => nil
+ T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e]
+
+compVector(l,m is ["Vector",mUnder],e) ==
+ markImport m
+ markImport mUnder
+ null l => [$EmptyVector,m,e]
+ Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l]
+ Tl="failed" => nil
+ [["VECTOR",:[T.expr for T in Tl]],m,e]
+
+compColon([":",f,t],m,e) ==
+ $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e)
+ --if inside an expression, ":" means to convert to m "on faith"
+ f := markKillAll f
+ $lhsOfColon: local:= f
+ t:=
+ t := markKillAll t
+ atom t and (t':= ASSOC(t,getDomainsInScope e)) => t'
+ isDomainForm(t,e) and not $insideCategoryIfTrue =>
+ (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t)
+ isDomainForm(t,e) or isCategoryForm(t,e) => t
+ t is ["Mapping",m',:r] => t
+ unknownTypeError t
+ t
+ if $insideCapsuleFunctionIfTrue then markDeclaredImport t
+ f is ["LISTOF",:l] =>
+ (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T)
+ e:=
+ f is [op,:argl] and not (t is ["Mapping",:.]) =>
+ --for MPOLY--replace parameters by formal arguments: RDJ 3/83
+ newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList),
+ [(x is [":",a,m] => a; x) for x in argl],t)
+ signature:=
+ ["Mapping",newTarget,:
+ [(x is [":",a,m] => m;
+ getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]]
+ put(op,"mode",signature,e)
+ put(f,"mode",t,e)
+ if not $bootStrapMode and $insideFunctorIfTrue and
+ makeCategoryForm(t,e) is [catform,e] then
+ e:= put(f,"value",[genSomeVariable(),t,$noEnv],e)
+ ["/throwAway",getmode(f,e),e]
+
+compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T)
+
+compConstruct1(form is ["construct",:l],m,e) ==
+ y:= modeIsAggregateOf("List",m,e) =>
+ T:= compList(l,["List",CADR y],e) => convert(T,m)
+ y:= modeIsAggregateOf("Vector",m,e) =>
+ T:= compVector(l,["Vector",CADR y],e) => convert(T,m)
+ T:= compForm(form,m,e) => T
+ for D in getDomainsInScope e repeat
+ (y:=modeIsAggregateOf("List",D,e)) and
+ (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) =>
+ return T'
+ (y:=modeIsAggregateOf("Vector",D,e)) and
+ (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) =>
+ return T'
+
+compPretend(u := ["pretend",x,t],m,e) ==
+ t := markKillAll t
+ m := markKillAll m
+ e:= addDomain(t,e)
+ T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil
+ if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"]
+ T1:= [T.expr,t,T.env]
+ t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<--
+ T':= coerce(T1,m) =>
+ warningMessage =>
+ stackWarning warningMessage
+ markCompColonInside("@",T')
+ markPretend(T1,T')
+ nil
+
+compAtSign(["@",x,m'],m,e) ==
+ m' := markKillAll m'
+ m := markKillAll m
+ e:= addDomain(m',e)
+ T:= comp(x,m',e) or return nil
+ coerce(T,m)
+
+compColonInside(x,m,e,m') ==
+ m' := markKillAll m'
+ e:= addDomain(m',e)
+ T:= comp(x,$EmptyMode,e) or return nil
+ if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"]
+ T:= [T.expr,m',T.env]
+ m := markKillAll m
+ T':= coerce(T,m) =>
+ warningMessage =>
+ stackWarning warningMessage
+ markCompColonInside("@",T')
+ stackWarning [":",m'," -- should replace by pretend"]
+ markCompColonInside("pretend",T')
+ nil
+
+resolve(min, mout) ==
+ din := markKillAll min
+ dout := markKillAll mout
+ din=$NoValueMode or dout=$NoValueMode => $NoValueMode
+ dout=$EmptyMode => din
+ STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94
+ STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94
+ din^=dout and (STRINGP din or STRINGP dout) =>
+ modeEqual(dout,$String) => dout
+ modeEqual(din,$String) => nil
+ mkUnion(din,dout)
+ dout
+
+coerce(T,m) ==
+ T := [T.expr,markKillAll T.mode,T.env]
+ m := markKillAll m
+ if not get(m, 'isLiteral,T.env) then markImport m
+ $InteractiveMode =>
+ keyedSystemError("S2GE0016",['"coerce",
+ '"function coerce called from the interpreter."])
+--==================> changes <======================
+--The following line is inappropriate for our needs:::
+--rplac(CADR T,substitute("$",$Rep,CADR T))
+ T' := coerce0(T,m) => T'
+ T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env]
+--==================> changes <======================
+ coerce0(T,m)
+
+coerce0(T,m) ==
+ T':= coerceEasy(T,m) => T'
+ T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET)
+ T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD)
+ T':= coerceExtraHard(T,m) => T'
+ T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil
+ T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP)
+ stackMessage fn(T.expr,T.mode,m) where
+ -- if from from coerceable, this coerce was just a trial coercion
+ -- from compFormWithModemap to filter through the modemaps
+ fn(x,m1,m2) ==
+ ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l",
+ " to mode","%b",m2,"%d"]
+
+coerceSubset(T := [x,m,e],m') ==
+ m = $SmallInteger =>
+ m' = $Integer => [x,m',e]
+ m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e]
+ nil
+-- pp [m, m']
+ isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e]
+ m is ['SubDomain,=m',:.] => [x,m',e]
+ (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and
+ -- obviously this is temporary
+ eval substitute(x,"#1",pred) => [x,m',e]
+ (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary
+ and eval substitute(x,"*",pred) =>
+ [x,m',e]
+ nil
+
+coerceRep(T,m) ==
+ md := T.mode
+ atom md => nil
+ CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or
+ CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T
+ nil
+
+--- GET rid of XLAMs
+spadCompileOrSetq form ==
+ --bizarre hack to take account of the existence of "known" functions
+ --good for performance (LISPLLIB size, BPI size, NILSEC)
+ [nam,[lam,vl,body]] := form
+ CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"]
+ if vl is [:vl',E] and body is [nam',: =vl'] then
+ LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam']
+ sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam']
+ else if (ATOM body or and/[ATOM x for x in body])
+ and vl is [:vl',E] and not CONTAINED(E,body) then
+ macform := ['XLAM,vl',body]
+ LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform]
+ sayBrightly ['" ",:bright nam,'"is replaced by",:bright body]
+ $insideCapsuleFunctionIfTrue => first COMP LIST form
+ compileConstructor form
+
+coerceHard(T,m) ==
+ $e: local:= T.env
+ m':= T.mode
+ STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e]
+ modeEqual(m',m) or
+ (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and
+ modeEqual(m'',m) or
+ (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and
+ modeEqual(m'',m') => [T.expr,m,T.env]
+ STRINGP T.expr and T.expr=m => [T.expr,m,$e]
+ isCategoryForm(m,$e) =>
+ $bootStrapMode = true => [T.expr,m,$e]
+ extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e]
+ nil
+ nil
+
+coerceExtraHard(T is [x,m',e],m) ==
+ T':= autoCoerceByModemap(T,m) => T'
+ isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and
+ member(t,l) and (T':= autoCoerceByModemap(T,t)) and
+ (T'':= coerce(T',m)) => T''
+ m' is ['Record,:.] and m = $Expression =>
+ [['coerceRe2E,x,['ELT,COPY m',0]],m,e]
+ nil
+
+compCoerce(u := ["::",x,m'],m,e) ==
+ m' := markKillAll m'
+ e:= addDomain(m',e)
+ m := markKillAll m
+--------------> new code <-------------------
+ T:= compCoerce1(x,m',e) => coerce(T,m)
+ T := comp(x,$EmptyMode,e) or return nil
+ T.mode = $SmallInteger and
+ MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) =>
+ compCoerce(["::",["::",x,$Integer],m'],m,e)
+--------------> new code <-------------------
+ getmode(m',e) is ["Mapping",["UnionCategory",:l]] =>
+ l := [markKillAll x for x in l]
+ T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil
+ coerce([T.expr,m',T.env],m)
+
+compCoerce1(x,m',e) ==
+ T:= comp(x,m',e)
+ if null T then T := comp(x,$EmptyMode,e)
+ null T => return nil
+ m1:=
+ STRINGP T.mode => $String
+ T.mode
+ m':=resolve(m1,m')
+ T:=[T.expr,m1,T.env]
+ T':= coerce(T,m') => T'
+ T':= coerceByModemap(T,m') => T'
+ pred:=isSubset(m',T.mode,e) =>
+ gg:=GENSYM()
+ pred:= substitute(gg,"*",pred)
+ code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]]
+ [code,m',T.env]
+
+coerceByModemap([x,m,e],m') ==
+--+ modified 6/27 for new runtime system
+ u:=
+ [modemap
+ for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t,
+ s] and (modeEqual(t,m') or isSubset(t,m',e))
+ and (modeEqual(s,m) or isSubset(m,s,e))] or return nil
+ mm:=first u -- patch for non-trival conditons
+ fn := genDeltaEntry ['coerce,:mm]
+ T := [["call",fn,x],m',e]
+ markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil)
+
+autoCoerceByModemap([x,source,e],target) ==
+ u:=
+ [cexpr
+ for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [
+ .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil
+ fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
+ markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true)
+
+--======================================================================
+-- From compiler.boot
+--======================================================================
+--comp3x(x,m,$e) ==
+
+comp3(x,m,$e) ==
+ --returns a Triple or %else nil to signalcan't do'
+ $e:= addDomain(m,$e)
+ e:= $e --for debugging purposes
+ m is ["Mapping",:.] => compWithMappingMode(x,m,e)
+ m is ["QUOTE",a] => (x=a => [x,m,$e]; nil)
+ STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil)
+ ^x or atom x => compAtom(x,m,e)
+ op:= first x
+ getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u
+ op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e)
+ op=":" => compColon(x,m,e)
+ op="::" => compCoerce(x,m,e)
+ not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) =>
+ compTypeOf(x,m,e)
+ ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)--
+ x is ['PART,:.] => compPART(x,m,e)
+ ----------------------------------
+ t:= qt(14,compExpression(x,m,e))
+ t is [x',m',e'] and not member(m',getDomainsInScope e') =>
+ qt(15,[x',m',addDomain(m',e')])
+ qt(16,t)
+
+yyyyy x == x
+compExpression(x,m,e) ==
+ $insideExpressionIfTrue: local:= true
+ if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x
+ x := compRenameOp x
+ atom first x and (fn:= GETL(first x,"SPECIAL")) =>
+ FUNCALL(fn,x,m,e)
+ compForm(x,m,e)
+
+compRenameOp x == ----------> new 12/3/94
+ x is [op,:r] and op is ['PART,.,op1] =>
+ [op1,:r]
+ x
+
+compCase(["case",x,m1],m,e) ==
+ m' := markKillAll m1
+ e:= addDomain(m',e)
+ T:= compCase1(x,m',e) => coerce(T,m)
+ nil
+
+compCase1(x,m,e) ==
+ x1 :=
+ x is ['PART,.,a] => a
+ x
+ [x',m',e']:= comp(x1,$EmptyMode,e) or return nil
+ if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true)
+ --------------------------------------------------------------------------
+ m' isnt ['Union,:r] => nil
+ mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e')
+ | map is [.,.,s,t] and modeEqual(t,m) and
+ (modeEqual(s,m') or switchMode and modeEqual(s,"$"))]
+ or return nil
+ u := [cexpr for [.,cexpr] in mml]
+ fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
+ tag := genCaseTag(m, r, 1) or return nil
+ x1 :=
+ switchMode => markRepper('rep, x)
+ x
+ markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e']))
+
+genCaseTag(t,l,n) ==
+ l is [x, :l] =>
+ x = t =>
+ STRINGP x => INTERN x
+ INTERN STRCONC("value", STRINGIMAGE n)
+ x is ["::",=t,:.] => t
+ STRINGP x => genCaseTag(t, l, n)
+ genCaseTag(t, l, n + 1)
+ nil
+
+compIf(["IF",aOrig,b,c],m,E) ==
+ a := markKillButIfs aOrig
+ [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil
+ [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil
+ [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil
+ xb':= coerce(Tb,mc) or return nil
+ x:= ["IF",xa,quotify xb'.expr,quotify xc]
+ (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where
+ Env(bEnv,cEnv,b,c,E) ==
+ canReturn(b,0,0,true) =>
+ (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv)
+ canReturn(c,0,0,true) => cEnv
+ E
+ [x,mc,returnEnv]
+
+compBoolean(p,pWas,m,Einit) ==
+ op := opOf p
+ [p',m,E]:=
+ fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) =>
+ APPLY(fop,[p,pWas,m,Einit]) or return nil
+ T := comp(p,m,Einit) or return nil
+ markAny('compBoolean,pWas,T)
+ [p',m,getSuccessEnvironment(markKillAll p,E),
+ getInverseEnvironment(markKillAll p,E)]
+
+compAnd([op,:args], pWas, m, e) ==
+--called ONLY from compBoolean
+ cargs := [T.expr for x in args
+ | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil]
+ null cargs => nil
+ coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m)
+
+compOr([op,:args], pWas, m, e) ==
+--called ONLY from compBoolean
+ cargs := [T.expr for x in args
+ | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil]
+ null cargs => nil
+ coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m)
+
+compNot([op,arg], pWas, m, e) ==
+--called ONLY from compBoolean
+ [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil
+ coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m)
+
+compDefine(form,m,e) ==
+ $tripleHits: local:= 0
+ $macroIfTrue: local
+ $packagesUsed: local
+ ['DEF,.,originalSignature,.,body] := form
+ if not $insideFunctorIfTrue then
+ $originalBody := COPY body
+ compDefine1(form,m,e)
+
+compDefine1(form,m,e) ==
+ $insideExpressionIfTrue: local:= false
+ --1. decompose after macro-expanding form
+ ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
+ $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode)
+ => [lhs,m,put(first lhs,'macro,rhs,e)]
+ null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and
+ (sig:= getSignatureFromMode(lhs,e)) =>
+ -- here signature of lhs is determined by a previous declaration
+ compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e)
+ if signature.target=$Category then $insideCategoryIfTrue:= true
+ if signature.target is ['Mapping,:map] then
+ signature:= map
+ form:= ['DEF,lhs,signature,specialCases,rhs]
+
+
+-- RDJ (11/83): when argument and return types are all declared,
+-- or arguments have types declared in the environment,
+-- and there is no existing modemap for this signature, add
+-- the modemap by a declaration, then strip off declarations and recurse
+ e := compDefineAddSignature(lhs,signature,e)
+-- 2. if signature list for arguments is not empty, replace ('DEF,..) by
+-- ('where,('DEF,..),..) with an empty signature list;
+-- otherwise, fill in all NILs in the signature
+ not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e)
+ signature.target=$Category =>
+ compDefineCategory(form,m,e,nil,$formalArgList)
+ isDomainForm(rhs,e) and not $insideFunctorIfTrue =>
+ if null signature.target then signature:=
+ [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),:
+ rest signature]
+ rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs)
+ compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil,
+ $formalArgList)
+ null $form => stackAndThrow ['"bad == form ",form]
+ newPrefix:=
+ $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op)
+ getAbbreviation($op,#rest $form)
+ compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList)
+
+compDefineCategory(df,m,e,prefix,fal) ==
+ $domainShell: local -- holds the category of the object being compiled
+ $lisplibCategory: local
+ not $insideFunctorIfTrue and $LISPLIB =>
+ compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1)
+ compDefineCategory1(df,m,e,prefix,fal)
+
+compDefineCategory1(df,m,e,prefix,fal) ==
+ $DEFdepth : local := 0 --for conversion to new compiler 3/93
+ $capsuleStack : local := nil --for conversion to new compiler 3/93
+ $predicateStack:local := nil --for conversion to new compiler 3/93
+ $signatureStack:local := nil --for conversion to new compiler 3/93
+ $importStack : local := nil --for conversion to new compiler 3/93
+ $globalImportStack : local := nil --for conversion to new compiler 3/93
+ $catAddForm : local := nil --for conversion to new compiler 2/95
+ $globalDeclareStack : local := nil
+ $globalImportDefAlist: local:= nil
+ $localMacroStack : local := nil --for conversion to new compiler 3/93
+ $freeStack : local := nil --for conversion to new compiler 3/93
+ $domainLevelVariableList: local := nil--for conversion to new compiler 3/93
+ $categoryTranForm : local := nil --for conversion to new compiler 10/93
+ ['DEF,form,sig,sc,body] := df
+ body := markKillAll body --these parts will be replaced by compDefineLisplib
+ categoryCapsule :=
+--+
+ body is ['add,cat,capsule] =>
+ body := cat
+ capsule
+ nil
+ [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal)
+--+ next two lines
+-- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil
+-- else
+ if categoryCapsule and not $bootStrapMode then
+ [.,.,e] :=
+ $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1
+ $categoryPredicateList: local :=
+ makeCategoryPredicates(form,$lisplibCategory)
+ defform := mkCategoryPackage(form,cat,categoryCapsule)
+ ['DEF,[.,arg,:.],:.] := defform
+ $categoryNameForDollar :local := arg
+ compDefine1(defform,$EmptyMode,e)
+ else
+ [body,T] := $categoryTranForm
+ markFinish(body,T)
+
+ [d,m,e]
+
+compDefineCategory2(form,signature,specialCases,body,m,e,
+ $prefix,$formalArgList) ==
+ --1. bind global variables
+ $insideCategoryIfTrue: local:= true
+ $TOP__LEVEL: local
+ $definition: local
+ --used by DomainSubstitutionFunction
+ $form: local
+ $op: local
+ $extraParms: local
+ --Set in DomainSubstitutionFunction, used further down
+-- 1.1 augment e to add declaration $: <form>
+ [$op,:argl]:= $definition:= form
+ e:= addBinding("$",[['mode,:$definition]],e)
+
+-- 2. obtain signature
+ signature':=
+ [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]]
+ e:= giveFormalParametersValues(argl,e)
+
+-- 3. replace arguments by $1,..., substitute into body,
+-- and introduce declarations into environment
+ sargl:= TAKE(# argl, $TriangleVariableList)
+ $functorForm:= $form:= [$op,:sargl]
+ $formalArgList:= [:sargl,:$formalArgList]
+ aList:= [[a,:sa] for a in argl for sa in sargl]
+ formalBody:= SUBLIS(aList,body)
+ signature' := SUBLIS(aList,signature')
+--Begin lines for category default definitions
+ $functionStats: local:= [0,0]
+ $functorStats: local:= [0,0]
+ $frontier: local := 0
+ $getDomainCode: local := nil
+ $addForm: local:= nil
+ for x in sargl for t in rest signature' repeat
+ [.,.,e]:= compMakeDeclaration([":",x,t],m,e)
+
+-- 4. compile body in environment of %type declarations for arguments
+ op':= $op
+ -- following line causes cats with no with or Join to be fresh copies
+ if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then
+ formalBody := ['Join, formalBody]
+ T := compOrCroak(formalBody,signature'.target,e)
+--------------------> new <-------------------
+ $catAddForm :=
+ $originalBody is ['add,y,:.] => y
+ $originalBody
+ $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]]
+--------------------> new <-------------------
+ body:= optFunctorBody markKillAll T.expr
+ if $extraParms then
+ formals:=actuals:=nil
+ for u in $extraParms repeat
+ formals:=[CAR u,:formals]
+ actuals:=[MKQ CDR u,:actuals]
+ body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body]
+ if argl then body:= -- always subst for args after extraparms
+ ['sublisV,['PAIR,['QUOTE,sargl],['LIST,:
+ [['devaluate,u] for u in sargl]]],body]
+ body:=
+ ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]]
+ fun:= compile [op',['LAM,sargl,body]]
+
+-- 5. give operator a 'modemap property
+ pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList]
+ parSignature:= SUBLIS(pairlis,signature')
+ parForm:= SUBLIS(pairlis,form)
+---- lisplibWrite('"compilerInfo",
+---- ['SETQ,'$CategoryFrame,
+---- ['put,['QUOTE,op'],'
+---- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm,
+---- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile)
+ --Equivalent to the following two lines, we hope
+ if null sargl then
+ evalAndRwriteLispForm('NILADIC,
+ ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true])
+
+-- 6. put modemaps into InteractiveModemapFrame
+ $domainShell :=
+ BOUNDP '$convertingSpadFile and $convertingSpadFile => nil
+ eval [op',:MAPCAR('MKQ,sargl)]
+ $lisplibCategory:= formalBody
+---- if $LISPLIB then
+---- $lisplibForm:= form
+---- $lisplibKind:= 'category
+---- modemap:= [[parForm,:parSignature],[true,op']]
+---- $lisplibModemap:= modemap
+---- $lisplibCategory:= formalBody
+---- form':=[op',:sargl]
+---- augLisplibModemapsFromCategory(form',formalBody,signature')
+ [fun,'(Category),e]
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}