diff --git a/changelog b/changelog index 61e7cf8..7cfd12c 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090904 tpd src/axiom-website/patches.html 20090904.02.tpd.patch +20090904 tpd src/interp/Makefile move wi1.boot to wi1.lisp +20090904 tpd src/interp/wi1.lisp added, rewritten from wi1.boot +20090904 tpd src/interp/wi1.boot removed, rewritten to wi1.lisp 20090904 tpd src/axiom-website/patches.html 20090904.01.tpd.patch 20090904 tpd src/interp/Makefile move pspad2.boot to pspad2.lisp 20090904 tpd src/interp/pspad2.lisp added, rewritten from pspad2.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 907db83..e7006a6 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1986,5 +1986,7 @@ src/interp/topics.lisp rewrite from boot to lisp
src/interp/pspad1.lisp rewrite from boot to lisp
20090904.01.tpd.patch src/interp/pspad2.lisp rewrite from boot to lisp
+20090904.02.tpd.patch +src/interp/wi1.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index ee6ec60..c58c3c2 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -4046,34 +4046,24 @@ ${MID}/interop.lisp: ${IN}/interop.lisp.pamphlet @ \subsection{wi1.boot} -translate files <>= -${AUTO}/wi1.${O}: ${MID}/wi1.clisp - @ echo 592 making ${AUTO}/wi1.${O} from ${MID}/wi1.clisp +${AUTO}/wi1.${O}: ${MID}/wi1.lisp + @ echo 598 making ${AUTO}/wi1.${O} from ${MID}/wi1.lisp @ (cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/wi1.clisp"' \ + echo '(progn (compile-file "${MID}/wi1.lisp"' \ ':output-file "${AUTO}/wi1.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/wi1.clisp"' \ + echo '(progn (compile-file "${MID}/wi1.lisp"' \ ':output-file "${AUTO}/wi1.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/wi1.clisp: ${IN}/wi1.boot.pamphlet - @ echo 593 making ${MID}/wi1.clisp from ${IN}/wi1.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/wi1.boot.pamphlet >wi1.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "wi1.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "wi1.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm wi1.boot ) +<>= +${MID}/wi1.lisp: ${IN}/wi1.lisp.pamphlet + @ echo 599 making ${MID}/wi1.lisp from ${IN}/wi1.lisp.pamphlet + @ ${TANGLE} ${IN}/wi1.lisp.pamphlet >${MID}/wi1.lisp @ @@ -4746,7 +4736,7 @@ clean: <> <> -<> +<> <> <> diff --git a/src/interp/wi1.boot.pamphlet b/src/interp/wi1.boot.pamphlet deleted file mode 100644 index 8b9c152..0000000 --- a/src/interp/wi1.boot.pamphlet +++ /dev/null @@ -1,1282 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp wi1.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - --- !! 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:= GET(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) == - $tripleCache: local:= nil - $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 $:
- [$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} diff --git a/src/interp/wi1.lisp.pamphlet b/src/interp/wi1.lisp.pamphlet new file mode 100644 index 0000000..6455eeb --- /dev/null +++ b/src/interp/wi1.lisp.pamphlet @@ -0,0 +1,5667 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp wi1.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;-- !! do not delete the next function ! +;spad2AsTranslatorAutoloadOnceTrigger() == nil + +(DEFUN |spad2AsTranslatorAutoloadOnceTrigger| () NIL) + +;pairList(u,v) == [[x,:y] for x in u for y in v] + +;;; *** |pairList| REDEFINED + +(DEFUN |pairList| (|u| |v|) + (PROG () + (RETURN + (SEQ (PROG (G166065) + (SPADLET G166065 NIL) + (RETURN + (DO ((G166071 |u| (CDR G166071)) (|x| NIL) + (G166072 |v| (CDR G166072)) (|y| NIL)) + ((OR (ATOM G166071) + (PROGN (SETQ |x| (CAR G166071)) NIL) + (ATOM G166072) + (PROGN (SETQ |y| (CAR G166072)) NIL)) + (NREVERSE0 G166065)) + (SEQ (EXIT (SETQ G166065 + (CONS (CONS |x| |y|) G166065))))))))))) + +;--====================================================================== +;-- 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 + +;;; *** |tr| REDEFINED + +(DEFUN |tr| (|fn|) + (PROG (|$convertingSpadFile| |$options| |$outStream| |sfn| |newname|) + (DECLARE (SPECIAL |$convertingSpadFile| |$options| |$outStream|)) + (RETURN + (PROGN + (SPADLET |$convertingSpadFile| 'T) + (SPADLET |$options| NIL) + (SPADLET |sfn| (STRINGIMAGE |fn|)) + (SPADLET |newname| (STRCONC |sfn| (MAKESTRING ".as"))) + (SPADLET |$outStream| (MAKE-OUTSTREAM |newname|)) + (|markSay| (MAKESTRING "#pile")) + (|markSay| (MAKESTRING "#include \"axiom.as\"")) + (|markTerpri|) + (CATCH 'SPAD_READER (|compiler| (CONS (INTERN |sfn|) NIL))) + (SHUT |$outStream|))))) + +;stackMessage msg == +;--if msg isnt ["cannot coerce: ",:.] then foobum msg +; $compErrorMessageStack:= [msg,:$compErrorMessageStack] +; nil + +;;; *** |stackMessage| REDEFINED + +(DEFUN |stackMessage| (|msg|) + (declare (special |$compErrorMessageStack|)) + (PROGN + (SPADLET |$compErrorMessageStack| + (CONS |msg| |$compErrorMessageStack|)) + NIL)) + +;ppFull x == +; _*PRINT_-LEVEL_* : local := nil +; _*PRINT_-DEPTH_* : local := nil +; _*PRINT_-LENGTH_* : local := nil +; pp x + +(DEFUN |ppFull| (|x|) + (PROG (*PRINT-LEVEL* *PRINT-DEPTH* *PRINT-LENGTH*) + (RETURN + (PROGN + (SPADLET *PRINT-LEVEL* NIL) + (SPADLET *PRINT-DEPTH* NIL) + (SPADLET *PRINT-LENGTH* 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) + +(DEFUN |put| (|x| |prop| |val| |e|) + (PROG (|newProplist|) + (declare (special |$InteractiveMode| |$CategoryFrame| + |$insideCapsuleFunctionIfTrue| |$CapsuleModemapFrame|)) + (RETURN + (COND + ((AND |$InteractiveMode| (NULL (EQ |e| |$CategoryFrame|))) + (|putIntSymTab| |x| |prop| |val| |e|)) + ((NULL (ATOM |x|)) (|put| (CAR |x|) |prop| |val| |e|)) + ('T + (SPADLET |newProplist| (|augProplistOf| |x| |prop| |val| |e|)) + (COND + ((AND (BOOT-EQUAL |prop| '|modemap|) + (BOOT-EQUAL |$insideCapsuleFunctionIfTrue| 'T)) + (SAY (CONS (MAKESTRING + "**** modemap PUT on CapsuleModemapFrame: ") + (CONS |val| NIL))) + (SPADLET |$CapsuleModemapFrame| + (|addBinding| |x| + (|augProplistOf| |x| '|modemap| |val| + |$CapsuleModemapFrame|) + |$CapsuleModemapFrame|)) + |e|) + ('T (|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] + +;;; *** |addBinding| REDEFINED + +(DEFUN |addBinding| (|var| |proplist| |e|) + (PROG (|tailContour| |tailEnv| |ISTMP#1| |curContour| |lx|) + (RETURN + (PROGN + (SPADLET |curContour| (CAAR |e|)) + (SPADLET |tailContour| (CDAR |e|)) + (SPADLET |tailEnv| (CDR |e|)) + (COND + ((EQ |proplist| (|getProplist| |var| |e|)) |e|) + (|$InteractiveMode| + (|addBindingInteractive| |var| |proplist| |e|)) + ('T + (COND + ((AND (PAIRP |curContour|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |curContour|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |var|)))) + (SPADLET |curContour| (CDR |curContour|)))) + (SPADLET |lx| (CONS |var| |proplist|)) + (CONS (CONS (CONS |lx| |curContour|) |tailContour|) + |tailEnv|))))))) + +;--====================================================================== +;-- 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) + +(DEFUN |compJoin,getParms| (|y| |e|) + (PROG (|ISTMP#1| |y'|) + (RETURN + (SEQ (IF (ATOM |y|) + (EXIT (SEQ (IF (|isDomainForm| |y| |e|) + (EXIT (LIST |y|))) + (EXIT NIL)))) + (IF (AND (PAIRP |y|) (EQ (QCAR |y|) 'LENGTH) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y'| (QCAR |ISTMP#1|)) 'T)))) + (EXIT (CONS |y| (CONS |y'| NIL)))) + (EXIT (LIST |y|)))))) + +(DEFUN |compJoin| (G166187 |m| |e|) + (PROG (|argl| |catList| |ISTMP#1| |pl| |ISTMP#2| |body| + |parameters| |catList'| T$) + (declare (special |$Category|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G166187) '|Join|) (CAR G166187))) + (SPADLET |argl| (CDR G166187)) + (SPADLET |catList| + (PROG (G166207) + (SPADLET G166207 NIL) + (RETURN + (DO ((G166212 |argl| (CDR G166212)) + (|x| NIL)) + ((OR (ATOM G166212) + (PROGN + (SETQ |x| (CAR G166212)) + NIL)) + (NREVERSE0 G166207)) + (SEQ (EXIT (SETQ G166207 + (CONS + (CAR + (OR + (|compForMode| |x| + |$Category| |e|) + (RETURN '|failed|))) + G166207)))))))) + (COND + ((BOOT-EQUAL |catList| '|failed|) + (|stackSemanticError| + (CONS '|cannot form Join of: | (CONS |argl| NIL)) + NIL)) + ('T + (SPADLET |catList'| + (PROG (G166231) + (SPADLET G166231 NIL) + (RETURN + (DO ((G166245 |catList| (CDR G166245)) + (|x| NIL)) + ((OR (ATOM G166245) + (PROGN + (SETQ |x| (CAR G166245)) + NIL)) + (NREVERSE0 G166231)) + (SEQ (EXIT + (SETQ G166231 + (CONS + (PROGN + (SPADLET |x| + (|markKillAll| |x|)) + (COND + ((|isCategoryForm| |x| |e|) + (SPADLET |parameters| + (|union| + (PROG (G166251) + (SPADLET G166251 NIL) + (RETURN + (DO + ((G166256 + (CDR |x|) + (CDR G166256)) + (|y| NIL)) + ((OR + (ATOM G166256) + (PROGN + (SETQ |y| + (CAR G166256)) + NIL)) + G166251) + (SEQ + (EXIT + (SETQ G166251 + (APPEND + G166251 + (|compJoin,getParms| + |y| |e|)))))))) + |parameters|)) + |x|) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|DomainSubstitutionMacro|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pl| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |parameters| + (|union| |pl| + |parameters|)) + |body|) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|mkCategory|)) + |x|) + ((AND (ATOM |x|) + (BOOT-EQUAL + (|getmode| |x| |e|) + |$Category|)) + |x|) + ('T + (|stackSemanticError| + (CONS + '|invalid argument to Join: | + (CONS |x| NIL)) + NIL) + |x|))) + G166231)))))))) + (SPADLET T$ + (CONS (|wrapDomainSub| |parameters| + (CONS '|Join| |catList'|)) + (CONS |$Category| (CONS |e| NIL)))) + (|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) + +(DEFUN |compDefineFunctor| (|dfOriginal| |m| |e| |prefix| |fal|) + (PROG (|$domainShell| |$profileCompiler| |$profileAlist| |df|) + (DECLARE (SPECIAL |$domainShell| |$profileCompiler| + |$profileAlist|)) + (RETURN + (PROGN + (SPADLET |df| (|markInsertParts| |dfOriginal|)) + (SPADLET |$domainShell| NIL) + (SPADLET |$profileCompiler| 'T) + (SPADLET |$profileAlist| NIL) + (COND + ($LISPLIB + (|compDefineLisplib| |df| |m| |e| |prefix| |fal| + '|compDefineFunctor1|)) + ('T (|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 + +(DEFUN |compDefineLisplib| (|df| |m| |e| |prefix| |fal| |fn|) + (PROG ($LISPLIB |$op| |$lisplibAttributes| |$lisplibPredicates| + |$lisplibCategoriesExtended| |$lisplibForm| |$lisplibKind| + |$lisplibModemap| |$lisplibModemapAlist| |$lisplibSlot1| + |$lisplibOperationAlist| |$lisplibSuperDomain| |$libFile| + |$lisplibVariableAlist| |$lisplibRelatedDomains| + |$lisplibCategory| |op| |libName| |res|) + (DECLARE (SPECIAL $LISPLIB |$op| |$lisplibAttributes| + |$lisplibPredicates| |$lisplibCategoriesExtended| + |$lisplibForm| |$lisplibKind| |$lisplibModemap| + |$lisplibModemapAlist| |$lisplibSlot1| + |$lisplibOperationAlist| |$lisplibSuperDomain| + |$libFile| |$lisplibVariableAlist| + |$compileDocumentation| + |$lisplibRelatedDomains| |$lisplibCategory|)) + (RETURN + (PROGN + (COND ((EQ (CAR |df|) 'DEF) (CAR |df|))) + (SPADLET |op| (CAADR |df|)) + (|sayMSG| (|fillerSpaces| 72 (MAKESTRING "-"))) + (SPADLET $LISPLIB 'T) + (SPADLET |$op| |op|) + (SPADLET |$lisplibAttributes| NIL) + (SPADLET |$lisplibPredicates| NIL) + (SPADLET |$lisplibCategoriesExtended| NIL) + (SPADLET |$lisplibForm| NIL) + (SPADLET |$lisplibKind| NIL) + (SPADLET |$lisplibModemap| NIL) + (SPADLET |$lisplibModemapAlist| NIL) + (SPADLET |$lisplibSlot1| NIL) + (SPADLET |$lisplibOperationAlist| NIL) + (SPADLET |$lisplibSuperDomain| NIL) + (SPADLET |$libFile| NIL) + (SPADLET |$lisplibVariableAlist| NIL) + (SPADLET |$lisplibRelatedDomains| NIL) + (SPADLET |$lisplibCategory| NIL) + (SPADLET |libName| (|getConstructorAbbreviation| |op|)) + (COND + ((AND (BOUNDP '|$compileDocumentation|) + |$compileDocumentation|) + (|compileDocumentation| |libName|)) + ('T + (|sayMSG| + (CONS (MAKESTRING " initializing ") + (CONS |$spadLibFT| + (APPEND (|bright| |libName|) + (CONS (MAKESTRING "for") + (|bright| |op|)))))) + (|initializeLisplib| |libName|) + (|sayMSG| + (CONS (MAKESTRING " compiling into ") + (CONS |$spadLibFT| (|bright| |libName|)))) + (SPADLET |res| (FUNCALL |fn| |df| |m| |e| |prefix| |fal|)) + (|sayMSG| + (CONS (MAKESTRING " finalizing ") + (CONS |$spadLibFT| (|bright| |libName|)))) + (FRESH-LINE |$algebraOutputStream|) + (|sayMSG| (|fillerSpaces| 72 (MAKESTRING "-"))) + (|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) + +(DEFUN |compTopLevel| (|x| |m| |e|) + (PROG (|$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| |$forceAdd| + |$compTimeSum| |$resolveTimeSum| |$packagesUsed| + |$originalTarget| |compFun| |a| |def| |ISTMP#3| |target| + |ISTMP#1| |ISTMP#2| |LETTMP#1| |val| |mode|) + (DECLARE (SPECIAL |$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| + |$forceAdd| |$compTimeSum| |$resolveTimeSum| + |$packagesUsed| |$originalTarget|)) + (RETURN + (PROGN + (SPADLET |$NRTderivedTargetIfTrue| NIL) + (SPADLET |$killOptimizeIfTrue| NIL) + (SPADLET |$forceAdd| NIL) + (SPADLET |$compTimeSum| 0) + (SPADLET |$resolveTimeSum| 0) + (SPADLET |$packagesUsed| NIL) + (SPADLET |compFun| + (COND + ((BOOT-EQUAL |$newCompAtTopLevel| 'T) '|newComp|) + ('T '|compOrCroak|))) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|where|)) + (SPADLET |x| (|markWhereTran| |x|)))) + (SPADLET |def| + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|where|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + 'T)))) + |a|) + ('T |x|))) + (SPADLET |$originalTarget| + (COND + ((AND (PAIRP |def|) (EQ (QCAR |def|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |def|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#3|)) + 'T)))))))) + |target|) + ('T '|sorry|))) + (COND + ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF)) + (AND (PAIRP |x|) (EQ (QCAR |x|) '|where|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'DEF))))))) + (SPADLET |LETTMP#1| (FUNCALL |compFun| |x| |m| |e|)) + (SPADLET |val| (CAR |LETTMP#1|)) + (SPADLET |mode| (CADR |LETTMP#1|)) + (CONS |val| (CONS |mode| (CONS |e| NIL)))) + ('T (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 + +(DEFUN |markWhereTran| (G166613) + (PROG (|form| |sig| |clist| |tail| |ISTMP#5| |n| |ISTMP#6| |x| |l| + |items| |op| |argl| |target| |atypeList| |a| |b| |r| + |decls| |key| |fn| |ISTMP#3| |q| |ISTMP#4| |bd| |ttype| + |body| |macros| |t| |p| |nargtypes| |nform| |ntarget| + |ndef| |ISTMP#1| |ISTMP#2| |e| |m| |mpart| |result|) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G166613) '|where|) (CAR G166613))) + (COND ((EQ (CAADR G166613) 'DEF) (CAADR G166613))) + (SPADLET |form| (CADADR G166613)) + (SPADLET |sig| (CAR (CDDADR G166613))) + (SPADLET |clist| (CADR (CDDADR G166613))) + (SPADLET |body| (CADDR (CDDADR G166613))) + (SPADLET |tail| (CDDR G166613)) + (SPADLET |items| + (COND + ((AND (PAIRP |tail|) (EQ (QCDR |tail|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |tail|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'SEQ) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (REVERSE |ISTMP#2|)) + 'T) + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCAR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCAR |ISTMP#4|) + '|exit|) + (PROGN + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |n| + (QCAR |ISTMP#5|)) + (SPADLET |ISTMP#6| + (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCDR |ISTMP#6|) + NIL) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#6|)) + 'T))))))) + (PROGN + (SPADLET |l| + (QCDR |ISTMP#3|)) + 'T) + (PROGN + (SPADLET |l| (NREVERSE |l|)) + 'T)))))) + (APPEND |l| (CONS |x| NIL))) + ('T (CONS (CAR |tail|) NIL)))) + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |target| (CAR |sig|)) + (SPADLET |atypeList| (CDR |sig|)) + (SPADLET |decls| + (PROG (G166701) + (SPADLET G166701 NIL) + (RETURN + (DO ((G166708 |argl| (CDR G166708)) + (|a| NIL) + (G166709 |atypeList| (CDR G166709)) + (|b| NIL)) + ((OR (ATOM G166708) + (PROGN + (SETQ |a| (CAR G166708)) + NIL) + (ATOM G166709) + (PROGN + (SETQ |b| (CAR G166709)) + NIL)) + (NREVERSE0 G166701)) + (SEQ (EXIT (COND + (|b| + (SETQ G166701 + (CONS + (CONS '|:| + (CONS |a| (CONS |b| NIL))) + G166701)))))))))) + (DO ((G166744 |items| (CDR G166744)) (|x| NIL)) + ((OR (ATOM G166744) + (PROGN (SETQ |x| (CAR G166744)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((AND (PAIRP |a|) + (EQ (QCAR |a|) 'LISTOF) + (PROGN + (SPADLET |r| (QCDR |a|)) + 'T)) + (DO ((G166753 |r| (CDR G166753)) + (|y| NIL)) + ((OR (ATOM G166753) + (PROGN + (SETQ |y| (CAR G166753)) + NIL)) + NIL) + (SEQ (EXIT + (SPADLET |decls| + (CONS + (CONS '|:| + (CONS |y| (CONS |b| NIL))) + |decls|)))))) + ('T + (SPADLET |decls| (CONS |x| |decls|))))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |key| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |fn| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |p| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |q| + (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |bd| + (QCAR |ISTMP#4|)) + 'T))))))))) + (MEMQ |key| '(DEF MDEF)) + (BOOT-EQUAL |p| '(NIL)) + (BOOT-EQUAL |q| '(NIL))) + (COND + ((OR (BOOT-EQUAL |fn| |target|) + (AND (PAIRP |fn|) + (EQ (QCDR |fn|) NIL) + (EQUAL (QCAR |fn|) |target|))) + (SPADLET |ttype| |bd|)) + ((OR (BOOT-EQUAL |fn| |body|) + (AND (PAIRP |fn|) + (EQ (QCDR |fn|) NIL) + (EQUAL (QCAR |fn|) |body|))) + (SPADLET |body| |bd|)) + ('T + (SPADLET |macros| (CONS |x| |macros|))))) + ('T + (|systemError| + (CONS (MAKESTRING + "unexpected WHERE item: ") + (CONS |x| NIL)))))))) + (SPADLET |nargtypes| + (PROG (G166764) + (SPADLET G166764 NIL) + (RETURN + (DO ((G166770 |argl| (CDR G166770)) + (|arg| NIL)) + ((OR (ATOM G166770) + (PROGN + (SETQ |arg| (CAR G166770)) + NIL)) + (NREVERSE0 G166764)) + (SEQ (EXIT (COND + ((SPADLET |p| + (OR + (PROG (G166776) + (SPADLET G166776 NIL) + (RETURN + (DO + ((G166783 NIL + G166776) + (G166784 |decls| + (CDR G166784)) + (|d| NIL)) + ((OR G166783 + (ATOM G166784) + (PROGN + (SETQ |d| + (CAR G166784)) + NIL)) + G166776) + (SEQ + (EXIT + (COND + ((AND (PAIRP |d|) + (PROGN + (SPADLET + |ISTMP#1| + (QCDR |d|)) + (AND + (PAIRP + |ISTMP#1|) + (EQUAL + (QCAR + |ISTMP#1|) + |arg|) + (PROGN + (SPADLET + |ISTMP#2| + (QCDR + |ISTMP#1|)) + (AND + (PAIRP + |ISTMP#2|) + (EQ + (QCDR + |ISTMP#2|) + NIL) + (PROGN + (SPADLET + |t| + (QCAR + |ISTMP#2|)) + 'T)))))) + (SETQ G166776 + (OR G166776 + |t|))))))))) + (|systemError| + (CONS + (MAKESTRING + "Missing WHERE declaration for :") + (CONS |arg| NIL))))) + (SETQ G166764 + (CONS |p| G166764)))))))))) + (SPADLET |nform| |form|) + (SPADLET |ntarget| (OR |ttype| |target|)) + (SPADLET |ndef| + (CONS 'DEF + (CONS |nform| + (CONS (CONS |ntarget| |nargtypes|) + (CONS |clist| + (CONS |body| NIL)))))) + (SPADLET |result| + (COND + ((PROGN + (SPADLET |ISTMP#1| (REVERSE |macros|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |e| (QCAR |ISTMP#2|)) + (SPADLET |m| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |m| (NREVERSE |m|)) + 'T))) + (SPADLET |mpart| + (COND + (|m| + (CONS 'SEQ + (APPEND |m| + (CONS + (CONS '|exit| + (CONS 1 (CONS |e| NIL))) + NIL)))) + ('T |e|))) + (CONS '|where| + (CONS |ndef| (CONS |mpart| NIL)))) + ('T |ndef|))) + |result|))))) + +;compPART(u,m,e) == +;--------new------------------------------------------94/10/11 +; ['PART,.,x] := u +; T := comp(x,m,e) => markAny('compPART,u, T) +; nil + +(DEFUN |compPART| (|u| |m| |e|) + (PROG (|x| T$) + (RETURN + (PROGN + (SPADLET |x| (CADDR |u|)) + (COND + ((SPADLET T$ (|comp| |x| |m| |e|)) + (|markAny| '|compPART| |u| T$)) + ('T NIL)))))) + +;xxxxx x == x + +(DEFUN |xxxxx| (|x|) |x|) + +;qt(n,T) == +; null T => nil +; if null getProplist('R,T.env) then xxxxx n +; T + +(DEFUN |qt| (|n| T$) + (COND + ((NULL T$) NIL) + ('T (COND ((NULL (|getProplist| 'R (CADDR T$))) (|xxxxx| |n|))) T$))) + +;qe(n,e) == +; if null getProplist('R,e) then xxxxx n +; e + +(DEFUN |qe| (|n| |e|) + (PROGN (COND ((NULL (|getProplist| 'R |e|)) (|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 + +(DEFUN |comp| (|x| |m| |e|) + (PROG (T$) + (RETURN + (PROGN + (|qe| 7 |e|) + (COND + ((SPADLET T$ (|qt| 8 (|comp0| |x| |m| |e|))) + (|qt| 9 (|markComp| |x| T$))) + ('T 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 + +(DEFUN |comp0| (|x| |m| |e|) + (PROG (T$) + (declare (special |$compStack| |$exitModeStack|)) + (RETURN + (PROGN + (|qe| 8 |e|) + (COND + ((SPADLET T$ (|compNoStacking| |x| |m| |e|)) + (SPADLET |$compStack| NIL) (|qt| 10 T$)) + ('T + (SPADLET |$compStack| + (CONS (CONS |x| + (CONS |m| + (CONS |e| + (CONS |$exitModeStack| NIL)))) + |$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)) + +(DEFUN |compNoStacking| (|xOrig| |m| |e|) + (PROG (|$partExpression|) + (DECLARE (SPECIAL |$partExpression|)) + (RETURN + (PROGN + (SPADLET |$partExpression| NIL) + (SPADLET |xOrig| (|markKillAllRecursive| |xOrig|)) + (|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 + +(DEFUN |markKillAllRecursive| (|x|) + (PROG (|op| |r|) + (RETURN + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |r| (QCDR |x|)) + 'T)) + (COND + ((BOOT-EQUAL |op| 'PART) + (CONS 'PART + (CONS (CAR |r|) + (CONS (|markKillAllRecursive| (CADR |r|)) NIL)))) + ((|constructor?| |op|) (|markKillAll| |x|)) + ((AND (BOOT-EQUAL |op| '|elt|) + (|constructor?| (|opOf| (CAR |r|)))) + (CONS '|elt| + (CONS (|markKillAllRecursive| (CAR |r|)) + (CONS (CADR |r|) NIL)))) + ('T |x|))) + ('T |x|))))) + +;compNoStackingAux($partExpression,m,e) == +;-----------------not used---------------------94/10/11 +; x := CADDR $partExpression +; T := compNoStacking0(x,m,e) or return nil +; markParts($partExpression,T) + +(DEFUN |compNoStackingAux| (|$partExpression| |m| |e|) + (DECLARE (SPECIAL |$partExpression|)) + (PROG (|x| T$) + (RETURN + (PROGN + (SPADLET |x| (CADDR |$partExpression|)) + (SPADLET T$ (OR (|compNoStacking0| |x| |m| |e|) (RETURN NIL))) + (|markParts| |$partExpression| T$))))) + +;compNoStacking0(x,m,e) == +; qe(1,e) +; T := compNoStacking01(x,m,qe(51,e)) +; qt(52,T) + +(DEFUN |compNoStacking0| (|x| |m| |e|) + (PROG (T$) + (RETURN + (PROGN + (|qe| 1 |e|) + (SPADLET 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) + +(DEFUN |compNoStacking01| (|x| |m| |e|) + (PROG (T$) + (declare (special |$compStack|)) + (RETURN + (PROGN + (COND ((CONTAINED 'MI |m|) (SPADLET |m| (|markKillAll| |m|)))) + (COND + ((SPADLET T$ (|comp2| |x| |m| |e|)) + (COND + ((AND (BOOT-EQUAL |m| |$EmptyMode|) + (BOOT-EQUAL (CADR T$) + (IFCAR (|get| '|Rep| '|value| |e|)))) + (CONS (CAR T$) (CONS '|Rep| (CONS (CADDR T$) NIL)))) + ('T (|qt| 12 T$)))) + ('T (SPADLET 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 + +(DEFUN |compNoStacking1| (|x| |m| |e| |$compStack|) + (DECLARE (SPECIAL |$compStack|)) + (PROG (|u| |m1| T$) + (RETURN + (COND + ((SPADLET |u| + (|get| (COND ((BOOT-EQUAL |m| '$) '|Rep|) ('T |m|)) + '|value| |e|)) + (SPADLET |m1| (|markKillAll| (CAR |u|))) + (COND + ((SPADLET T$ (|comp2| |x| |m1| |e|)) (|coerce| T$ |m|)) + ('T NIL))) + ('T 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) + +(DEFUN |compWithMappingMode| (|x| |m| |oldE|) + (PROG (|$killOptimizeIfTrue| |m'| |sl| |ISTMP#3| |ISTMP#4| |target| + |argModeList| |ISTMP#5| |vl| |e| |t| |LETTMP#1| + |originalFun| |u| |uu| T$ |ISTMP#1| |a| |ISTMP#2| |b|) + (DECLARE (SPECIAL |$killOptimizeIfTrue|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |m|) '|Mapping|) (CAR |m|))) + (SPADLET |m'| (CADR |m|)) + (SPADLET |sl| (CDDR |m|)) + (SPADLET |$killOptimizeIfTrue| 'T) + (SPADLET |e| |oldE|) + (SPADLET |x| (|markKillAll| |x|)) + (SPADLET |m| (|markKillAll| |m|)) + (COND + ((|isFunctor| |x|) + (COND + ((AND (PROGN + (SPADLET |ISTMP#1| + (|get| |x| '|modemap| + |$CategoryFrame|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#4|)) + (SPADLET |argModeList| + (QCDR |ISTMP#4|)) + 'T))))) + (PROGN + (SPADLET |ISTMP#5| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL))))))) + (PROG (G167028) + (SPADLET G167028 'T) + (RETURN + (DO ((G167035 NIL (NULL G167028)) + (G167036 |argModeList| + (CDR G167036)) + (|mode| NIL) + (G167037 |sl| (CDR G167037)) + (|s| NIL)) + ((OR G167035 (ATOM G167036) + (PROGN + (SETQ |mode| (CAR G167036)) + NIL) + (ATOM G167037) + (PROGN + (SETQ |s| (CAR G167037)) + NIL)) + G167028) + (SEQ (EXIT + (SETQ G167028 + (AND G167028 + (|extendsCategoryForm| '$ |s| + |mode|)))))))) + (|extendsCategoryForm| '$ |target| |m'|)) + (RETURN (CONS |x| (CONS |m| (CONS |e| NIL))))) + ('T NIL))) + ('T (COND ((STRINGP |x|) (SPADLET |x| (INTERN |x|)))) + (DO ((G167054 |sl| (CDR G167054)) (|m| NIL) + (G167055 + (SPADLET |vl| + (TAKE (|#| |sl|) + |$FormalMapVariableList|)) + (CDR G167055)) + (|v| NIL)) + ((OR (ATOM G167054) + (PROGN (SETQ |m| (CAR G167054)) NIL) + (ATOM G167055) + (PROGN (SETQ |v| (CAR G167055)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (|compMakeDeclaration| + (CONS '|:| + (CONS |v| (CONS |m| NIL))) + |$EmptyMode| |e|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + |LETTMP#1|)))) + (COND + ((AND (NULL (NULL |vl|)) + (NULL (|hasFormalMapVariable| |x| |vl|))) + (RETURN + (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| (CONS |x| |vl|) |m'| |e|) + (RETURN NIL))) + (SPADLET |u| (CAR |LETTMP#1|)) + (|extractCodeAndConstructTriple| |u| |m| |oldE|)))) + ((AND (NULL |vl|) + (SPADLET |t| (|comp| (CONS |x| NIL) |m'| |e|))) + (RETURN + (PROGN + (SPADLET |u| (CAR |t|)) + (|extractCodeAndConstructTriple| |u| |m| |oldE|)))) + ('T + (SPADLET |LETTMP#1| + (OR (|comp| |x| |m'| |e|) (RETURN NIL))) + (SPADLET |u| (CAR |LETTMP#1|)) + (SPADLET |originalFun| |u|) + (COND + ((AND (PAIRP |originalFun|) + (EQ (QCAR |originalFun|) 'WI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |originalFun|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |u| |b|))) + (SPADLET |uu| + (CONS 'LAMBDA (CONS |vl| (CONS |u| NIL)))) + (SPADLET T$ + (CONS |uu| (CONS |m| (CONS |oldE| NIL)))) + (COND + ((AND (PAIRP |originalFun|) + (EQ (QCAR |originalFun|) 'WI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |originalFun|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (|markLambda| |vl| |a| |m| T$)) + ('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) + +(DEFUN |compAtom| (|x| |m| |e|) + (PROG (|ISTMP#1| |ISTMP#2| R T$ |t|) + (declare (special |$Expression| |$localImportStack| |$globalImportStack|)) + (RETURN + (COND + ((SPADLET T$ + (|compAtomWithModemap| |x| |m| |e| + (|get| |x| '|modemap| |e|))) + (|markCompAtom| |x| T$)) + ((BOOT-EQUAL |x| '|nil|) + (SPADLET T$ + (COND + ((PROGN + (SPADLET |ISTMP#1| + (|modeIsAggregateOf| '|List| |m| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET R (QCAR |ISTMP#2|)) + 'T))))) + (|compList| |x| (CONS '|List| (CONS R NIL)) |e|)) + ((PROGN + (SPADLET |ISTMP#1| + (|modeIsAggregateOf| '|Vector| |m| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET R (QCAR |ISTMP#2|)) + 'T))))) + (|compVector| |x| (CONS '|Vector| (CONS R NIL)) + |e|)))) + (COND (T$ (|convert| T$ |m|)))) + ((AND (FIXP |x|) + (MEMQ (|opOf| |m|) + '(|Integer| |NonNegativeInteger| |PositiveInteger| + |SmallInteger|))) + (|markAt| (CONS |x| (CONS |m| (CONS |e| NIL))))) + ('T + (SPADLET |t| + (COND + ((|isSymbol| |x|) + (OR (|compSymbol| |x| |m| |e|) (RETURN NIL))) + ((AND (BOOT-EQUAL |m| |$Expression|) + (|primitiveType| |x|)) + (CONS |x| (CONS |m| (CONS |e| NIL)))) + ((STRINGP |x|) + (COND + ((AND (NEQUAL |x| (MAKESTRING "failed")) + (OR (|member| '(|Symbol|) + |$localImportStack|) + (|member| '(|Symbol|) + |$globalImportStack|))) + (|markAt| + (CONS |x| + (CONS '(|String|) (CONS |e| NIL))))) + ('T (CONS |x| (CONS |x| (CONS |e| NIL)))))) + ('T + (CONS |x| + (CONS (OR (|primitiveType| |x|) + (RETURN NIL)) + (CONS |e| NIL)))))) + (|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] + +(DEFUN |extractCodeAndConstructTriple| (|u| |m| |oldE|) + (PROG (|ISTMP#1| |a| |fn| |op| |LETTMP#1| |env|) + (RETURN + (PROGN + (SPADLET |u| (|markKillAll| |u|)) + (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|call|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |fn| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((AND (PAIRP |fn|) (EQ (QCAR |fn|) '|applyFun|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |fn|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |fn| |a|))) + (CONS |fn| (CONS |m| (CONS |oldE| NIL)))) + ('T (SPADLET |op| (CAR |u|)) + (SPADLET |LETTMP#1| (REVERSE (CDR |u|))) + (SPADLET |env| (CAR |LETTMP#1|)) + (CONS (CONS 'CONS + (CONS (CONS '|function| (CONS |op| NIL)) + (CONS |env| NIL))) + (CONS |m| (CONS |oldE| NIL))))))))) + +;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 + +(DEFUN |compSymbol| (|s| |m| |e|) + (PROG (|v| |m'|) + (declare (special |$NoValue| |$NoValueMode| |$Boolean| |$formalArgList| + |$functorLocalParameters| |$FormalMapVariableList| + |$compForModeIfTrue| |$Symbol| |$Expression|)) + (RETURN + (COND + ((BOOT-EQUAL |s| '|$NoValue|) + (CONS '|$NoValue| (CONS |$NoValueMode| (CONS |e| NIL)))) + ((|isFluid| |s|) + (CONS |s| + (CONS (OR (|getmode| |s| |e|) (RETURN NIL)) + (CONS |e| NIL)))) + ((BOOT-EQUAL |s| '|true|) + (CONS ''T (CONS |$Boolean| (CONS |e| NIL)))) + ((BOOT-EQUAL |s| '|false|) + (CONS NIL (CONS |$Boolean| (CONS |e| NIL)))) + ((OR (BOOT-EQUAL |s| |m|) (|get| |s| '|isLiteral| |e|)) + (CONS (CONS 'QUOTE (CONS |s| NIL)) (CONS |s| (CONS |e| NIL)))) + ((SPADLET |v| (|get| |s| '|value| |e|)) + (COND + ((MEMQ |s| |$functorLocalParameters|) + (|NRTgetLocalIndex| |s|) + (CONS |s| (CONS (CADR |v|) (CONS |e| NIL)))) + ('T (CONS |s| (CONS (CADR |v|) (CONS |e| NIL)))))) + ((SPADLET |m'| (|getmode| |s| |e|)) + (COND + ((AND (NULL (|member| |s| |$formalArgList|)) + (NULL (MEMQ |s| |$FormalMapVariableList|)) + (NULL (|isFunction| |s| |e|)) + (NULL (BOOT-EQUAL |$compForModeIfTrue| 'T))) + (|errorRef| |s|))) + (CONS |s| (CONS |m'| (CONS |e| NIL)))) + ((MEMQ |s| |$FormalMapVariableList|) + (|stackMessage| (CONS '|no mode found for| (CONS |s| NIL)))) + ((OR (BOOT-EQUAL |m| |$Symbol|) (BOOT-EQUAL |m| |$Expression|)) + (CONS (CONS 'QUOTE (CONS |s| NIL)) (CONS |m| (CONS |e| NIL)))) + ((NULL (|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 + +(DEFUN |compForm| (|form| |m| |e|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |op| |r| T$) + (RETURN + (PROGN + (COND + ((AND (PAIRP |form|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |form|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) 'PART) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |op| (QCAR |ISTMP#3|)) + 'T))))))) + (PROGN (SPADLET |r| (QCDR |form|)) 'T)) + (SPADLET |form| (CONS |op| |r|)))) + (SPADLET T$ + (OR (|compForm1| |form| |m| |e|) + (|compArgumentsAndTryAgain| |form| |m| |e|) + (RETURN + (|stackMessageIfNone| + (CONS '|cannot compile| + (CONS '|%b| + (CONS |form| (CONS '|%d| NIL)))))))) + 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) + +(DEFUN |compForm1| (|form| |m| |e|) + (PROG (|$NumberOfArgsIfInteger| |op| |argl| |a| |b| |ISTMP#2| |op'| + |domain| |LETTMP#1| |val| |ISTMP#1| |ans| |mmList| T$) + (DECLARE (SPECIAL |$NumberOfArgsIfInteger|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |$NumberOfArgsIfInteger| (|#| |argl|)) + (COND + ((BOOT-EQUAL |op| '|error|) + (CONS (CONS |op| + (PROG (G167267) + (SPADLET G167267 NIL) + (RETURN + (DO ((G167275 |argl| (CDR G167275)) + (|x| NIL)) + ((OR (ATOM G167275) + (PROGN + (SETQ |x| (CAR G167275)) + NIL)) + (NREVERSE0 G167267)) + (SEQ (EXIT + (SETQ G167267 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (|outputComp| |x| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G167267)))))))) + (CONS |m| (CONS |e| NIL)))) + ((AND (PAIRP |op|) (EQ (QCAR |op|) 'MI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (|compForm1| (CONS (|markKillExpr| |b|) |argl|) |m| + |e|)) + ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |domain| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |op'| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |domain| (|markKillAll| |domain|)) + (COND + ((BOOT-EQUAL |domain| '|Lisp|) + (SPADLET |val| + (CONS |op'| + (PROG (G167288) + (SPADLET G167288 NIL) + (RETURN + (DO + ((G167296 |argl| + (CDR G167296)) + (|x| NIL)) + ((OR (ATOM G167296) + (PROGN + (SETQ |x| (CAR G167296)) + NIL)) + (NREVERSE0 G167288)) + (SEQ + (EXIT + (SETQ G167288 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (|compOrCroak| |x| + |$EmptyMode| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G167288))))))))) + (|markLisp| (CONS |val| (CONS |m| (CONS |e| NIL))) + |m|)) + ((AND (BOOT-EQUAL |domain| |$Expression|) + (BOOT-EQUAL |op'| '|construct|)) + (|compExpressionList| |argl| |m| |e|)) + ((AND (BOOT-EQUAL |op'| 'COLLECT) + (|coerceable| |domain| |m| |e|)) + (SPADLET T$ + (OR (|comp| (CONS |op'| |argl|) |domain| + |e|) + (RETURN NIL))) + (|coerce| T$ |m|)) + ((AND (BOOT-EQUAL |domain| '|Rep|) + (SPADLET |ans| + (|compForm2| (CONS |op'| |argl|) + (MSUBST '|Rep| '$ |m|) + (SPADLET |e| + (|addDomain| |domain| |e|)) + (PROG (G167307) + (SPADLET G167307 NIL) + (RETURN + (DO + ((G167313 + (|getFormModemaps| + (CONS |op'| |argl|) |e|) + (CDR G167313)) + (|x| NIL)) + ((OR (ATOM G167313) + (PROGN + (SETQ |x| + (CAR G167313)) + NIL)) + (NREVERSE0 G167307)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL + (QCAR |ISTMP#1|) + |domain|)))) + (SETQ G167307 + (CONS + (MSUBST '|Rep| '$ + |x|) + G167307)))))))))))) + |ans|) + ((SPADLET |ans| + (|compForm2| (CONS |op'| |argl|) |m| + (SPADLET |e| + (|addDomain| |domain| |e|)) + (PROG (G167324) + (SPADLET G167324 NIL) + (RETURN + (DO + ((G167330 + (|getFormModemaps| + (CONS |op'| |argl|) |e|) + (CDR G167330)) + (|x| NIL)) + ((OR (ATOM G167330) + (PROGN + (SETQ |x| (CAR G167330)) + NIL)) + (NREVERSE0 G167324)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |domain|)))) + (SETQ G167324 + (CONS |x| G167324))))))))))) + |ans|) + ((AND (BOOT-EQUAL |op'| '|construct|) + (|coerceable| |domain| |m| |e|)) + (SPADLET T$ + (OR (|comp| (CONS |op'| |argl|) |domain| + |e|) + (RETURN NIL))) + (|coerce| T$ |m|)) + ('T NIL))) + ('T (SPADLET |e| (|addDomain| |m| |e|)) + (COND + ((AND (SPADLET |mmList| + (|getFormModemaps| |form| |e|)) + (SPADLET T$ + (|compForm2| |form| |m| |e| |mmList|))) + T$) + ('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)) + +(DEFUN |compForm3| (|form| |m| |e| |modemapList|) + (PROG (|op| |argl| |mml| T$ |result|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |modemapList| + (|compFormOrderModemaps| |modemapList| + (BOOT-EQUAL |m| '$))) + (|qe| 22 |e|) + (SPADLET T$ + (OR (PROG (G167384) + (SPADLET G167384 NIL) + (RETURN + (DO ((G167390 NIL G167384) + (|ml| |modemapList| (CDR |ml|))) + ((OR G167390 (ATOM |ml|)) + G167384) + (SEQ (EXIT + (SETQ G167384 + (OR G167384 + (|compFormWithModemap| |form| + |m| |e| + (CAR (SPADLET |mml| |ml|)))))))))) + (RETURN NIL))) + (|qt| 14 T$) + (SPADLET |result| + (COND + (|$compUniquelyIfTrue| + (COND + ((PROG (G167395) + (SPADLET G167395 NIL) + (RETURN + (DO + ((G167401 NIL G167395) + (G167402 (CDR |mml|) + (CDR G167402)) + (|mm| NIL)) + ((OR G167401 (ATOM G167402) + (PROGN + (SETQ |mm| (CAR G167402)) + NIL)) + G167395) + (SEQ + (EXIT + (SETQ G167395 + (OR G167395 + (|compFormWithModemap| |form| + |m| |e| |mm|)))))))) + (THROW '|compUniquely| NIL)) + ('T (|qt| 15 T$)))) + ('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)] + +(DEFUN |compFormOrderModemaps| (|mml| |targetIsDollar?|) + (PROG (|dc| |sig| |dc1| |sig1| |dollarMms| |repMms|) + (RETURN + (SEQ (PROGN + (SPADLET |repMms| + (PROG (G167436) + (SPADLET G167436 NIL) + (RETURN + (DO ((G167443 |mml| (CDR G167443)) + (|mm| NIL)) + ((OR (ATOM G167443) + (PROGN + (SETQ |mm| (CAR G167443)) + NIL) + (PROGN + (PROGN + (SPADLET |dc| (CAAR |mm|)) + |mm|) + NIL)) + (NREVERSE0 G167436)) + (SEQ (EXIT (COND + ((BOOT-EQUAL |dc| '|Rep|) + (SETQ G167436 + (CONS |mm| G167436)))))))))) + (COND + ((AND |repMms| |targetIsDollar?|) + (SPADLET |dollarMms| + (PROG (G167456) + (SPADLET G167456 NIL) + (RETURN + (DO ((G167463 |mml| (CDR G167463)) + (|mm| NIL)) + ((OR (ATOM G167463) + (PROGN + (SETQ |mm| (CAR G167463)) + NIL) + (PROGN + (PROGN + (SPADLET |dc| (CAAR |mm|)) + (SPADLET |sig| (CDAR |mm|)) + |mm|) + NIL)) + (NREVERSE0 G167456)) + (SEQ (EXIT + (COND + ((AND (BOOT-EQUAL |dc| '$) + (PROG (G167470) + (SPADLET G167470 NIL) + (RETURN + (DO + ((G167478 NIL + G167470) + (G167479 |repMms| + (CDR G167479)) + (|mm1| NIL)) + ((OR G167478 + (ATOM G167479) + (PROGN + (SETQ |mm1| + (CAR G167479)) + NIL) + (PROGN + (PROGN + (SPADLET |dc1| + (CAAR |mm1|)) + (SPADLET |sig1| + (CDAR |mm1|)) + |mm1|) + NIL)) + G167470) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |sig1| + |sig|) + (SETQ G167470 + (OR G167470 + |mm1|)))))))))) + (SETQ G167456 + (CONS |mm| G167456)))))))))) + (SPADLET |repMms| (APPEND |dollarMms| |repMms|)))) + (COND + ((NULL |repMms|) |mml|) + ('T (APPEND |repMms| (SETDIFFERENCE |mml| |repMms|))))))))) + +;compWI(["WI",a,b],m,E) == +; u := comp(b,m,E) +; pp (u => "====> ok"; 'NO) +; u + +(DEFUN |compWI| (G167503 |m| E) + (PROG (|a| |b| |u|) + (RETURN + (PROGN + (COND ((EQ (CAR G167503) 'WI) (CAR G167503))) + (SPADLET |a| (CADR G167503)) + (SPADLET |b| (CADDR G167503)) + (SPADLET |u| (|comp| |b| |m| E)) + (|pp| (COND (|u| '|====> ok|) ('T 'NO))) + |u|)))) + +;compMI(["MI",a,b],m,E) == +; u := comp(b,m,E) +; pp (u => "====> ok"; 'NO) +; u + +(DEFUN |compMI| (G167522 |m| E) + (PROG (|a| |b| |u|) + (RETURN + (PROGN + (COND ((EQ (CAR G167522) 'MI) (CAR G167522))) + (SPADLET |a| (CADR G167522)) + (SPADLET |b| (CADDR G167522)) + (SPADLET |u| (|comp| |b| |m| E)) + (|pp| (COND (|u| '|====> ok|) ('T '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] + +(DEFUN |compWhere| (G167555 |m| |eInit|) + (PROG (|$insideExpressionIfTrue| |$insideWhereIfTrue| |form| + |exprList| |e| |u| |eBefore| |LETTMP#1| |x| |eAfter| |del| + |eFinal|) + (DECLARE (SPECIAL |$insideExpressionIfTrue| |$insideWhereIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CADR G167555)) + (SPADLET |exprList| (CDDR G167555)) + (SPADLET |$insideExpressionIfTrue| NIL) + (SPADLET |$insideWhereIfTrue| 'T) + (SPADLET |e| |eInit|) + (SPADLET |u| + (DO ((G167578 |exprList| (CDR G167578)) + (|item| NIL)) + ((OR (ATOM G167578) + (PROGN + (SETQ |item| (CAR G167578)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (OR + (|comp| |item| |$EmptyMode| |e|) + (RETURN '|failed|))) + (SPADLET |e| (CADDR |LETTMP#1|)) + |LETTMP#1|))))) + (COND + ((BOOT-EQUAL |u| '|failed|) (RETURN NIL)) + ('T (SPADLET |$insideWhereIfTrue| NIL) + (SPADLET |LETTMP#1| + (OR (|comp| (|macroExpand| |form| + (SPADLET |eBefore| |e|)) + |m| |e|) + (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |eAfter| (CADDR |LETTMP#1|)) + (SPADLET |eFinal| + (COND + ((SPADLET |del| + (|deltaContour| |eAfter| + |eBefore|)) + (|addContour| |del| |eInit|)) + ('T |eInit|))) + (CONS |x| (CONS |m| (CONS |eFinal| NIL)))))))))) + +;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)] + +(DEFUN |compMacro| (|form| |m| |e|) + (PROG (|$macroIfTrue| |firstForm| |lhs| |signature| |specialCases| + |rhs|) + (DECLARE (SPECIAL |$macroIfTrue|)) + (RETURN + (PROGN + (SPADLET |$macroIfTrue| 'T) + (SPADLET |form| (|markKillAll| |form|)) + (COND ((EQ (CAR |form|) 'MDEF) (CAR |form|))) + (SPADLET |lhs| (CADR |form|)) + (SPADLET |signature| (CADDR |form|)) + (SPADLET |specialCases| (CADDDR |form|)) + (SPADLET |rhs| (CAR (CDDDDR |form|))) + (SPADLET |firstForm| + (CONS 'MDEF + (CONS (CAR |lhs|) + (CONS '(NIL) + (CONS '(NIL) (CONS |rhs| NIL)))))) + (|markMacro| (CAR |lhs|) |rhs|) + (SPADLET |rhs| + (COND + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CATEGORY)) + (CONS (MAKESTRING "-- the constructor category") + NIL)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Join|)) + (CONS (MAKESTRING "-- the constructor category") + NIL)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CAPSULE)) + (CONS (MAKESTRING "-- the constructor capsule") + NIL)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|add|)) + (CONS (MAKESTRING "-- the constructor capsule") + NIL)) + ('T (|formatUnabbreviated| |rhs|)))) + (|sayBrightly| + (CONS (MAKESTRING " processing macro definition") + (CONS '|%b| + (APPEND (|formatUnabbreviated| |lhs|) + (CONS (MAKESTRING " ==> ") + (APPEND |rhs| (CONS '|%d| NIL))))))) + (SPADLET |form| (|macroExpand| |form| |e|)) + (COND ((EQ (CAR |form|) 'MDEF) (CAR |form|))) + (SPADLET |lhs| (CADR |form|)) + (SPADLET |signature| (CADDR |form|)) + (SPADLET |specialCases| (CADDDR |form|)) + (SPADLET |rhs| (CAR (CDDDDR |form|))) + (COND + ((OR (BOOT-EQUAL |m| |$EmptyMode|) + (BOOT-EQUAL |m| |$NoValueMode|)) + (CONS '|/throwAway| + (CONS |$NoValueMode| + (CONS (|put| (CAR |lhs|) '|macro| |rhs| |e|) + NIL))))))))) + +;--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 + +(DEFUN |compSetq| (|oform| |m| E) + (PROG (|form| |val| T$) + (RETURN + (PROGN + (COND ((EQ (CAR |oform|) 'LET) (CAR |oform|))) + (SPADLET |form| (CADR |oform|)) + (SPADLET |val| (CADDR |oform|)) + (COND + ((SPADLET T$ (|compSetq1| |form| |val| |m| E)) + (|markSetq| |oform| T$)) + ('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) + +(DEFUN |compSetq1| (|oform| |val| |m| E) + (PROG (|form| |ISTMP#1| |x| |ISTMP#2| |y| |LETTMP#1| |E'| |op| |l|) + (RETURN + (PROGN + (SPADLET |form| (|markKillAll| |oform|)) + (COND + ((IDENTP |form|) (|setqSingle| |form| |val| |m| E)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |LETTMP#1| + (|compMakeDeclaration| |form| |$EmptyMode| E)) + (SPADLET |E'| (CADDR |LETTMP#1|)) + (|compSetq| (CONS 'LET (CONS |x| (CONS |val| NIL))) |m| + |E'|)) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |l| (QCDR |form|)) + 'T)) + (COND + ((BOOT-EQUAL |op| 'CONS) + (|setqMultiple| (|uncons| |form|) |val| |m| E)) + ((BOOT-EQUAL |op| '|Tuple|) + (|setqMultiple| |l| |val| |m| E)) + ('T (|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) + +(DEFUN |setqSetelt| (|oform| G167704 |val| |m| E) + (PROG (|v| |s| T$) + (RETURN + (PROGN + (SPADLET |v| (CAR G167704)) + (SPADLET |s| (CDR G167704)) + (SPADLET T$ + (OR (|comp0| (CONS '|setelt| + (APPEND |oform| (CONS |val| NIL))) + |m| E) + (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'] + +(DEFUN |setqSingle| (|id| |val| |m| E) + (PROG (|$insideSetqSingleIfTrue| |currentProplist| |m''| |trialT| + |maxm''| T$ |LETTMP#1| |x| |m'| |T'| |key| |newProplist| + |x1| |e'| |k| |form|) + (DECLARE (SPECIAL |$insideSetqSingleIfTrue| |$NoValueMode| |$EmptyMode| + |$profileCompiler| |$form| |$markFreeStack| + |$QuickLet|)) + (RETURN + (PROGN + (SPADLET |$insideSetqSingleIfTrue| 'T) + (SPADLET |currentProplist| (|getProplist| |id| E)) + (SPADLET |m''| + (OR (|get| |id| '|mode| E) (|getmode| |id| E) + (COND + ((BOOT-EQUAL |m| |$NoValueMode|) |$EmptyMode|) + ('T |m|)))) + (SPADLET |trialT| + (AND (BOOT-EQUAL |m''| '$) (|get| '|Rep| '|value| E) + (|comp| |val| '|Rep| E))) + (SPADLET T$ + (OR (AND |trialT| (|coerce| |trialT| |m''|)) + (COND + ((SPADLET T$ (|comp| |val| |m''| E)) T$) + ((AND (NULL (|get| |id| '|mode| E)) + (NEQUAL |m''| + (SPADLET |maxm''| + (|maxSuperType| |m''| E))) + (SPADLET T$ (|comp| |val| |maxm''| E))) + T$) + ((AND (SPADLET T$ (|comp| |val| |$EmptyMode| E)) + (|getmode| (CADR T$) E)) + (|assignError| |val| (CADR T$) |id| |m''|))) + (RETURN NIL))) + (SPADLET |T'| + (PROGN + (SPADLET |LETTMP#1| + (OR (|convert| T$ |m|) (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e'| (CADDR |LETTMP#1|)) + |LETTMP#1|)) + (COND + ((BOOT-EQUAL |$profileCompiler| 'T) + (COND + ((NULL (IDENTP |id|)) NIL) + ('T + (SPADLET |key| + (COND + ((MEMQ |id| (CDR |$form|)) '|arguments|) + ('T '|locals|))) + (|profileRecord| |key| |id| (CADR T$)))))) + (SPADLET |newProplist| + (|consProplistOf| |id| |currentProplist| '|value| + (|markKillAll| (|removeEnv| T$)))) + (SPADLET |e'| + (COND + ((PAIRP |id|) |e'|) + ('T (|addBinding| |id| |newProplist| |e'|)))) + (SPADLET |x1| (|markKillAll| |x|)) + (COND + ((|isDomainForm| |x1| |e'|) + (COND + ((|isDomainInScope| |id| |e'|) + (|stackWarning| + (CONS '|domain valued variable| + (CONS '|%b| + (CONS |id| + (CONS '|%d| + (CONS + '|has been reassigned within its scope| + NIL)))))))) + (SPADLET |e'| (|augModemapsFromDomain1| |id| |x1| |e'|)))) + (COND + ((SPADLET |k| (|NRTassocIndex| |id|)) + (SPADLET |$markFreeStack| (CONS |id| |$markFreeStack|)) + (SPADLET |form| + (CONS 'SETELT (CONS '$ (CONS |k| (CONS |x| NIL)))))) + ('T + (SPADLET |form| + (COND + (|$QuickLet| + (CONS 'LET (CONS |id| (CONS |x| NIL)))) + ('T + (CONS 'LET + (CONS |id| + (CONS |x| + (CONS + (COND + ((|isDomainForm| |x| |e'|) + (CONS 'ELT + (CONS |id| (CONS 0 NIL)))) + ('T + (CAR (|outputComp| |id| |e'|)))) + NIL))))))))) + (CONS |form| (CONS |m'| (CONS |e'| NIL))))))) + +;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] + +(DEFUN |setqMultiple,decompose| (|t| |length| |e|) + (declare (ignore |length|)) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |l| |ISTMP#4| |name| |mode|) + (declare (special |$EmptyMode|)) + (RETURN + (SEQ (IF (AND (PAIRP |t|) (EQ (QCAR |t|) '|Record|) + (PROGN (SPADLET |l| (QCDR |t|)) 'T)) + (EXIT (PROG (G167823) + (SPADLET G167823 NIL) + (RETURN + (DO ((G167829 |l| (CDR G167829)) + (G167785 NIL)) + ((OR (ATOM G167829) + (PROGN + (SETQ G167785 (CAR G167829)) + NIL) + (PROGN + (PROGN + (SPADLET |name| (CADR G167785)) + (SPADLET |mode| + (CADDR G167785)) + G167785) + NIL)) + (NREVERSE0 G167823)) + (SEQ (EXIT (SETQ G167823 + (CONS (CONS |name| |mode|) + G167823))))))))) + (IF (PROGN + (SPADLET |ISTMP#1| (|comp| |t| |$EmptyMode| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) + '|RecordCategory|) + (PROGN + (SPADLET |l| (QCDR |ISTMP#3|)) + 'T))) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL))))))) + (EXIT (PROG (G167841) + (SPADLET G167841 NIL) + (RETURN + (DO ((G167847 |l| (CDR G167847)) + (G167813 NIL)) + ((OR (ATOM G167847) + (PROGN + (SETQ G167813 (CAR G167847)) + NIL) + (PROGN + (PROGN + (SPADLET |name| (CADR G167813)) + (SPADLET |mode| + (CADDR G167813)) + G167813) + NIL)) + (NREVERSE0 G167841)) + (SEQ (EXIT (SETQ G167841 + (CONS (CONS |name| |mode|) + G167841))))))))) + (EXIT (|stackMessage| + (CONS '|no multiple assigns to mode: | + (CONS |t| NIL)))))))) + +(DEFUN |setqMultiple| (|nameList| |val| |m| |e|) + (PROG (|l| |g| |m1| T$ |x| |m'| |ISTMP#1| D |selectorModePairs| |y| + |z| |LETTMP#1| |assignList|) + (RETURN + (SEQ (COND + ((AND (PAIRP |val|) (EQ (QCAR |val|) 'CONS) + (BOOT-EQUAL |m| |$NoValueMode|)) + (|setqMultipleExplicit| |nameList| (|uncons| |val|) |m| + |e|)) + ((AND (PAIRP |val|) (EQ (QCAR |val|) '|Tuple|) + (PROGN (SPADLET |l| (QCDR |val|)) 'T) + (BOOT-EQUAL |m| |$NoValueMode|)) + (|setqMultipleExplicit| |nameList| |l| |m| |e|)) + ('T (SPADLET |g| (|genVariable|)) + (SPADLET |e| (|addBinding| |g| NIL |e|)) + (SPADLET T$ + (PROGN + (SPADLET |LETTMP#1| + (OR (|compSetq1| |g| |val| + |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |m1| (CADR |LETTMP#1|)) + |LETTMP#1|)) + (SPADLET |e| (|put| |g| '|mode| |m1| |e|)) + (SPADLET |LETTMP#1| (OR (|convert| T$ |m|) (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((AND (PAIRP |m1|) (EQ (QCAR |m1|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) + (DO ((G167883 |nameList| (CDR G167883)) (|y| NIL)) + ((OR (ATOM G167883) + (PROGN (SETQ |y| (CAR G167883)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |e| + (|put| |y| '|value| + (CONS (|genSomeVariable|) + (CONS D (CONS |$noEnv| NIL))) + |e|))))) + (|convert| + (CONS (CONS 'PROGN + (CONS |x| + (CONS + (CONS 'LET + (CONS |nameList| + (CONS |g| NIL))) + (CONS |g| NIL)))) + (CONS |m'| (CONS |e| NIL))) + |m|)) + ('T + (SPADLET |selectorModePairs| + (OR (|setqMultiple,decompose| |m1| + (|#| |nameList|) |e|) + (RETURN NIL))) + (COND + ((NEQUAL (|#| |nameList|) (|#| |selectorModePairs|)) + (|stackMessage| + (CONS |val| + (CONS '| must decompose into | + (CONS (|#| |nameList|) + (CONS '| components| NIL)))))) + ('T + (SPADLET |assignList| + (PROG (G167898) + (SPADLET G167898 NIL) + (RETURN + (DO ((G167908 |nameList| + (CDR G167908)) + (|x| NIL) + (G167909 |selectorModePairs| + (CDR G167909)) + (G167875 NIL)) + ((OR (ATOM G167908) + (PROGN + (SETQ |x| (CAR G167908)) + NIL) + (ATOM G167909) + (PROGN + (SETQ G167875 + (CAR G167909)) + NIL) + (PROGN + (PROGN + (SPADLET |y| + (CAR G167875)) + (SPADLET |z| + (CDR G167875)) + G167875) + NIL)) + (NREVERSE0 G167898)) + (SEQ + (EXIT + (SETQ G167898 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (OR + (|compSetq1| |x| + (CONS '|elt| + (CONS |g| (CONS |y| NIL))) + |z| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G167898)))))))) + (COND + ((BOOT-EQUAL |assignList| '|failed|) NIL) + ('T + (CONS (MKPROGN (CONS |x| + (APPEND |assignList| + (CONS |g| NIL)))) + (CONS |m'| (CONS |e| NIL))))))))))))))) + +;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) + +(DEFUN |setqMultipleExplicit| (|nameList| |valList| |m| |e|) + (declare (ignore |m|)) + (PROG (|gensymList| |assignList| |LETTMP#1| |reAssignList| T$) + (declare (special |$EmptyMode| |$NoValueMode|)) + (RETURN + (SEQ (COND + ((NEQUAL (|#| |nameList|) (|#| |valList|)) + (|stackMessage| + (CONS '|Multiple assignment error; # of items in: | + (CONS |nameList| + (CONS '|must = # in: | + (CONS |valList| NIL)))))) + ('T + (SPADLET |gensymList| + (PROG (G167958) + (SPADLET G167958 NIL) + (RETURN + (DO ((G167963 |nameList| (CDR G167963)) + (|name| NIL)) + ((OR (ATOM G167963) + (PROGN + (SETQ |name| (CAR G167963)) + NIL)) + (NREVERSE0 G167958)) + (SEQ (EXIT (SETQ G167958 + (CONS (|genVariable|) + G167958)))))))) + (DO ((G167973 |gensymList| (CDR G167973)) (|g| NIL) + (G167974 |nameList| (CDR G167974)) (|name| NIL)) + ((OR (ATOM G167973) + (PROGN (SETQ |g| (CAR G167973)) NIL) + (ATOM G167974) + (PROGN (SETQ |name| (CAR G167974)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |e| + (|put| |g| '|mode| + (|get| |name| '|mode| |e|) |e|))))) + (SPADLET |assignList| + (PROG (G167992) + (SPADLET G167992 NIL) + (RETURN + (DO ((G168002 |gensymList| + (CDR G168002)) + (|g| NIL) + (G168003 |valList| (CDR G168003)) + (|val| NIL) + (G168004 |nameList| (CDR G168004)) + (|name| NIL)) + ((OR (ATOM G168002) + (PROGN + (SETQ |g| (CAR G168002)) + NIL) + (ATOM G168003) + (PROGN + (SETQ |val| (CAR G168003)) + NIL) + (ATOM G168004) + (PROGN + (SETQ |name| (CAR G168004)) + NIL)) + (NREVERSE0 G167992)) + (SEQ (EXIT (SETQ G167992 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR + (|compSetq1| |g| |val| + |$EmptyMode| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G167992)))))))) + (COND + ((BOOT-EQUAL |assignList| '|failed|) NIL) + ('T + (SPADLET |reAssignList| + (PROG (G168024) + (SPADLET G168024 NIL) + (RETURN + (DO ((G168033 |gensymList| + (CDR G168033)) + (|g| NIL) + (G168034 |nameList| + (CDR G168034)) + (|name| NIL)) + ((OR (ATOM G168033) + (PROGN + (SETQ |g| (CAR G168033)) + NIL) + (ATOM G168034) + (PROGN + (SETQ |name| (CAR G168034)) + NIL)) + (NREVERSE0 G168024)) + (SEQ (EXIT + (SETQ G168024 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR + (|compSetq1| |name| |g| + |$EmptyMode| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G168024)))))))) + (COND + ((BOOT-EQUAL |reAssignList| '|failed|) NIL) + ('T + (SPADLET T$ + (CONS (CONS 'PROGN + (APPEND + (PROG (G168047) + (SPADLET G168047 NIL) + (RETURN + (DO + ((G168052 |assignList| + (CDR G168052)) + (T$ NIL)) + ((OR (ATOM G168052) + (PROGN + (SETQ T$ (CAR G168052)) + NIL)) + (NREVERSE0 G168047)) + (SEQ + (EXIT + (SETQ G168047 + (CONS (CAR T$) G168047))))))) + (PROG (G168062) + (SPADLET G168062 NIL) + (RETURN + (DO + ((G168067 |reAssignList| + (CDR G168067)) + (T$ NIL)) + ((OR (ATOM G168067) + (PROGN + (SETQ T$ (CAR G168067)) + NIL)) + (NREVERSE0 G168062)) + (SEQ + (EXIT + (SETQ G168062 + (CONS (CAR T$) G168062))))))))) + (CONS |$NoValueMode| + (CONS + (CADDR (|last| |reAssignList|)) + NIL)))) + (|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 + +(DEFUN |canReturn,findThrow| + (|gs| |expr| |level| |exitCount| |ValueFlag|) + (PROG (|ISTMP#1| |ISTMP#2| |data| |l|) + (RETURN + (SEQ (IF (ATOM |expr|) (EXIT NIL)) + (IF (AND (PAIRP |expr|) (EQ (QCAR |expr|) 'THROW) + (PROGN + (SPADLET |ISTMP#1| (QCDR |expr|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |gs|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |data| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT 'T)) + (IF (AND (PAIRP |expr|) (EQ (QCAR |expr|) 'SEQ) + (PROGN (SPADLET |l| (QCDR |expr|)) 'T)) + (EXIT (PROG (G168120) + (SPADLET G168120 NIL) + (RETURN + (DO ((G168126 NIL G168120) + (G168127 |l| (CDR G168127)) + (|u| NIL)) + ((OR G168126 (ATOM G168127) + (PROGN + (SETQ |u| (CAR G168127)) + NIL)) + G168120) + (SEQ (EXIT (SETQ G168120 + (OR G168120 + (|canReturn,findThrow| |gs| |u| + (PLUS |level| 1) |exitCount| + |ValueFlag|)))))))))) + (EXIT (PROG (G168134) + (SPADLET G168134 NIL) + (RETURN + (DO ((G168140 NIL G168134) + (G168141 (CDR |expr|) (CDR G168141)) + (|u| NIL)) + ((OR G168140 (ATOM G168141) + (PROGN (SETQ |u| (CAR G168141)) NIL)) + G168134) + (SEQ (EXIT (SETQ G168134 + (OR G168134 + (|canReturn,findThrow| |gs| + |u| |level| |exitCount| + |ValueFlag|))))))))))))) + +(DEFUN |canReturn| (|expr| |level| |exitCount| |ValueFlag|) + (PROG (|op| |count| |gs| |data| |a| |b| |ISTMP#3| |c| |ISTMP#1| + |args| |ISTMP#2| |bods|) + (declare (special |$convert2NewCompiler|)) + (RETURN + (SEQ (COND + ((ATOM |expr|) + (AND |ValueFlag| (BOOT-EQUAL |level| |exitCount|))) + ((BOOT-EQUAL (SPADLET |op| (CAR |expr|)) 'QUOTE) + (AND |ValueFlag| (BOOT-EQUAL |level| |exitCount|))) + ((MEMQ |op| '(WI MI)) + (|canReturn| (CADDR |expr|) |level| |count| |ValueFlag|)) + ((BOOT-EQUAL |op| '|TAGGEDexit|) + (COND + ((AND (PAIRP |expr|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |expr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |count| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |data| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (|canReturn| (CAR |data|) |level| |count| + (BOOT-EQUAL |count| |level|)))))) + ((AND (BOOT-EQUAL |level| |exitCount|) (NULL |ValueFlag|)) + NIL) + ((BOOT-EQUAL |op| 'SEQ) + (PROG (G168213) + (SPADLET G168213 NIL) + (RETURN + (DO ((G168219 NIL G168213) + (G168220 (CDR |expr|) (CDR G168220)) + (|u| NIL)) + ((OR G168219 (ATOM G168220) + (PROGN (SETQ |u| (CAR G168220)) NIL)) + G168213) + (SEQ (EXIT (SETQ G168213 + (OR G168213 + (|canReturn| |u| (PLUS |level| 1) + |exitCount| NIL))))))))) + ((BOOT-EQUAL |op| '|TAGGEDreturn|) NIL) + ((BOOT-EQUAL |op| 'CATCH) + (PROGN + (SPADLET |gs| (CADR |expr|)) + (SPADLET |data| (CADDR |expr|)) + (COND + ((|canReturn,findThrow| |gs| |data| |level| + |exitCount| |ValueFlag|) + 'T) + ('T + (|canReturn| |data| |level| |exitCount| |ValueFlag|))))) + ((BOOT-EQUAL |op| 'COND) + (COND + ((BOOT-EQUAL |level| |exitCount|) + (PROG (G168227) + (SPADLET G168227 NIL) + (RETURN + (DO ((G168233 NIL G168227) + (G168234 (CDR |expr|) (CDR G168234)) + (|u| NIL)) + ((OR G168233 (ATOM G168234) + (PROGN (SETQ |u| (CAR G168234)) NIL)) + G168227) + (SEQ (EXIT (SETQ G168227 + (OR G168227 + (|canReturn| (|last| |u|) + |level| |exitCount| + |ValueFlag|))))))))) + ('T + (PROG (G168241) + (SPADLET G168241 NIL) + (RETURN + (DO ((G168247 NIL G168241) + (G168248 (CDR |expr|) (CDR G168248)) + (|v| NIL)) + ((OR G168247 (ATOM G168248) + (PROGN (SETQ |v| (CAR G168248)) NIL)) + G168241) + (SEQ (EXIT (SETQ G168241 + (OR G168241 + (PROG (G168255) + (SPADLET G168255 NIL) + (RETURN + (DO + ((G168261 NIL + G168255) + (G168262 |v| + (CDR G168262)) + (|u| NIL)) + ((OR G168261 + (ATOM G168262) + (PROGN + (SETQ |u| + (CAR G168262)) + NIL)) + G168255) + (SEQ + (EXIT + (SETQ G168255 + (OR G168255 + (|canReturn| |u| + |level| |exitCount| + |ValueFlag|)))))))))))))))))) + ((BOOT-EQUAL |op| 'IF) + (PROGN + (AND (PAIRP |expr|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |expr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + 'T)))))))) + (COND + ((AND (NULL (|canReturn| |a| 0 0 'T)) + (NULL (AND (BOUNDP '|$convert2NewCompiler|) + |$convert2NewCompiler|))) + (SAY (MAKESTRING + "IF statement can not cause consequents to be executed")) + (|pp| |expr|))) + (OR (|canReturn| |a| |level| |exitCount| NIL) + (|canReturn| |b| |level| |exitCount| |ValueFlag|) + (|canReturn| |c| |level| |exitCount| |ValueFlag|)))) + ((ATOM |op|) + (PROG (G168269) + (SPADLET G168269 'T) + (RETURN + (DO ((G168275 NIL (NULL G168269)) + (G168276 |expr| (CDR G168276)) (|u| NIL)) + ((OR G168275 (ATOM G168276) + (PROGN (SETQ |u| (CAR G168276)) NIL)) + G168269) + (SEQ (EXIT (SETQ G168269 + (AND G168269 + (|canReturn| |u| |level| + |exitCount| |ValueFlag|))))))))) + ((AND (PAIRP |op|) (EQ (QCAR |op|) 'XLAM) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |args| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |bods| (QCAR |ISTMP#2|)) + 'T)))))) + (PROG (G168283) + (SPADLET G168283 'T) + (RETURN + (DO ((G168289 NIL (NULL G168283)) + (G168290 |expr| (CDR G168290)) (|u| NIL)) + ((OR G168289 (ATOM G168290) + (PROGN (SETQ |u| (CAR G168290)) NIL)) + G168283) + (SEQ (EXIT (SETQ G168283 + (AND G168283 + (|canReturn| |u| |level| + |exitCount| |ValueFlag|))))))))) + ('T (|systemErrorHere| (MAKESTRING "canReturn")))))))) + +;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] + +(DEFUN |compList| (|l| |m| |e|) + (PROG (|LETTMP#1| |mUnder| |Tl| T$) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |m|) '|List|) (CAR |m|))) + (SPADLET |mUnder| (CADR |m|)) + (|markImport| |m|) + (|markImport| |mUnder|) + (COND + ((NULL |l|) (CONS NIL (CONS |m| (CONS |e| NIL)))) + ('T + (SPADLET |Tl| + (PROG (G168352) + (SPADLET G168352 NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|)) + (G168362 |l| (CDR G168362)) + (|x| NIL)) + ((OR (ATOM G168362) + (PROGN + (SETQ |x| (CAR G168362)) + NIL)) + (NREVERSE0 G168352)) + (SEQ (EXIT + (SETQ G168352 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| |x| |mUnder| |e|) + (RETURN '|failed|))) + (SPADLET |mUnder| + (CADR |LETTMP#1|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G168352)))))))) + (COND + ((BOOT-EQUAL |Tl| '|failed|) NIL) + ('T + (SPADLET T$ + (CONS (CONS 'LIST + (PROG (G168372) + (SPADLET G168372 NIL) + (RETURN + (DO + ((G168377 |Tl| + (CDR G168377)) + (T$ NIL)) + ((OR (ATOM G168377) + (PROGN + (SETQ T$ + (CAR G168377)) + NIL)) + (NREVERSE0 G168372)) + (SEQ + (EXIT + (SETQ G168372 + (CONS (CAR T$) + G168372)))))))) + (CONS (CONS '|List| + (CONS |mUnder| NIL)) + (CONS |e| NIL))))))))))))) + +;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] + +(DEFUN |compVector| (|l| |m| |e|) + (PROG (|LETTMP#1| |mUnder| |Tl|) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |m|) '|Vector|) (CAR |m|))) + (SPADLET |mUnder| (CADR |m|)) + (|markImport| |m|) + (|markImport| |mUnder|) + (COND + ((NULL |l|) + (CONS |$EmptyVector| (CONS |m| (CONS |e| NIL)))) + ('T + (SPADLET |Tl| + (PROG (G168422) + (SPADLET G168422 NIL) + (RETURN + (DO ((G168431 |l| (CDR G168431)) + (|x| NIL)) + ((OR (ATOM G168431) + (PROGN + (SETQ |x| (CAR G168431)) + NIL)) + (NREVERSE0 G168422)) + (SEQ (EXIT + (SETQ G168422 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| |x| |mUnder| |e|) + (RETURN '|failed|))) + (SPADLET |mUnder| + (CADR |LETTMP#1|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G168422)))))))) + (COND + ((BOOT-EQUAL |Tl| '|failed|) NIL) + ('T + (CONS (CONS 'VECTOR + (PROG (G168441) + (SPADLET G168441 NIL) + (RETURN + (DO + ((G168446 |Tl| (CDR G168446)) + (T$ NIL)) + ((OR (ATOM G168446) + (PROGN + (SETQ T$ (CAR G168446)) + NIL)) + (NREVERSE0 G168441)) + (SEQ + (EXIT + (SETQ G168441 + (CONS (CAR T$) G168441)))))))) + (CONS |m| (CONS |e| NIL)))))))))))) + +;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] + +(DEFUN |compColon| (G168534 |m| |e|) + (PROG (|$lhsOfColon| |f| |t'| |m'| |r| |t| |l| |LETTMP#1| T$ |op| + |argl| |newTarget| |a| |signature| |ISTMP#1| |catform| + |ISTMP#2|) + (DECLARE (SPECIAL |$lhsOfColon|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G168534) '|:|) (CAR G168534))) + (SPADLET |f| (CADR G168534)) + (SPADLET |t| (CADDR G168534)) + (COND + ((BOOT-EQUAL |$insideExpressionIfTrue| 'T) + (|compPretend| + (CONS '|pretend| (CONS |f| (CONS |t| NIL))) |m| + |e|)) + ('T (SPADLET |f| (|markKillAll| |f|)) + (SPADLET |$lhsOfColon| |f|) + (SPADLET |t| + (PROGN + (SPADLET |t| (|markKillAll| |t|)) + (COND + ((AND (ATOM |t|) + (SPADLET |t'| + (|assoc| |t| + (|getDomainsInScope| |e|)))) + |t'|) + ((AND (|isDomainForm| |t| |e|) + (NULL |$insideCategoryIfTrue|)) + (COND + ((NULL (|member| |t| + (|getDomainsInScope| |e|))) + (SPADLET |e| (|addDomain| |t| |e|)))) + |t|) + ((OR (|isDomainForm| |t| |e|) + (|isCategoryForm| |t| |e|)) + |t|) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m'| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + |t|) + ('T (|unknownTypeError| |t|) |t|)))) + (COND + (|$insideCapsuleFunctionIfTrue| + (|markDeclaredImport| |t|))) + (COND + ((AND (PAIRP |f|) (EQ (QCAR |f|) 'LISTOF) + (PROGN (SPADLET |l| (QCDR |f|)) 'T)) + (DO ((G168585 |l| (CDR G168585)) (|x| NIL)) + ((OR (ATOM G168585) + (PROGN (SETQ |x| (CAR G168585)) NIL)) + NIL) + (SEQ (EXIT (SPADLET T$ + (PROGN + (SPADLET |LETTMP#1| + (|compColon| + (CONS '|:| + (CONS |x| (CONS |t| NIL))) + |m| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|))))) + T$) + ('T + (SPADLET |e| + (COND + ((AND (PAIRP |f|) + (PROGN + (SPADLET |op| (QCAR |f|)) + (SPADLET |argl| (QCDR |f|)) + 'T) + (NULL + (AND (PAIRP |t|) + (EQ (QCAR |t|) '|Mapping|)))) + (SPADLET |newTarget| + (EQSUBSTLIST + (TAKE (|#| |argl|) + |$FormalMapVariableList|) + (PROG (G168602) + (SPADLET G168602 NIL) + (RETURN + (DO + ((G168614 |argl| + (CDR G168614)) + (|x| NIL)) + ((OR (ATOM G168614) + (PROGN + (SETQ |x| + (CAR G168614)) + NIL)) + (NREVERSE0 G168602)) + (SEQ + (EXIT + (SETQ G168602 + (CONS + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|:|) + (PROGN + (SPADLET + |ISTMP#1| + (QCDR |x|)) + (AND + (PAIRP + |ISTMP#1|) + (PROGN + (SPADLET + |a| + (QCAR + |ISTMP#1|)) + (SPADLET + |ISTMP#2| + (QCDR + |ISTMP#1|)) + (AND + (PAIRP + |ISTMP#2|) + (EQ + (QCDR + |ISTMP#2|) + NIL) + (PROGN + (SPADLET + |m| + (QCAR + |ISTMP#2|)) + 'T)))))) + |a|) + ('T |x|)) + G168602))))))) + |t|)) + (SPADLET |signature| + (CONS '|Mapping| + (CONS |newTarget| + (PROG (G168631) + (SPADLET G168631 NIL) + (RETURN + (DO + ((G168643 |argl| + (CDR G168643)) + (|x| NIL)) + ((OR (ATOM G168643) + (PROGN + (SETQ |x| + (CAR G168643)) + NIL)) + (NREVERSE0 G168631)) + (SEQ + (EXIT + (SETQ G168631 + (CONS + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|:|) + (PROGN + (SPADLET + |ISTMP#1| + (QCDR |x|)) + (AND + (PAIRP + |ISTMP#1|) + (PROGN + (SPADLET + |a| + (QCAR + |ISTMP#1|)) + (SPADLET + |ISTMP#2| + (QCDR + |ISTMP#1|)) + (AND + (PAIRP + |ISTMP#2|) + (EQ + (QCDR + |ISTMP#2|) + NIL) + (PROGN + (SPADLET + |m| + (QCAR + |ISTMP#2|)) + 'T)))))) + |m|) + ('T + (OR + (|getmode| |x| + |e|) + (|systemErrorHere| + (MAKESTRING + "compColonOld"))))) + G168631)))))))))) + (|put| |op| '|mode| |signature| |e|)) + ('T (|put| |f| '|mode| |t| |e|)))) + (COND + ((AND (NULL |$bootStrapMode|) + |$insideFunctorIfTrue| + (PROGN + (SPADLET |ISTMP#1| + (|makeCategoryForm| |t| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |catform| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |e| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |e| + (|put| |f| '|value| + (CONS (|genSomeVariable|) + (CONS |t| (CONS |$noEnv| NIL))) + |e|)))) + (CONS '|/throwAway| + (CONS (|getmode| |f| |e|) (CONS |e| NIL)))))))))))) + +;compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) + +(DEFUN |compConstruct| (|form| |m| |e|) + (PROG (T$) + (RETURN + (AND (SPADLET T$ (|compConstruct1| |form| |m| |e|)) + (|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' + +(DEFUN |compConstruct1| (|form| |m| |e|) + (PROG (|l| |y| T$ |T'|) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |form|) '|construct|) (CAR |form|))) + (SPADLET |l| (CDR |form|)) + (SEQ (COND + ((SPADLET |y| + (|modeIsAggregateOf| '|List| |m| |e|)) + (COND + ((SPADLET T$ + (|compList| |l| + (CONS '|List| + (CONS (CADR |y|) NIL)) + |e|)) + (EXIT (|convert| T$ |m|))))) + ((SPADLET |y| + (|modeIsAggregateOf| '|Vector| |m| |e|)) + (COND + ((SPADLET T$ + (|compVector| |l| + (CONS '|Vector| + (CONS (CADR |y|) NIL)) + |e|)) + (EXIT (|convert| T$ |m|))))) + ((SPADLET T$ (|compForm| |form| |m| |e|)) T$) + ('T + (DO ((G168706 (|getDomainsInScope| |e|) + (CDR G168706)) + (D NIL)) + ((OR (ATOM G168706) + (PROGN (SETQ D (CAR G168706)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND + (SPADLET |y| + (|modeIsAggregateOf| '|List| D + |e|)) + (SPADLET T$ + (|compList| |l| + (CONS '|List| + (CONS (CADR |y|) NIL)) + |e|)) + (SPADLET |T'| (|convert| T$ |m|))) + (RETURN |T'|)) + ((AND + (SPADLET |y| + (|modeIsAggregateOf| '|Vector| D + |e|)) + (SPADLET T$ + (|compVector| |l| + (CONS '|Vector| + (CONS (CADR |y|) NIL)) + |e|)) + (SPADLET |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 + +(DEFUN |compPretend| (|u| |m| |e|) + (PROG (|x| |t| T$ |warningMessage| T1 |T'|) + (RETURN + (PROGN + (COND ((EQ (CAR |u|) '|pretend|) (CAR |u|))) + (SPADLET |x| (CADR |u|)) + (SPADLET |t| (CADDR |u|)) + (SPADLET |t| (|markKillAll| |t|)) + (SPADLET |m| (|markKillAll| |m|)) + (SPADLET |e| (|addDomain| |t| |e|)) + (SPADLET T$ + (OR (|comp| |x| |t| |e|) (|comp| |x| |$EmptyMode| |e|) + (RETURN NIL))) + (COND + ((BOOT-EQUAL (CADR T$) |t|) + (SPADLET |warningMessage| + (CONS '|pretend| + (CONS |t| + (CONS '| -- should replace by @| NIL)))))) + (SPADLET T1 (CONS (CAR T$) (CONS |t| (CONS (CADDR T$) NIL)))) + (COND + ((AND (BOOT-EQUAL |t| '$) (BOOT-EQUAL |m| '|Rep|)) + (|markPretend| T1 T1)) + ((SPADLET |T'| (|coerce| T1 |m|)) + (COND + (|warningMessage| (|stackWarning| |warningMessage|) + (|markCompColonInside| '@ |T'|)) + ('T (|markPretend| T1 |T'|)))) + ('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) + +(DEFUN |compAtSign| (G168753 |m| |e|) + (PROG (|x| |m'| T$) + (RETURN + (PROGN + (COND ((EQ (CAR G168753) '@) (CAR G168753))) + (SPADLET |x| (CADR G168753)) + (SPADLET |m'| (CADDR G168753)) + (SPADLET |m'| (|markKillAll| |m'|)) + (SPADLET |m| (|markKillAll| |m|)) + (SPADLET |e| (|addDomain| |m'| |e|)) + (SPADLET T$ (OR (|comp| |x| |m'| |e|) (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 + +(DEFUN |compColonInside| (|x| |m| |e| |m'|) + (PROG (|warningMessage| T$ |T'|) + (RETURN + (PROGN + (SPADLET |m'| (|markKillAll| |m'|)) + (SPADLET |e| (|addDomain| |m'| |e|)) + (SPADLET T$ (OR (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) + (COND + ((BOOT-EQUAL (CADR T$) |m'|) + (SPADLET |warningMessage| + (CONS '|:| + (CONS |m'| + (CONS '| -- should replace by ::| NIL)))))) + (SPADLET T$ (CONS (CAR T$) (CONS |m'| (CONS (CADDR T$) NIL)))) + (SPADLET |m| (|markKillAll| |m|)) + (COND + ((SPADLET |T'| (|coerce| T$ |m|)) + (COND + (|warningMessage| (|stackWarning| |warningMessage|) + (|markCompColonInside| '@ |T'|)) + ('T + (|stackWarning| + (CONS '|:| + (CONS |m'| + (CONS '| -- should replace by pretend| + NIL)))) + (|markCompColonInside| '|pretend| |T'|)))) + ('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 + +(DEFUN |resolve| (|min| |mout|) + (PROG (|din| |dout|) + (RETURN + (PROGN + (SPADLET |din| (|markKillAll| |min|)) + (SPADLET |dout| (|markKillAll| |mout|)) + (COND + ((OR (BOOT-EQUAL |din| |$NoValueMode|) + (BOOT-EQUAL |dout| |$NoValueMode|)) + |$NoValueMode|) + ((BOOT-EQUAL |dout| |$EmptyMode|) |din|) + ((AND (STRINGP |din|) (BOOT-EQUAL |dout| '(|Symbol|))) + |dout|) + ((AND (STRINGP |dout|) (BOOT-EQUAL |din| '(|Symbol|))) |din|) + ((AND (NEQUAL |din| |dout|) + (OR (STRINGP |din|) (STRINGP |dout|))) + (COND + ((|modeEqual| |dout| |$String|) |dout|) + ((|modeEqual| |din| |$String|) NIL) + ('T (|mkUnion| |din| |dout|)))) + ('T |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) + +(DEFUN |coerce| (T$ |m|) + (PROG (|T'|) + (RETURN + (PROGN + (SPADLET T$ + (CONS (CAR T$) + (CONS (|markKillAll| (CADR T$)) + (CONS (CADDR T$) NIL)))) + (SPADLET |m| (|markKillAll| |m|)) + (COND + ((NULL (|get| |m| '|isLiteral| (CADDR T$))) + (|markImport| |m|))) + (COND + (|$InteractiveMode| + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "coerce") + (CONS (MAKESTRING + "function coerce called from the interpreter.") + NIL)))) + ((SPADLET |T'| (|coerce0| T$ |m|)) |T'|) + ('T + (SPADLET T$ + (CONS (CAR T$) + (CONS (|fullSubstitute| '$ |$Representation| + (CADR T$)) + (CONS (CADDR T$) NIL)))) + (|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"] + +(DEFUN |coerce0,fn| (|x| |m1| |m2|) + (CONS '|Cannot coerce| + (CONS '|%b| + (CONS |x| + (CONS '|%d| + (CONS '|%l| + (CONS '| of mode| + (CONS '|%b| + (CONS |m1| + (CONS '|%d| + (CONS '|%l| + (CONS '| to mode| + (CONS '|%b| + (CONS |m2| + (CONS '|%d| NIL))))))))))))))) + +(DEFUN |coerce0| (T$ |m|) + (PROG (|T'|) + (RETURN + (COND + ((SPADLET |T'| (|coerceEasy| T$ |m|)) |T'|) + ((SPADLET |T'| (|coerceSubset| T$ |m|)) + (|markCoerce| T$ |T'| 'AUTOSUBSET)) + ((SPADLET |T'| (|coerceHard| T$ |m|)) + (|markCoerce| T$ |T'| 'AUTOHARD)) + ((SPADLET |T'| (|coerceExtraHard| T$ |m|)) |T'|) + ((OR (BOOT-EQUAL (CAR T$) '|$fromCoerceable$|) + (|isSomeDomainVariable| |m|)) + NIL) + ((SPADLET |T'| (|coerceRep| T$ |m|)) + (|markCoerce| T$ |T'| 'AUTOREP)) + ('T (|stackMessage| (|coerce0,fn| (CAR T$) (CADR T$) |m|))))))) + +;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 + +(DEFUN |coerceSubset| (T$ |m'|) + (PROG (|x| |m| |e| |r| |ISTMP#1| |pred|) + (RETURN + (PROGN + (SPADLET |x| (CAR T$)) + (SPADLET |m| (CADR T$)) + (SPADLET |e| (CADDR T$)) + (COND + ((BOOT-EQUAL |m| |$SmallInteger|) + (COND + ((BOOT-EQUAL |m'| |$Integer|) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ((OR (BOOT-EQUAL |m'| + (SPADLET |r| (|get| |x| '|range| |e|))) + (|isSubset| |r| |m'| |e|)) + (CONS |x| (CONS |r| (CONS |e| NIL)))) + ('T NIL))) + ((OR (|isSubset| |m| |m'| |e|) + (AND (BOOT-EQUAL |m| '|Rep|) (BOOT-EQUAL |m'| '$))) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|SubDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |m'|)))) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ((AND (SPADLET |pred| + (LASSOC (|opOf| |m'|) + (|get| (|opOf| |m|) '|SubDomain| |e|))) + (INTEGERP |x|) (|eval| (MSUBST |x| '|#1| |pred|))) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ((AND (SPADLET |pred| + (|isSubset| |m'| (|maxSuperType| |m| |e|) |e|)) + (INTEGERP |x|) (|eval| (MSUBST |x| '* |pred|))) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ('T 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 + +(DEFUN |coerceRep| (T$ |m|) + (PROG (|md|) + (RETURN + (PROGN + (SPADLET |md| (CADR T$)) + (COND + ((ATOM |md|) NIL) + ((OR (AND (CONTAINED '|Rep| |md|) + (BOOT-EQUAL (MSUBST '$ '|Rep| |md|) |m|)) + (AND (CONTAINED '|Rep| |m|) + (BOOT-EQUAL (MSUBST '$ '|Rep| |m|) |md|))) + T$) + ('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 + +(DEFUN |spadCompileOrSetq| (|form|) + (PROG (|nam| |lam| |vl| |body| |nam'| |ISTMP#1| E |vl'| |macform|) + (RETURN + (SEQ (PROGN + (SPADLET |nam| (CAR |form|)) + (SPADLET |lam| (CAADR |form|)) + (SPADLET |vl| (CADADR |form|)) + (SPADLET |body| (CAR (CDDADR |form|))) + (COND + ((CONTAINED (INTERN " " "BOOT") |body|) + (|sayBrightly| + (CONS (MAKESTRING " ") + (APPEND (|bright| |nam|) + (CONS (MAKESTRING " not compiled") + NIL))))) + ('T + (COND + ((AND (PAIRP |vl|) + (PROGN (SPADLET |ISTMP#1| (REVERSE |vl|)) 'T) + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET E (QCAR |ISTMP#1|)) + (SPADLET |vl'| (QCDR |ISTMP#1|)) + 'T) + (PROGN (SPADLET |vl'| (NREVERSE |vl'|)) 'T) + (PAIRP |body|) + (PROGN (SPADLET |nam'| (QCAR |body|)) 'T) + (EQUAL (QCDR |body|) |vl'|)) + (|LAM,EVALANDFILEACTQ| + (CONS 'PUT + (CONS (MKQ |nam|) + (CONS (MKQ '|SPADreplace|) + (CONS (MKQ |nam'|) NIL))))) + (|sayBrightly| + (CONS (MAKESTRING " ") + (APPEND (|bright| |nam|) + (CONS + (MAKESTRING "is replaced by") + (|bright| |nam'|)))))) + ((AND (OR (ATOM |body|) + (PROG (G168859) + (SPADLET G168859 'T) + (RETURN + (DO ((G168865 NIL (NULL G168859)) + (G168866 |body| (CDR G168866)) + (|x| NIL)) + ((OR G168865 (ATOM G168866) + (PROGN + (SETQ |x| (CAR G168866)) + NIL)) + G168859) + (SEQ (EXIT + (SETQ G168859 + (AND G168859 (ATOM |x|))))))))) + (PAIRP |vl|) + (PROGN (SPADLET |ISTMP#1| (REVERSE |vl|)) 'T) + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET E (QCAR |ISTMP#1|)) + (SPADLET |vl'| (QCDR |ISTMP#1|)) + 'T) + (PROGN (SPADLET |vl'| (NREVERSE |vl'|)) 'T) + (NULL (CONTAINED E |body|))) + (SPADLET |macform| + (CONS 'XLAM (CONS |vl'| (CONS |body| NIL)))) + (|LAM,EVALANDFILEACTQ| + (CONS 'PUT + (CONS (MKQ |nam|) + (CONS (MKQ '|SPADreplace|) + (CONS (MKQ |macform|) NIL))))) + (|sayBrightly| + (CONS (MAKESTRING " ") + (APPEND (|bright| |nam|) + (CONS + (MAKESTRING "is replaced by") + (|bright| |body|)))))) + ('T NIL)) + (COND + (|$insideCapsuleFunctionIfTrue| + (CAR (COMP (LIST |form|)))) + ('T (|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 + +(DEFUN |coerceHard| (T$ |m|) + (PROG (|$e| |m'| |ISTMP#1| |ISTMP#2| |m''|) + (DECLARE (SPECIAL |$e| |$bootStrapMode| |$String|)) + (RETURN + (PROGN + (SPADLET |$e| (CADDR T$)) + (SPADLET |m'| (CADR T$)) + (COND + ((AND (STRINGP |m'|) (|modeEqual| |m| |$String|)) + (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) + ((OR (|modeEqual| |m'| |m|) + (AND (OR (PROGN + (SPADLET |ISTMP#1| + (|get| |m'| '|value| |$e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m''| (QCAR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#1| (|getmode| |m'| |$e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |m''| + (QCAR |ISTMP#2|)) + 'T)))))) + (|modeEqual| |m''| |m|)) + (AND (OR (PROGN + (SPADLET |ISTMP#1| (|get| |m| '|value| |$e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m''| (QCAR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#1| (|getmode| |m| |$e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |m''| + (QCAR |ISTMP#2|)) + 'T)))))) + (|modeEqual| |m''| |m'|))) + (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))) + ((AND (STRINGP (CAR T$)) (BOOT-EQUAL (CAR T$) |m|)) + (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) + ((|isCategoryForm| |m| |$e|) + (COND + ((BOOT-EQUAL |$bootStrapMode| 'T) + (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) + ((|extendsCategoryForm| (CAR T$) (CADR T$) |m|) + (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) + ('T NIL))) + ('T 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 + +(DEFUN |coerceExtraHard| (T$ |m|) + (PROG (|x| |m'| |e| |ISTMP#1| |l| |t| |T'| |T''|) + (declare (special |$Expression|)) + (RETURN + (PROGN + (SPADLET |x| (CAR T$)) + (SPADLET |m'| (CADR T$)) + (SPADLET |e| (CADDR T$)) + (COND + ((SPADLET |T'| (|autoCoerceByModemap| T$ |m|)) |T'|) + ((AND (PROGN + (SPADLET |ISTMP#1| (|isUnionMode| |m'| |e|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Union|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T))) + (SPADLET |t| (|hasType| |x| |e|)) (|member| |t| |l|) + (SPADLET |T'| (|autoCoerceByModemap| T$ |t|)) + (SPADLET |T''| (|coerce| |T'| |m|))) + |T''|) + ((AND (PAIRP |m'|) (EQ (QCAR |m'|) '|Record|) + (BOOT-EQUAL |m| |$Expression|)) + (CONS (CONS '|coerceRe2E| + (CONS |x| + (CONS (CONS 'ELT + (CONS (COPY |m'|) (CONS 0 NIL))) + NIL))) + (CONS |m| (CONS |e| NIL)))) + ('T 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) + +(DEFUN |compCoerce| (|u| |m| |e|) + (PROG (|x| |m'| |ISTMP#1| |ISTMP#2| |ISTMP#3| |l| T$) + (declare (special |$Integer| |$SmallInteger| |$EmptyMode|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |u|) '|::|) (CAR |u|))) + (SPADLET |x| (CADR |u|)) + (SPADLET |m'| (CADDR |u|)) + (SPADLET |m'| (|markKillAll| |m'|)) + (SPADLET |e| (|addDomain| |m'| |e|)) + (SPADLET |m| (|markKillAll| |m|)) + (COND + ((SPADLET T$ (|compCoerce1| |x| |m'| |e|)) + (|coerce| T$ |m|)) + ('T + (SPADLET T$ + (OR (|comp| |x| |$EmptyMode| |e|) + (RETURN NIL))) + (COND + ((AND (BOOT-EQUAL (CADR T$) |$SmallInteger|) + (MEMQ (|opOf| |m|) + '(|NonNegativeInteger| |PositiveInteger|))) + (|compCoerce| + (CONS '|::| + (CONS (CONS '|::| + (CONS |x| (CONS |$Integer| NIL))) + (CONS |m'| NIL))) + |m| |e|)) + ((PROGN + (SPADLET |ISTMP#1| (|getmode| |m'| |e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) + '|UnionCategory|) + (PROGN + (SPADLET |l| (QCDR |ISTMP#3|)) + 'T))))))) + (SPADLET |l| + (PROG (G169011) + (SPADLET G169011 NIL) + (RETURN + (DO ((G169016 |l| (CDR G169016)) + (|x| NIL)) + ((OR (ATOM G169016) + (PROGN + (SETQ |x| (CAR G169016)) + NIL)) + (NREVERSE0 G169011)) + (SEQ (EXIT + (SETQ G169011 + (CONS (|markKillAll| |x|) + G169011)))))))) + (SPADLET T$ + (OR (PROG (G169022) + (SPADLET G169022 NIL) + (RETURN + (DO + ((G169028 NIL G169022) + (G169029 |l| (CDR G169029)) + (|m1| NIL)) + ((OR G169028 (ATOM G169029) + (PROGN + (SETQ |m1| (CAR G169029)) + NIL)) + G169022) + (SEQ + (EXIT + (SETQ G169022 + (OR G169022 + (|compCoerce1| |x| |m1| |e|)))))))) + (RETURN NIL))) + (|coerce| + (CONS (CAR T$) + (CONS |m'| (CONS (CADDR T$) NIL))) + |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] + +(DEFUN |compCoerce1| (|x| |m'| |e|) + (PROG (|m1| T$ |T'| |gg| |pred| |code|) + (declare (special |$String| |$EmptyMode|)) + (RETURN + (PROGN + (SPADLET T$ (|comp| |x| |m'| |e|)) + (COND ((NULL T$) (SPADLET T$ (|comp| |x| |$EmptyMode| |e|)))) + (COND + ((NULL T$) (RETURN NIL)) + ('T + (SPADLET |m1| + (COND + ((STRINGP (CADR T$)) |$String|) + ('T (CADR T$)))) + (SPADLET |m'| (|resolve| |m1| |m'|)) + (SPADLET T$ + (CONS (CAR T$) (CONS |m1| (CONS (CADDR T$) NIL)))) + (COND + ((SPADLET |T'| (|coerce| T$ |m'|)) |T'|) + ((SPADLET |T'| (|coerceByModemap| T$ |m'|)) |T'|) + ((SPADLET |pred| (|isSubset| |m'| (CADR T$) |e|)) + (PROGN + (SPADLET |gg| (GENSYM)) + (SPADLET |pred| (MSUBST |gg| '* |pred|)) + (SPADLET |code| + (CONS 'PROG1 + (CONS (CONS 'LET + (CONS |gg| (CONS (CAR T$) NIL))) + (CONS + (CONS '|check-subtype| + (CONS |pred| + (CONS (MKQ |m'|) + (CONS |gg| NIL)))) + NIL)))) + (CONS |code| (CONS |m'| (CONS (CADDR T$) NIL)))))))))))) + +;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) + +(DEFUN |coerceByModemap| (G169091 |m'|) + (PROG (|x| |m| |e| |map| |cexpr| |ISTMP#1| |t| |ISTMP#2| |s| |u| |mm| + |fn| T$) + (RETURN + (SEQ (PROGN + (SPADLET |x| (CAR G169091)) + (SPADLET |m| (CADR G169091)) + (SPADLET |e| (CADDR G169091)) + (SPADLET |u| + (OR (PROG (G169118) + (SPADLET G169118 NIL) + (RETURN + (DO ((G169125 + (|getModemapList| '|coerce| 1 |e|) + (CDR G169125)) + (|modemap| NIL)) + ((OR (ATOM G169125) + (PROGN + (SETQ |modemap| (CAR G169125)) + NIL) + (PROGN + (PROGN + (SPADLET |map| (CAR |modemap|)) + (SPADLET |cexpr| + (CADR |modemap|)) + |modemap|) + NIL)) + (NREVERSE0 G169118)) + (SEQ (EXIT + (COND + ((AND (PAIRP |map|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |map|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#2|)) + 'T))))) + (OR (|modeEqual| |t| |m'|) + (|isSubset| |t| |m'| |e|)) + (OR (|modeEqual| |s| |m|) + (|isSubset| |m| |s| |e|))) + (SETQ G169118 + (CONS |modemap| G169118))))))))) + (RETURN NIL))) + (SPADLET |mm| (CAR |u|)) + (SPADLET |fn| (|genDeltaEntry| (CONS '|coerce| |mm|))) + (SPADLET T$ + (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) + (CONS |m'| (CONS |e| NIL)))) + (|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) + +(DEFUN |autoCoerceByModemap| (G169173 |target|) + (PROG (|x| |source| |e| |map| |cexpr| |ISTMP#1| |t| |ISTMP#2| |s| |u| + |cond| |selfn| |fn|) + (RETURN + (SEQ (PROGN + (SPADLET |x| (CAR G169173)) + (SPADLET |source| (CADR G169173)) + (SPADLET |e| (CADDR G169173)) + (SPADLET |u| + (OR (PROG (G169203) + (SPADLET G169203 NIL) + (RETURN + (DO ((G169210 + (|getModemapList| '|autoCoerce| 1 + |e|) + (CDR G169210)) + (|modemap| NIL)) + ((OR (ATOM G169210) + (PROGN + (SETQ |modemap| (CAR G169210)) + NIL) + (PROGN + (PROGN + (SPADLET |map| (CAR |modemap|)) + (SPADLET |cexpr| + (CADR |modemap|)) + |modemap|) + NIL)) + (NREVERSE0 G169203)) + (SEQ (EXIT + (COND + ((AND (PAIRP |map|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |map|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#2|)) + 'T))))) + (|modeEqual| |t| |target|) + (|modeEqual| |s| |source|)) + (SETQ G169203 + (CONS |cexpr| G169203))))))))) + (RETURN NIL))) + (SPADLET |fn| + (OR (PROG (G169217) + (SPADLET G169217 NIL) + (RETURN + (DO ((G169225 NIL G169217) + (G169226 |u| (CDR G169226)) + (G169168 NIL)) + ((OR G169225 (ATOM G169226) + (PROGN + (SETQ G169168 (CAR G169226)) + NIL) + (PROGN + (PROGN + (SPADLET |cond| + (CAR G169168)) + (SPADLET |selfn| + (CADR G169168)) + G169168) + NIL)) + G169217) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |cond| 'T) + (SETQ G169217 + (OR G169217 |selfn|))))))))) + (RETURN NIL))) + (|markCoerceByModemap| |x| |source| |target| + (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) + (CONS |target| (CONS |e| NIL))) + 'T)))))) + +;--====================================================================== +;-- 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) + +(DEFUN |comp3| (|x| |m| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|e| |a| |op| |ml| |u| |sig| |varlist| |ISTMP#3| |body| |t| + |x'| |ISTMP#1| |m'| |ISTMP#2| |e'|) + (declare (special |$insideCompTypeOf| |$e|)) + (RETURN + (PROGN + (SPADLET |$e| (|addDomain| |m| |$e|)) + (SPADLET |e| |$e|) + (COND + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Mapping|)) + (|compWithMappingMode| |x| |m| |e|)) + ((AND (PAIRP |m|) (EQ (QCAR |m|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((BOOT-EQUAL |x| |a|) + (CONS |x| (CONS |m| (CONS |$e| NIL)))) + ('T NIL))) + ((STRINGP |m|) + (COND + ((ATOM |x|) + (COND + ((OR (BOOT-EQUAL |m| |x|) + (BOOT-EQUAL |m| (STRINGIMAGE |x|))) + (CONS |m| (CONS |m| (CONS |e| NIL)))) + ('T NIL))) + ('T NIL))) + ((OR (NULL |x|) (ATOM |x|)) (|compAtom| |x| |m| |e|)) + ('T (SPADLET |op| (CAR |x|)) + (COND + ((AND (PROGN + (SPADLET |ISTMP#1| (|getmode| |op| |e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN (SPADLET |ml| (QCDR |ISTMP#1|)) 'T))) + (SPADLET |u| (|applyMapping| |x| |m| |e| |ml|))) + |u|) + ((AND (PAIRP |op|) (EQ (QCAR |op|) 'KAPPA) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |varlist| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |body| (QCAR |ISTMP#3|)) + 'T)))))))) + (|compApply| |sig| |varlist| |body| (CDR |x|) |m| |e|)) + ((BOOT-EQUAL |op| '|:|) (|compColon| |x| |m| |e|)) + ((BOOT-EQUAL |op| '|::|) (|compCoerce| |x| |m| |e|)) + ((AND (NULL (BOOT-EQUAL |$insideCompTypeOf| 'T)) + (|stringPrefix?| (MAKESTRING "TypeOf") (PNAME |op|))) + (|compTypeOf| |x| |m| |e|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PART)) + (|compPART| |x| |m| |e|)) + ('T (SPADLET |t| (|qt| 14 (|compExpression| |x| |m| |e|))) + (COND + ((AND (PAIRP |t|) + (PROGN + (SPADLET |x'| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m'| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |e'| (QCAR |ISTMP#2|)) + 'T))))) + (NULL (|member| |m'| (|getDomainsInScope| |e'|)))) + (|qt| 15 + (CONS |x'| + (CONS |m'| + (CONS (|addDomain| |m'| |e'|) NIL))))) + ('T (|qt| 16 |t|))))))))))) + +;yyyyy x == x + +(DEFUN |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:= GET(first x,"SPECIAL")) => +; FUNCALL(fn,x,m,e) +; compForm(x,m,e) + +(DEFUN |compExpression| (|x| |m| |e|) + (PROG (|$insideExpressionIfTrue| |ISTMP#1| |ISTMP#2| |ISTMP#3| + |ISTMP#4| |w| |ISTMP#5| |ISTMP#6| |ISTMP#7| |ISTMP#8| B + |ISTMP#9| |ISTMP#10| |ISTMP#11| |ISTMP#12| |ISTMP#13| + |ISTMP#14| |ISTMP#15| |ISTMP#16| |ISTMP#17| |ISTMP#18| |l| + |fn|) + (DECLARE (SPECIAL |$insideExpressionIfTrue|)) + (RETURN + (PROGN + (SPADLET |$insideExpressionIfTrue| 'T) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'PART) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |w| + (QCAR |ISTMP#4|)) + 'T))))))) + (PROGN + (SPADLET |ISTMP#5| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |ISTMP#6| (QCAR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (PROGN + (SPADLET |ISTMP#7| + (QCAR |ISTMP#6|)) + (AND (PAIRP |ISTMP#7|) + (EQ (QCAR |ISTMP#7|) '|elt|) + (PROGN + (SPADLET |ISTMP#8| + (QCDR |ISTMP#7|)) + (AND (PAIRP |ISTMP#8|) + (PROGN + (SPADLET B + (QCAR |ISTMP#8|)) + (SPADLET |ISTMP#9| + (QCDR |ISTMP#8|)) + (AND (PAIRP |ISTMP#9|) + (EQ (QCDR |ISTMP#9|) NIL) + (EQ (QCAR |ISTMP#9|) + '|new|))))))) + (PROGN + (SPADLET |ISTMP#10| + (QCDR |ISTMP#6|)) + (AND (PAIRP |ISTMP#10|) + (PROGN + (SPADLET |ISTMP#11| + (QCAR |ISTMP#10|)) + (AND (PAIRP |ISTMP#11|) + (EQ (QCAR |ISTMP#11|) 'PART) + (PROGN + (SPADLET |ISTMP#12| + (QCDR |ISTMP#11|)) + (AND (PAIRP |ISTMP#12|) + (PROGN + (SPADLET |ISTMP#13| + (QCDR |ISTMP#12|)) + (AND (PAIRP |ISTMP#13|) + (EQ (QCDR |ISTMP#13|) + NIL) + (PROGN + (SPADLET |ISTMP#14| + (QCAR |ISTMP#13|)) + (AND + (PAIRP |ISTMP#14|) + (EQ + (QCAR |ISTMP#14|) + '|#|) + (PROGN + (SPADLET + |ISTMP#15| + (QCDR + |ISTMP#14|)) + (AND + (PAIRP + |ISTMP#15|) + (EQ + (QCDR + |ISTMP#15|) + NIL) + (PROGN + (SPADLET + |ISTMP#16| + (QCAR + |ISTMP#15|)) + (AND + (PAIRP + |ISTMP#16|) + (EQ + (QCAR + |ISTMP#16|) + 'PART) + (PROGN + (SPADLET + |ISTMP#17| + (QCDR + |ISTMP#16|)) + (AND + (PAIRP + |ISTMP#17|) + (PROGN + (SPADLET + |ISTMP#18| + (QCDR + |ISTMP#17|)) + (AND + (PAIRP + |ISTMP#18|) + (EQ + (QCDR + |ISTMP#18|) + NIL) + (PROGN + (SPADLET + |l| + (QCAR + |ISTMP#18|)) + 'T)))))))))))))))))))))))))) + (|yyyyy| |x|))) + (SPADLET |x| (|compRenameOp| |x|)) + (COND + ((AND (ATOM (CAR |x|)) + (SPADLET |fn| (GETL (CAR |x|) 'SPECIAL))) + (FUNCALL |fn| |x| |m| |e|)) + ('T (|compForm| |x| |m| |e|))))))) + +;compRenameOp x == ----------> new 12/3/94 +; x is [op,:r] and op is ['PART,.,op1] => +; [op1,:r] +; x + +(DEFUN |compRenameOp| (|x|) + (PROG (|op| |r| |ISTMP#1| |ISTMP#2| |op1|) + (RETURN + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |r| (QCDR |x|)) + 'T) + (PAIRP |op|) (EQ (QCAR |op|) 'PART) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |op1| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS |op1| |r|)) + ('T |x|))))) + +;compCase(["case",x,m1],m,e) == +; m' := markKillAll m1 +; e:= addDomain(m',e) +; T:= compCase1(x,m',e) => coerce(T,m) +; nil + +(DEFUN |compCase| (G169646 |m| |e|) + (PROG (|x| |m1| |m'| T$) + (RETURN + (PROGN + (COND ((EQ (CAR G169646) '|case|) (CAR G169646))) + (SPADLET |x| (CADR G169646)) + (SPADLET |m1| (CADDR G169646)) + (SPADLET |m'| (|markKillAll| |m1|)) + (SPADLET |e| (|addDomain| |m'| |e|)) + (COND + ((SPADLET T$ (|compCase1| |x| |m'| |e|)) (|coerce| T$ |m|)) + ('T 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'])) + +(DEFUN |compCase1| (|x| |m| |e|) + (PROG (|a| |LETTMP#1| |x'| |e'| |m'| |switchMode| |r| |map| |ISTMP#1| + |ISTMP#2| |s| |ISTMP#3| |t| |mml| |cexpr| |u| |cond| + |selfn| |fn| |tag| |x1|) + (declare (special |$Boolean| |$EmptyMode|)) + (RETURN + (SEQ (PROGN + (SPADLET |x1| + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PART) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#2|)) + 'T)))))) + |a|) + ('T |x|))) + (SPADLET |LETTMP#1| + (OR (|comp| |x1| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |x'| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e'| (CADDR |LETTMP#1|)) + (COND + ((BOOT-EQUAL |m'| '$) + (AND (SPADLET |m'| (IFCAR (|get| '|Rep| '|value| |e|))) + (SPADLET |switchMode| 'T)))) + (COND + ((NULL (AND (PAIRP |m'|) (EQ (QCAR |m'|) '|Union|) + (PROGN (SPADLET |r| (QCDR |m'|)) 'T))) + NIL) + ('T + (SPADLET |mml| + (OR (PROG (G169728) + (SPADLET G169728 NIL) + (RETURN + (DO ((G169735 + (|getModemapList| '|case| 2 + |e'|) + (CDR G169735)) + (|mm| NIL)) + ((OR (ATOM G169735) + (PROGN + (SETQ |mm| (CAR G169735)) + NIL) + (PROGN + (PROGN + (SPADLET |map| (CAR |mm|)) + (SPADLET |cexpr| + (CADR |mm|)) + |mm|) + NIL)) + (NREVERSE0 G169728)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |map|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |map|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#3|)) + 'T))))))) + (|modeEqual| |t| |m|) + (OR (|modeEqual| |s| |m'|) + (AND |switchMode| + (|modeEqual| |s| '$)))) + (SETQ G169728 + (CONS |mm| G169728))))))))) + (RETURN NIL))) + (SPADLET |u| + (PROG (G169747) + (SPADLET G169747 NIL) + (RETURN + (DO ((G169753 |mml| (CDR G169753)) + (G169713 NIL)) + ((OR (ATOM G169753) + (PROGN + (SETQ G169713 + (CAR G169753)) + NIL) + (PROGN + (PROGN + (SPADLET |cexpr| + (CADR G169713)) + G169713) + NIL)) + (NREVERSE0 G169747)) + (SEQ (EXIT + (SETQ G169747 + (CONS |cexpr| G169747)))))))) + (SPADLET |fn| + (OR (PROG (G169760) + (SPADLET G169760 NIL) + (RETURN + (DO ((G169768 NIL G169760) + (G169769 |u| (CDR G169769)) + (G169716 NIL)) + ((OR G169768 (ATOM G169769) + (PROGN + (SETQ G169716 + (CAR G169769)) + NIL) + (PROGN + (PROGN + (SPADLET |cond| + (CAR G169716)) + (SPADLET |selfn| + (CADR G169716)) + G169716) + NIL)) + G169760) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |cond| 'T) + (SETQ G169760 + (OR G169760 |selfn|))))))))) + (RETURN NIL))) + (SPADLET |tag| + (OR (|genCaseTag| |m| |r| 1) (RETURN NIL))) + (SPADLET |x1| + (COND + (|switchMode| (|markRepper| '|rep| |x|)) + ('T |x|))) + (|markCase| |x| |tag| + (|markCaseWas| |x1| + (CONS (CONS '|call| + (CONS |fn| (CONS |x'| NIL))) + (CONS |$Boolean| (CONS |e'| NIL)))))))))))) + +;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 + +(DEFUN |genCaseTag| (|t| |l| |n|) + (PROG (|x| |ISTMP#1|) + (RETURN + (COND + ((AND (PAIRP |l|) + (PROGN + (SPADLET |x| (QCAR |l|)) + (SPADLET |l| (QCDR |l|)) + 'T)) + (COND + ((BOOT-EQUAL |x| |t|) + (COND + ((STRINGP |x|) (INTERN |x|)) + ('T (INTERN (STRCONC '|value| (STRINGIMAGE |n|)))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|::|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |t|)))) + |t|) + ((STRINGP |x|) (|genCaseTag| |t| |l| |n|)) + ('T (|genCaseTag| |t| |l| (PLUS |n| 1))))) + ('T 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] + +(DEFUN |compIf,Env| (|bEnv| |cEnv| |b| |c| E) + (SEQ (IF (|canReturn| |b| 0 0 'T) + (EXIT (SEQ (IF (|canReturn| |c| 0 0 'T) + (EXIT (|intersectionEnvironment| |bEnv| + |cEnv|))) + (EXIT |bEnv|)))) + (IF (|canReturn| |c| 0 0 'T) (EXIT |cEnv|)) (EXIT E))) + +(DEFUN |compIf| (G169859 |m| E) + (PROG (|aOrig| |b| |c| |a| |LETTMP#1| |xa| |ma| |Ea| |Einv| |Tb| |xb| + |mb| |Eb| |Tc| |xc| |mc| |Ec| |xb'| |x| |returnEnv|) + (declare (special |$Boolean|)) + (RETURN + (PROGN + (COND ((EQ (CAR G169859) 'IF) (CAR G169859))) + (SPADLET |aOrig| (CADR G169859)) + (SPADLET |b| (CADDR G169859)) + (SPADLET |c| (CADDDR G169859)) + (SPADLET |a| (|markKillButIfs| |aOrig|)) + (SPADLET |LETTMP#1| + (OR (|compBoolean| |a| |aOrig| |$Boolean| E) + (RETURN NIL))) + (SPADLET |xa| (CAR |LETTMP#1|)) + (SPADLET |ma| (CADR |LETTMP#1|)) + (SPADLET |Ea| (CADDR |LETTMP#1|)) + (SPADLET |Einv| (CADDDR |LETTMP#1|)) + (SPADLET |Tb| (OR (|compFromIf| |b| |m| |Ea|) (RETURN NIL))) + (SPADLET |xb| (CAR |Tb|)) + (SPADLET |mb| (CADR |Tb|)) + (SPADLET |Eb| (CADDR |Tb|)) + (SPADLET |Tc| + (OR (|compFromIf| |c| (|resolve| |mb| |m|) |Einv|) + (RETURN NIL))) + (SPADLET |xc| (CAR |Tc|)) + (SPADLET |mc| (CADR |Tc|)) + (SPADLET |Ec| (CADDR |Tc|)) + (SPADLET |xb'| (OR (|coerce| |Tb| |mc|) (RETURN NIL))) + (SPADLET |x| + (CONS 'IF + (CONS |xa| + (CONS (|quotify| (CAR |xb'|)) + (CONS (|quotify| |xc|) NIL))))) + (SPADLET |returnEnv| + (|compIf,Env| (CADDR |xb'|) |Ec| (CAR |xb'|) |xc| E)) + (CONS |x| (CONS |mc| (CONS |returnEnv| NIL))))))) + +;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)] + +(DEFUN |compBoolean| (|p| |pWas| |m| |Einit|) + (PROG (|op| |fop| T$ |LETTMP#1| |p'| E) + (RETURN + (PROGN + (SPADLET |op| (|opOf| |p|)) + (SPADLET |LETTMP#1| + (COND + ((SPADLET |fop| + (LASSOC |op| + '((|and| . |compAnd|) + (|or| . |compOr|) + (|not| . |compNot|)))) + (OR (APPLY |fop| + (CONS |p| + (CONS |pWas| + (CONS |m| (CONS |Einit| NIL))))) + (RETURN NIL))) + ('T + (SPADLET T$ + (OR (|comp| |p| |m| |Einit|) (RETURN NIL))) + (|markAny| '|compBoolean| |pWas| T$)))) + (SPADLET |p'| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET E (CADDR |LETTMP#1|)) + (CONS |p'| + (CONS |m| + (CONS (|getSuccessEnvironment| (|markKillAll| |p|) + E) + (CONS (|getInverseEnvironment| + (|markKillAll| |p|) E) + NIL)))))))) + +;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) + +(DEFUN |compAnd| (G169938 |pWas| |m| |e|) + (PROG (|op| |args| T$ |cargs|) + (declare (special |$Boolean|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G169938)) + (SPADLET |args| (CDR G169938)) + (SPADLET |cargs| + (PROG (G169955) + (SPADLET G169955 NIL) + (RETURN + (DO ((G169961 |args| (CDR G169961)) + (|x| NIL)) + ((OR (ATOM G169961) + (PROGN + (SETQ |x| (CAR G169961)) + NIL)) + (NREVERSE0 G169955)) + (SEQ (EXIT (COND + ((PROGN + (SPADLET T$ + (OR + (|compBoolean| |x| |x| + |$Boolean| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDR T$)) + T$) + (SETQ G169955 + (CONS (CAR T$) G169955)))))))))) + (COND + ((NULL |cargs|) NIL) + ('T + (|coerce| + (|markAny| '|compAnd| |pWas| + (CONS (CONS 'AND |cargs|) + (CONS |$Boolean| (CONS |e| NIL)))) + |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) + +(DEFUN |compOr| (G169982 |pWas| |m| |e|) + (PROG (|op| |args| T$ |cargs|) + (declare (special |$Boolean|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G169982)) + (SPADLET |args| (CDR G169982)) + (SPADLET |cargs| + (PROG (G169999) + (SPADLET G169999 NIL) + (RETURN + (DO ((G170005 |args| (CDR G170005)) + (|x| NIL)) + ((OR (ATOM G170005) + (PROGN + (SETQ |x| (CAR G170005)) + NIL)) + (NREVERSE0 G169999)) + (SEQ (EXIT (COND + ((PROGN + (SPADLET T$ + (OR + (|compBoolean| |x| |x| + |$Boolean| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDDR T$)) + T$) + (SETQ G169999 + (CONS (CAR T$) G169999)))))))))) + (COND + ((NULL |cargs|) NIL) + ('T + (|coerce| + (|markAny| '|compOr| |pWas| + (CONS (CONS 'OR |cargs|) + (CONS |$Boolean| (CONS |e| NIL)))) + |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) + +(DEFUN |compNot| (G170030 |pWas| |m| |e|) + (PROG (|op| |arg| |LETTMP#1| |x| |m1| |ei|) + (declare (special |$Boolean|)) + (RETURN + (PROGN + (SPADLET |op| (CAR G170030)) + (SPADLET |arg| (CADR G170030)) + (SPADLET |LETTMP#1| + (OR (|compBoolean| |arg| |arg| |$Boolean| |e|) + (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |m1| (CADR |LETTMP#1|)) + (SPADLET |ei| (CADDDR |LETTMP#1|)) + (|coerce| + (|markAny| '|compNot| |pWas| + (CONS (CONS 'NOT (CONS |x| NIL)) + (CONS |$Boolean| (CONS |ei| NIL)))) + |m|))))) + +;compDefine(form,m,e) == +; $tripleCache: local:= nil +; $tripleHits: local:= 0 +; $macroIfTrue: local +; $packagesUsed: local +; ['DEF,.,originalSignature,.,body] := form +; if not $insideFunctorIfTrue then +; $originalBody := COPY body +; compDefine1(form,m,e) + +(DEFUN |compDefine| (|form| |m| |e|) + (PROG (|$tripleCache| |$tripleHits| |$macroIfTrue| |$packagesUsed| + |originalSignature| |body|) + (DECLARE (SPECIAL |$tripleCache| |$tripleHits| |$macroIfTrue| + |$packagesUsed| |$originalBody| |$insideFunctorIfTrue|)) + (RETURN + (PROGN + (SPADLET |$tripleCache| NIL) + (SPADLET |$tripleHits| 0) + (SPADLET |$macroIfTrue| NIL) + (SPADLET |$packagesUsed| NIL) + (SPADLET |originalSignature| (CADDR |form|)) + (SPADLET |body| (CAR (CDDDDR |form|))) + (COND + ((NULL |$insideFunctorIfTrue|) + (SPADLET |$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) + +(DEFUN |compDefine1| (|form| |m| |e|) + (PROG (|$insideExpressionIfTrue| |lhs| |specialCases| |sig| |ISTMP#1| + |map| |signature| |rhs| |newPrefix|) + (DECLARE (SPECIAL |$insideExpressionIfTrue| |$form| |$op| |$prefix| + |$formalArgList| |$insideFunctorIfTrue| |$Category| + |$insideCategoryIfTrue| |$ConstructorNames| + |$NoValueMode| |$EmptyMode| |$insideWhereIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |$insideExpressionIfTrue| NIL) + (SPADLET |form| (|macroExpand| |form| |e|)) + (SPADLET |lhs| (CADR |form|)) + (SPADLET |signature| (CADDR |form|)) + (SPADLET |specialCases| (CADDDR |form|)) + (SPADLET |rhs| (CAR (CDDDDR |form|))) + (COND + ((AND |$insideWhereIfTrue| (|isMacro| |form| |e|) + (OR (BOOT-EQUAL |m| |$EmptyMode|) + (BOOT-EQUAL |m| |$NoValueMode|))) + (CONS |lhs| + (CONS |m| + (CONS (|put| (CAR |lhs|) '|macro| |rhs| + |e|) + NIL)))) + ((AND (NULL (CAR |signature|)) + (NULL (MEMQ (KAR |rhs|) |$ConstructorNames|)) + (SPADLET |sig| (|getSignatureFromMode| |lhs| |e|))) + (|compDefine1| + (CONS 'DEF + (CONS |lhs| + (CONS (CONS (CAR |sig|) + (CDR |signature|)) + (CONS |specialCases| + (CONS |rhs| NIL))))) + |m| |e|)) + ('T + (COND + ((BOOT-EQUAL (CAR |signature|) |$Category|) + (SPADLET |$insideCategoryIfTrue| 'T))) + (COND + ((PROGN + (SPADLET |ISTMP#1| (CAR |signature|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN (SPADLET |map| (QCDR |ISTMP#1|)) 'T))) + (SPADLET |signature| |map|) + (SPADLET |form| + (CONS 'DEF + (CONS |lhs| + (CONS |signature| + (CONS |specialCases| + (CONS |rhs| NIL)))))))) + (SPADLET |e| + (|compDefineAddSignature| |lhs| |signature| + |e|)) + (COND + ((NULL (PROG (G170094) + (SPADLET G170094 'T) + (RETURN + (DO ((G170100 NIL (NULL G170094)) + (G170101 (CDR |signature|) + (CDR G170101)) + (|x| NIL)) + ((OR G170100 (ATOM G170101) + (PROGN + (SETQ |x| (CAR G170101)) + NIL)) + G170094) + (SEQ (EXIT + (SETQ G170094 + (AND G170094 (NULL |x|))))))))) + (|compDefWhereClause| |form| |m| |e|)) + ((BOOT-EQUAL (CAR |signature|) |$Category|) + (|compDefineCategory| |form| |m| |e| NIL + |$formalArgList|)) + ((AND (|isDomainForm| |rhs| |e|) + (NULL |$insideFunctorIfTrue|)) + (COND + ((NULL (CAR |signature|)) + (SPADLET |signature| + (CONS (|getTargetFromRhs| |lhs| |rhs| + (|giveFormalParametersValues| + (CDR |lhs|) |e|)) + (CDR |signature|))))) + (SPADLET |rhs| + (|addEmptyCapsuleIfNecessary| + (CAR |signature|) |rhs|)) + (|compDefineFunctor| + (CONS 'DEF + (CONS |lhs| + (CONS |signature| + (CONS |specialCases| + (CONS |rhs| NIL))))) + |m| |e| NIL |$formalArgList|)) + ((NULL |$form|) + (|stackAndThrow| + (CONS (MAKESTRING "bad == form ") + (CONS |form| NIL)))) + ('T + (SPADLET |newPrefix| + (COND + (|$prefix| + (INTERN (STRCONC + (|encodeItem| |$prefix|) + (MAKESTRING ",") + (|encodeItem| |$op|)))) + ('T + (|getAbbreviation| |$op| + (|#| (CDR |$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) + +(DEFUN |compDefineCategory| (|df| |m| |e| |prefix| |fal|) + (PROG (|$domainShell| |$lisplibCategory|) + (DECLARE (SPECIAL |$domainShell| |$lisplibCategory| $LISPLIB + |$insideFunctorIfTrue|)) + (RETURN + (PROGN + (SPADLET |$domainShell| NIL) + (SPADLET |$lisplibCategory| NIL) + (COND + ((AND (NULL |$insideFunctorIfTrue|) $LISPLIB) + (|compDefineLisplib| |df| |m| |e| |prefix| |fal| + '|compDefineCategory1|)) + ('T (|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] + +(DEFUN |compDefineCategory1| (|df| |m| |e| |prefix| |fal|) + (PROG (|$DEFdepth| |$capsuleStack| |$predicateStack| + |$signatureStack| |$importStack| |$globalImportStack| + |$catAddForm| |$globalDeclareStack| |$globalImportDefAlist| + |$localMacroStack| |$freeStack| |$domainLevelVariableList| + |$categoryTranForm| |$insideCategoryPackageIfTrue| + |$categoryPredicateList| |$categoryNameForDollar| |form| + |sig| |sc| |ISTMP#1| |cat| |ISTMP#2| |capsule| + |categoryCapsule| |d| |defform| |arg| |LETTMP#1| |body| T$) + (DECLARE (SPECIAL |$DEFdepth| |$capsuleStack| |$predicateStack| + |$signatureStack| |$importStack| |$EmptyMode| + |$globalImportStack| |$catAddForm| |$lisplibCategory| + |$globalDeclareStack| |$globalImportDefAlist| + |$localMacroStack| |$freeStack| |$bootStrapMode| + |$domainLevelVariableList| |$categoryTranForm| + |$insideCategoryPackageIfTrue| + |$categoryPredicateList| + |$categoryNameForDollar|)) + (RETURN + (PROGN + (SPADLET |$DEFdepth| 0) + (SPADLET |$capsuleStack| NIL) + (SPADLET |$predicateStack| NIL) + (SPADLET |$signatureStack| NIL) + (SPADLET |$importStack| NIL) + (SPADLET |$globalImportStack| NIL) + (SPADLET |$catAddForm| NIL) + (SPADLET |$globalDeclareStack| NIL) + (SPADLET |$globalImportDefAlist| NIL) + (SPADLET |$localMacroStack| NIL) + (SPADLET |$freeStack| NIL) + (SPADLET |$domainLevelVariableList| NIL) + (SPADLET |$categoryTranForm| NIL) + (SPADLET |form| (CADR |df|)) + (SPADLET |sig| (CADDR |df|)) + (SPADLET |sc| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (SPADLET |body| (|markKillAll| |body|)) + (SPADLET |categoryCapsule| + (COND + ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cat| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |capsule| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |body| |cat|) |capsule|) + ('T NIL))) + (SPADLET |LETTMP#1| + (|compDefineCategory2| |form| |sig| |sc| |body| |m| + |e| |prefix| |fal|)) + (SPADLET |d| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((AND |categoryCapsule| (NULL |$bootStrapMode|)) + (SPADLET |LETTMP#1| + (PROGN + (SPADLET |$insideCategoryPackageIfTrue| 'T) + (SPADLET |$categoryPredicateList| + (|makeCategoryPredicates| |form| + |$lisplibCategory|)) + (SPADLET |defform| + (|mkCategoryPackage| |form| |cat| + |categoryCapsule|)) + (SPADLET |arg| (CADADR |defform|)) + (SPADLET |$categoryNameForDollar| |arg|) + (|compDefine1| |defform| |$EmptyMode| |e|))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|) + ('T (SPADLET |body| (CAR |$categoryTranForm|)) + (SPADLET T$ (CADR |$categoryTranForm|)) + (|markFinish| |body| T$))) + (CONS |d| (CONS |m| (CONS |e| NIL))))))) + +;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 $: +; [$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] + +(DEFUN |compDefineCategory2| + (|form| |signature| |specialCases| |body| |m| |e| |$prefix| + |$formalArgList|) + (declare (ignore |specialCases|)) + (DECLARE (SPECIAL |$prefix| |$formalArgList|)) + (PROG (|$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$form| |$op| + |$extraParms| |$functionStats| |$functorStats| |$frontier| + |$getDomainCode| |$addForm| |argl| |sargl| |aList| + |signature'| |LETTMP#1| |op'| |formalBody| T$ |ISTMP#1| |y| + |formals| |actuals| |g| |fun| |pairlis| |parSignature| + |parForm|) + (DECLARE (SPECIAL |$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$op| + |$form| |$op| |$extraParms| |$functionStats| + |$functorStats| |$frontier| |$getDomainCode| + |$addForm| |$lisplibCategory| |$convertingSpadFile| + |$domainShell| |$FormalMapVariableList| |$functorForm| + |$originalBody| |$categoryTranForm| |$originalBody| + |$catAddForm| |$addForm| |$formalArgList| + |$TriangleVariableList| )) + (RETURN + (SEQ (PROGN + (SPADLET |$insideCategoryIfTrue| 'T) + (SPADLET $TOP_LEVEL NIL) + (SPADLET |$definition| NIL) + (SPADLET |$form| NIL) + (SPADLET |$op| NIL) + (SPADLET |$extraParms| NIL) + (SPADLET |$definition| |form|) + (SPADLET |$op| (CAR |$definition|)) + (SPADLET |argl| (CDR |$definition|)) + (SPADLET |e| + (|addBinding| '$ + (CONS (CONS '|mode| |$definition|) NIL) |e|)) + (SPADLET |signature'| + (CONS (CAR |signature|) + (PROG (G170284) + (SPADLET G170284 NIL) + (RETURN + (DO ((G170289 |argl| (CDR G170289)) + (|a| NIL)) + ((OR (ATOM G170289) + (PROGN + (SETQ |a| (CAR G170289)) + NIL)) + (NREVERSE0 G170284)) + (SEQ (EXIT + (SETQ G170284 + (CONS + (|getArgumentModeOrMoan| |a| + |$definition| |e|) + G170284))))))))) + (SPADLET |e| (|giveFormalParametersValues| |argl| |e|)) + (SPADLET |sargl| + (TAKE (|#| |argl|) |$TriangleVariableList|)) + (SPADLET |$functorForm| + (SPADLET |$form| (CONS |$op| |sargl|))) + (SPADLET |$formalArgList| + (APPEND |sargl| |$formalArgList|)) + (SPADLET |aList| + (PROG (G170300) + (SPADLET G170300 NIL) + (RETURN + (DO ((G170306 |argl| (CDR G170306)) + (|a| NIL) + (G170307 |sargl| (CDR G170307)) + (|sa| NIL)) + ((OR (ATOM G170306) + (PROGN + (SETQ |a| (CAR G170306)) + NIL) + (ATOM G170307) + (PROGN + (SETQ |sa| (CAR G170307)) + NIL)) + (NREVERSE0 G170300)) + (SEQ (EXIT (SETQ G170300 + (CONS (CONS |a| |sa|) + G170300)))))))) + (SPADLET |formalBody| (SUBLIS |aList| |body|)) + (SPADLET |signature'| (SUBLIS |aList| |signature'|)) + (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) + (SPADLET |$functorStats| (CONS 0 (CONS 0 NIL))) + (SPADLET |$frontier| 0) + (SPADLET |$getDomainCode| NIL) + (SPADLET |$addForm| NIL) + (DO ((G170323 |sargl| (CDR G170323)) (|x| NIL) + (G170324 (CDR |signature'|) (CDR G170324)) + (|t| NIL)) + ((OR (ATOM G170323) + (PROGN (SETQ |x| (CAR G170323)) NIL) + (ATOM G170324) + (PROGN (SETQ |t| (CAR G170324)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (|compMakeDeclaration| + (CONS '|:| + (CONS |x| (CONS |t| NIL))) + |m| |e|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + |LETTMP#1|)))) + (SPADLET |op'| |$op|) + (COND + ((AND (NEQUAL (|opOf| |formalBody|) '|Join|) + (NEQUAL (|opOf| |formalBody|) '|mkCategory|)) + (SPADLET |formalBody| + (CONS '|Join| (CONS |formalBody| NIL))))) + (SPADLET T$ + (|compOrCroak| |formalBody| (CAR |signature'|) + |e|)) + (SPADLET |$catAddForm| + (COND + ((AND (PAIRP |$originalBody|) + (EQ (QCAR |$originalBody|) '|add|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |$originalBody|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + 'T)))) + |y|) + ('T |$originalBody|))) + (SPADLET |$categoryTranForm| + (CONS |$originalBody| + (CONS (CONS |$form| + (CONS + (CONS '|Mapping| |signature'|) + (CONS (CADDR T$) NIL))) + NIL))) + (SPADLET |body| + (|optFunctorBody| (|markKillAll| (CAR T$)))) + (COND + (|$extraParms| + (SPADLET |formals| (SPADLET |actuals| NIL)) + (DO ((G170338 |$extraParms| (CDR G170338)) + (|u| NIL)) + ((OR (ATOM G170338) + (PROGN (SETQ |u| (CAR G170338)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |formals| + (CONS (CAR |u|) |formals|)) + (SPADLET |actuals| + (CONS (MKQ (CDR |u|)) + |actuals|)))))) + (SPADLET |body| + (CONS '|sublisV| + (CONS (CONS 'PAIR + (CONS + (CONS 'QUOTE + (CONS |formals| NIL)) + (CONS (CONS 'LIST |actuals|) + NIL))) + (CONS |body| NIL)))))) + (COND + (|argl| (SPADLET |body| + (CONS '|sublisV| + (CONS + (CONS 'PAIR + (CONS + (CONS 'QUOTE + (CONS |sargl| NIL)) + (CONS + (CONS 'LIST + (PROG (G170348) + (SPADLET G170348 NIL) + (RETURN + (DO + ((G170353 |sargl| + (CDR G170353)) + (|u| NIL)) + ((OR (ATOM G170353) + (PROGN + (SETQ |u| + (CAR G170353)) + NIL)) + (NREVERSE0 G170348)) + (SEQ + (EXIT + (SETQ G170348 + (CONS + (CONS '|devaluate| + (CONS |u| NIL)) + G170348)))))))) + NIL))) + (CONS |body| NIL)))))) + (SPADLET |body| + (CONS 'PROG1 + (CONS (CONS 'LET + (CONS (SPADLET |g| (GENSYM)) + (CONS |body| NIL))) + (CONS (CONS 'SETELT + (CONS |g| + (CONS 0 + (CONS + (|mkConstructor| + |$functorForm|) + NIL)))) + NIL)))) + (SPADLET |fun| + (|compile| + (CONS |op'| + (CONS (CONS 'LAM + (CONS |sargl| (CONS |body| NIL))) + NIL)))) + (SPADLET |pairlis| + (PROG (G170364) + (SPADLET G170364 NIL) + (RETURN + (DO ((G170370 |argl| (CDR G170370)) + (|a| NIL) + (G170371 |$FormalMapVariableList| + (CDR G170371)) + (|v| NIL)) + ((OR (ATOM G170370) + (PROGN + (SETQ |a| (CAR G170370)) + NIL) + (ATOM G170371) + (PROGN + (SETQ |v| (CAR G170371)) + NIL)) + (NREVERSE0 G170364)) + (SEQ (EXIT (SETQ G170364 + (CONS (CONS |a| |v|) G170364)))))))) + (SPADLET |parSignature| (SUBLIS |pairlis| |signature'|)) + (SPADLET |parForm| (SUBLIS |pairlis| |form|)) + (COND + ((NULL |sargl|) + (|evalAndRwriteLispForm| 'NILADIC + (CONS 'MAKEPROP + (CONS (CONS 'QUOTE (CONS |op'| NIL)) + (CONS ''NILADIC (CONS 'T NIL))))))) + (SPADLET |$domainShell| + (COND + ((AND (BOUNDP '|$convertingSpadFile|) + |$convertingSpadFile|) + NIL) + ('T + (|eval| (CONS |op'| (MAPCAR 'MKQ |sargl|)))))) + (SPADLET |$lisplibCategory| |formalBody|) + (CONS |fun| (CONS '(|Category|) (CONS |e| NIL)))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}