diff --git a/changelog b/changelog index 1e9f341..fcede04 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20100826 tpd src/axiom-website/patches.html 20100826.02.tpd.patch +20100826 tpd src/interp/Makefile remove wi2.lisp +20100826 tpd src/interp/wi2.lisp removed 20100826 tpd src/axiom-website/patches.html 20100826.01.tpd.patch 20100826 tpd src/interp/Makefile remove wi1.lisp 20100826 tpd src/interp/wi1.lisp removed diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index a4532b3..f41ddf0 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3083,5 +3083,7 @@ src/interp/varini.lisp removed, merged with bookvol5
src/interp/ptrop.lisp merged and removed
20100826.01.tpd.patch src/interp/wi1.lisp removed
+20100826.02.tpd.patch +src/interp/wi2.lisp removed
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 6f90422..9aadaca 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -236,9 +236,9 @@ BROBJS= ${AUTO}/bc-matrix.${O} \ The {\bf TRANOBJS} list contains files only used by the {\bf boot} to Common Lisp translator and are probably never used by anyone but the developers. These files should probably be autoloaded. -\verb|${AUTO}/wi1.${O} | +\verb|${AUTO}/wi1.${O} ${AUTO}/wi2.${O} | <>= -TRANOBJS= ${AUTO}/wi2.${O} ${AUTO}/pspad1.${O} \ +TRANOBJS= ${AUTO}/pspad1.${O} \ ${AUTO}/pspad2.${O} ${AUTO}/mark.${O} ${AUTO}/nspadaux.${O} @ @@ -3303,50 +3303,6 @@ ${MID}/interop.lisp: ${IN}/interop.lisp.pamphlet @ -\subsection{wi1.boot} -<>= -${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.lisp"' \ - ':output-file "${AUTO}/wi1.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/wi1.lisp"' \ - ':output-file "${AUTO}/wi1.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${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 - -@ - -\subsection{wi2.boot} -<>= -${AUTO}/wi2.${O}: ${MID}/wi2.lisp - @ echo 598 making ${AUTO}/wi2.${O} from ${MID}/wi2.lisp - @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/wi2.lisp"' \ - ':output-file "${AUTO}/wi2.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/wi2.lisp"' \ - ':output-file "${AUTO}/wi2.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/wi2.lisp: ${IN}/wi2.lisp.pamphlet - @ echo 599 making ${MID}/wi2.lisp from ${IN}/wi2.lisp.pamphlet - @ ${TANGLE} ${IN}/wi2.lisp.pamphlet >${MID}/wi2.lisp - -@ - \subsection{pspad1.boot} <>= ${AUTO}/pspad1.${O}: ${MID}/pspad1.lisp @@ -3864,12 +3820,6 @@ clean: <> -<> -<> - -<> -<> - ${OUT}/%.o: ${MID}/%.lisp @ echo generic making ${OUT}/$*.o from ${MID}/$*.lisp @ ( cd ${MID} ; \ diff --git a/src/interp/wi2.lisp.pamphlet b/src/interp/wi2.lisp.pamphlet deleted file mode 100644 index e55adbe..0000000 --- a/src/interp/wi2.lisp.pamphlet +++ /dev/null @@ -1,4578 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp wi2.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -<<*>>= -(IN-PACKAGE "BOOT" ) - -;compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == -; ['DEF,form,signature,$functorSpecialCases,body] := df -; signature := markKillAll signature -; if NRTPARSE = true then -; [lineNumber,:$functorSpecialCases] := $functorSpecialCases -;-- 1. bind global variables -; $addForm: local -; $viewNames: local:= nil -; -; --This list is only used in genDomainViewName, for generating names -; --for alternate views, if they do not already exist. -; --format: Alist: (domain name . sublist) -; --sublist is alist: category . name of view -; $functionStats: local:= [0,0] -; $functorStats: local:= [0,0] -; $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 -; $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 -; $localLoopVariables: local := nil -; $pathStack : local := nil -; $form: local -; $op: local -; $signature: local -; $functorTarget: local -; $Representation: local -; --Set in doIt, accessed in the compiler - compNoStacking -; $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry -; $LocalDomainAlist:= nil -; $functorForm: local -; $functorLocalParameters: local -; $CheckVectorList: local -; --prevents CheckVector from printing out same message twice -; $getDomainCode: local -- code for getting views -; $insideFunctorIfTrue: local:= true -; $functorsUsed: local --not currently used, finds dependent functors -; $setelt: local := -; $QuickCode = true => 'QSETREFV -; 'SETELT -; $TOP__LEVEL: local -; $genFVar: local:= 0 -; $genSDVar: local:= 0 -; originale:= $e -; [$op,:argl]:= form -; $formalArgList:= [:argl,:$formalArgList] -; $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] -; $mutableDomain: local := -; -- all defaulting packages should have caching turned off -; isCategoryPackageName $op or -; (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) -; else false ) --true if domain has mutable state -; signature':= -; [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] -; $functorForm:= $form:= [$op,:argl] -; $globalImportStack := -; [markKillAll x for x in rest $functorForm for typ in rest signature' -; | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] -; if null first signature' then signature':= -; modemap2Signature getModemap($form,$e) -; target:= first signature' -; $functorTarget:= target -; $e:= giveFormalParametersValues(argl,$e) -; [ds,.,$e]:= compMakeCategoryObject(target,$e) or -;--+ copy needed since slot1 is reset; compMake.. can return a cached vector -; sayBrightly '" cannot produce category object:" -; pp target -; return nil -; $domainShell:= COPY_-SEQ ds -; $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") -; attributeList := ds.2 --see below under "loadTimeAlist" -;--+ 7 lines for $NRT follow -; $goGetList: local := nil -;-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 -; $condAlist: local := nil -; $uncondAlist: local := nil -;-->>-- next global initialized here, reset by NRTbuildFunctor -; $NRTslot1PredicateList: local := -; REMDUP [CADR x for x in attributeList] -;-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) -; $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList -; $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor -; --this is used below to set $lisplibSlot1 global -; $NRTbase: local := 6 -- equals length of $domainShell -; $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 -; $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts -; $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList -; $NRTaddList: local := nil --list of fncts not defined in capsule (added) -; $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector -; $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) -; $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... -; -- the above optimizes the calls to local domains -; $template: local:= nil --stored in the lisplib (if $NRTvec = true) -; $functionLocations: local := nil --locations of defined functions in source -; -- generate slots for arguments first, then for $NRTaddForm in compAdd -; for x in argl repeat NRTgetLocalIndex x -; [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) -; --The following loop sees if we can economise on ADDed operations -; --by using those of Rep, if that is the same. Example: DIRPROD -; if $insideCategoryPackageIfTrue^= true then -; if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) -; and FindRep(cb) = ab -; where FindRep cb == -; u:= -; while cb repeat -; ATOM cb => return nil -; cb is [['LET,'Rep,v,:.],:.] => return (u:=v) -; cb:=CDR cb -; u -; then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) -; else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) -; $signature:= signature' -; operationAlist:= SUBLIS($pairlis,$domainShell.(1)) -; parSignature:= SUBLIS($pairlis,signature') -; parForm:= SUBLIS($pairlis,form) -; -;-- (3.1) now make a list of the functor's local parameters; for -;-- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); -;-- in this case, D is replaced by D1,..,Dn (gensyms) which are set -;-- to the A1,..,An view of D -; if isPackageFunction() then $functorLocalParameters:= -; [nil,: -; [nil -; for i in 6..MAXINDEX $domainShell | -; $domainShell.i is [.,.,['ELT,'_$,.]]]] -; --leave space for vector ops and package name to be stored -;--+ -; $functorLocalParameters:= -; argPars := -; makeFunctorArgumentParameters(argl,rest signature',first signature') -; -- must do above to bring categories into scope --see line 5 of genDomainView -; argl -;-- 4. compile body in environment of %type declarations for arguments -; op':= $op -; rettype:= signature'.target -; SETQ($myFunctorBody, body) --------> new <-------- -; T:= compFunctorBody(body,rettype,$e,parForm) -;---------------> new <--------------------- -; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => -; return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) -;---------------> new <--------------------- -; -- If only compiling certain items, then ignore the body shell. -; $compileOnlyCertainItems => -; reportOnFunctorCompilation() -; [nil, ['Mapping, :signature'], originale] -; -; body':= T.expr -; lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM -; fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) -; --The above statement stops substitutions gettting in one another's way -;--+ -; operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) -; if $LISPLIB then -; augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) -; reportOnFunctorCompilation() -; -;-- 5. give operator a 'modemap property -;-- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) -; $insideFunctorIfTrue:= false -; if $LISPLIB then -; $lisplibKind:= -; $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package -; 'domain -; $lisplibForm:= form -; modemap:= [[parForm,:parSignature],[true,op']] -; $lisplibModemap:= modemap -; if null $bootStrapMode then -; $NRTslot1Info := NRTmakeSlot1Info() -; $isOpPackageName: local := isCategoryPackageName $op -; if $isOpPackageName then lisplibWrite('"slot1DataBase", -; ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) -; $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) -; $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) -; -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended -; libFn := getConstructorAbbreviation op' -; $lookupFunction: local := -; NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) -; --either lookupComplete (for forgetful guys) or lookupIncomplete -; $byteAddress :local := 0 -; $byteVec :local := nil -; $NRTslot1PredicateList := -; [simpBool x for x in $NRTslot1PredicateList] -; rwriteLispForm('loadTimeStuff, -; ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) -; $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 -; $lisplibOperationAlist:= operationAlist -; $lisplibMissingFunctions:= $CheckVectorList -; lisplibWrite('"compilerInfo", -; ['SETQ,'$CategoryFrame, -; ['put,['QUOTE,op'],' -; (QUOTE isFunctor), -; ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' -; QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], -; ['put,['QUOTE,op' ],'(QUOTE mode), -; ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) -; if null argl then -; evalAndRwriteLispForm('NILADIC, -; ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) -; [fun,['Mapping,:signature'],originale] - -(DEFUN |compDefineFunctor1,FindRep| (|cb|) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |v| |u|) - (RETURN - (SEQ (SPADLET |u| - (DO () ((NULL |cb|) NIL) - (SEQ (IF (ATOM |cb|) (EXIT (RETURN NIL))) - (IF (AND (PAIRP |cb|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |cb|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) 'LET) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) '|Rep|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |v| - (QCAR |ISTMP#3|)) - 'T)))))))) - (EXIT (RETURN (SPADLET |u| |v|)))) - (EXIT (SPADLET |cb| (CDR |cb|)))))) - (EXIT |u|))))) - -(DEFUN |compDefineFunctor1| (|df| |m| |$e| |$prefix| |$formalArgList|) - (DECLARE (SPECIAL |$e| |$prefix| |$formalArgList|)) - (PROG (|$addForm| |$viewNames| |$functionStats| |$functorStats| - |$DEFdepth| |$capsuleStack| |$predicateStack| - |$signatureStack| |$importStack| |$globalImportStack| - |$globalDeclareStack| |$globalImportDefAlist| - |$localMacroStack| |$freeStack| |$domainLevelVariableList| - |$localLoopVariables| |$pathStack| |$form| |$op| - |$signature| |$functorTarget| |$Representation| - |$LocalDomainAlist| |$functorForm| |$CategoryFrame| - |$functorLocalParameters| |$CheckVectorList| - |$getDomainCode| |$insideFunctorIfTrue| |$functorsUsed| - |$setelt| $TOP_LEVEL |$genFVar| |$genSDVar| - |$mutableDomain| |$attributesName| |$goGetList| - |$condAlist| |$uncondAlist| |$NRTslot1PredicateList| - |$NRTattributeAlist| |$NRTslot1Info| |$NRTbase| - |$NRTaddForm| |$NRTdeltaList| |$NRTdeltaListComp| - |$NRTaddList| |$NRTdeltaLength| |$NRTloadTimeAlist| - |$NRTdomainFormList| |$template| |$functionLocations| - |$isOpPackageName| |$lookupFunction| |$byteAddress| - |$byteVec| |form| |body| |signature| |lineNumber| - |originale| |argl| |signature'| |target| |ds| - |attributeList| |LETTMP#1| |fn| |ab| |cb| |parSignature| - |parForm| |ISTMP#2| |ISTMP#3| |ISTMP#4| |ISTMP#5| |ISTMP#6| - |argPars| |op'| |rettype| T$ |body'| |lamOrSlam| |fun| - |operationAlist| |ISTMP#1| |key| |modemap| |libFn|) - (DECLARE (SPECIAL - $LISPLIB $TOP_LEVEL |$CheckVectorList| |$DEFdepth| |$LocalDomainAlist| - |$NRTaddForm| |$NRTaddList| |$NRTattributeAlist| |$NRTbase| - |$NRTdeltaLength| |$NRTdeltaListComp| |$NRTdeltaList| - |$NRTdomainFormList| |$NRTloadTimeAlist| |$NRTslot1Info| - |$NRTslot1PredicateList| |$Representation| |$addForm| - |$attributesName| |$bootStrapMode| |$byteAddress| |$byteVec| - |$capsuleStack| |$compileOnlyCertainItems| |$condAlist| - |$convert2NewCompiler| |$domainLevelVariableList| |$domainShell| - |$form| |$freeStack| |$functionLocations| |$functionStats| - |$functorForm| |$functorLocalParameters| |$functorSpecialCases| - |$functorStats| |$functorTarget| |$functorsUsed| |$genFVar| - |$genSDVar| |$getDomainCode| |$globalDeclareStack| - |$globalImportDefAlist| |$globalImportStack| |$goGetList| - |$importStack| |$insideCategoryPackageIfTrue| |$insideFunctorIfTrue| - |$isOpPackageName| |$libFile| |$lisplibCategoriesExtended| - |$lisplibForm| |$lisplibFunctionLocations| |$lisplibKind| - |$lisplibMissingFunctions| |$lisplibModemap| |$lisplibOperationAlist| - |$lisplibSlot1| |$localLoopVariables| |$localMacroStack| - |$lookupFunction| |$mutableDomains| |$mutableDomain| |$myFunctorBody| - |$op| |$originalBody| |$pairlis| |$pathStack| |$predicateStack| - |$setelt| |$signatureStack| |$signature| |$template| |$uncondAlist| - |$viewNames|)) - - (RETURN - (SEQ (PROGN - (SPADLET |form| (CADR |df|)) - (SPADLET |signature| (CADDR |df|)) - (SPADLET |$functorSpecialCases| (CADDDR |df|)) - (SPADLET |body| (CAR (CDDDDR |df|))) - (SPADLET |signature| (|markKillAll| |signature|)) - (COND - ((BOOT-EQUAL NRTPARSE 'T) - (SPADLET |LETTMP#1| |$functorSpecialCases|) - (SPADLET |lineNumber| (CAR |LETTMP#1|)) - (SPADLET |$functorSpecialCases| (CDR |LETTMP#1|)) - |LETTMP#1|)) - (SPADLET |$addForm| NIL) - (SPADLET |$viewNames| NIL) - (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) - (SPADLET |$functorStats| (CONS 0 (CONS 0 NIL))) - (SPADLET |$DEFdepth| 0) - (SPADLET |$capsuleStack| NIL) - (SPADLET |$predicateStack| NIL) - (SPADLET |$signatureStack| NIL) - (SPADLET |$importStack| NIL) - (SPADLET |$globalImportStack| NIL) - (SPADLET |$globalDeclareStack| NIL) - (SPADLET |$globalImportDefAlist| NIL) - (SPADLET |$localMacroStack| NIL) - (SPADLET |$freeStack| NIL) - (SPADLET |$domainLevelVariableList| NIL) - (SPADLET |$localLoopVariables| NIL) - (SPADLET |$pathStack| NIL) - (SPADLET |$form| NIL) - (SPADLET |$op| NIL) - (SPADLET |$signature| NIL) - (SPADLET |$functorTarget| NIL) - (SPADLET |$Representation| NIL) - (SPADLET |$LocalDomainAlist| NIL) - (SPADLET |$LocalDomainAlist| NIL) - (SPADLET |$functorForm| NIL) - (SPADLET |$functorLocalParameters| NIL) - (SPADLET |$CheckVectorList| NIL) - (SPADLET |$getDomainCode| NIL) - (SPADLET |$insideFunctorIfTrue| 'T) - (SPADLET |$functorsUsed| NIL) - (SPADLET |$setelt| - (COND - ((BOOT-EQUAL |$QuickCode| 'T) 'QSETREFV) - ('T 'SETELT))) - (SPADLET $TOP_LEVEL NIL) - (SPADLET |$genFVar| 0) - (SPADLET |$genSDVar| 0) - (SPADLET |originale| |$e|) - (SPADLET |$op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |$formalArgList| - (APPEND |argl| |$formalArgList|)) - (SPADLET |$pairlis| - (PROG (G166232) - (SPADLET G166232 NIL) - (RETURN - (DO ((G166238 |argl| (CDR G166238)) - (|a| NIL) - (G166239 |$FormalMapVariableList| - (CDR G166239)) - (|v| NIL)) - ((OR (ATOM G166238) - (PROGN - (SETQ |a| (CAR G166238)) - NIL) - (ATOM G166239) - (PROGN - (SETQ |v| (CAR G166239)) - NIL)) - (NREVERSE0 G166232)) - (SEQ (EXIT (SETQ G166232 - (CONS (CONS |a| |v|) G166232)))))))) - (SPADLET |$mutableDomain| - (OR (|isCategoryPackageName| |$op|) - (COND - ((BOUNDP '|$mutableDomains|) - (MEMQ |$op| |$mutableDomains|)) - ('T NIL)))) - (SPADLET |signature'| - (CONS (CAR |signature|) - (PROG (G166252) - (SPADLET G166252 NIL) - (RETURN - (DO ((G166257 |argl| (CDR G166257)) - (|a| NIL)) - ((OR (ATOM G166257) - (PROGN - (SETQ |a| (CAR G166257)) - NIL)) - (NREVERSE0 G166252)) - (SEQ (EXIT - (SETQ G166252 - (CONS - (|getArgumentModeOrMoan| |a| - |form| |$e|) - G166252))))))))) - (SPADLET |$functorForm| - (SPADLET |$form| (CONS |$op| |argl|))) - (SPADLET |$globalImportStack| - (PROG (G166269) - (SPADLET G166269 NIL) - (RETURN - (DO ((G166276 (CDR |$functorForm|) - (CDR G166276)) - (|x| NIL) - (G166277 (CDR |signature'|) - (CDR G166277)) - (|typ| NIL)) - ((OR (ATOM G166276) - (PROGN - (SETQ |x| (CAR G166276)) - NIL) - (ATOM G166277) - (PROGN - (SETQ |typ| (CAR G166277)) - NIL)) - (NREVERSE0 G166269)) - (SEQ (EXIT (COND - ((BOOT-EQUAL - (GETDATABASE (|opOf| |typ|) - 'CONSTRUCTORKIND) - '|category|) - (SETQ G166269 - (CONS (|markKillAll| |x|) - G166269)))))))))) - (COND - ((NULL (CAR |signature'|)) - (SPADLET |signature'| - (|modemap2Signature| - (|getModemap| |$form| |$e|))))) - (SPADLET |target| (CAR |signature'|)) - (SPADLET |$functorTarget| |target|) - (SPADLET |$e| (|giveFormalParametersValues| |argl| |$e|)) - (SPADLET |LETTMP#1| - (OR (|compMakeCategoryObject| |target| |$e|) - (PROGN - (|sayBrightly| - " cannot produce category object:") - (|pp| |target|) - (RETURN NIL)))) - (SPADLET |ds| (CAR |LETTMP#1|)) - (SPADLET |$e| (CADDR |LETTMP#1|)) - (SPADLET |$domainShell| (COPY-SEQ |ds|)) - (SPADLET |$attributesName| - (INTERN (STRCONC (PNAME |$op|) - ";attributes"))) - (SPADLET |attributeList| (ELT |ds| 2)) - (SPADLET |$goGetList| NIL) - (SPADLET |$condAlist| NIL) - (SPADLET |$uncondAlist| NIL) - (SPADLET |$NRTslot1PredicateList| - (REMDUP (PROG (G166290) - (SPADLET G166290 NIL) - (RETURN - (DO ((G166295 |attributeList| - (CDR G166295)) - (|x| NIL)) - ((OR (ATOM G166295) - (PROGN - (SETQ |x| (CAR G166295)) - NIL)) - (NREVERSE0 G166290)) - (SEQ - (EXIT - (SETQ G166290 - (CONS (CADR |x|) G166290))))))))) - (SPADLET |$NRTattributeAlist| - (|NRTgenInitialAttributeAlist| |attributeList|)) - (SPADLET |$NRTslot1Info| NIL) - (SPADLET |$NRTbase| 6) - (SPADLET |$NRTaddForm| NIL) - (SPADLET |$NRTdeltaList| NIL) - (SPADLET |$NRTdeltaListComp| NIL) - (SPADLET |$NRTaddList| NIL) - (SPADLET |$NRTdeltaLength| 0) - (SPADLET |$NRTloadTimeAlist| NIL) - (SPADLET |$NRTdomainFormList| NIL) - (SPADLET |$template| NIL) - (SPADLET |$functionLocations| NIL) - (DO ((G166304 |argl| (CDR G166304)) (|x| NIL)) - ((OR (ATOM G166304) - (PROGN (SETQ |x| (CAR G166304)) NIL)) - NIL) - (SEQ (EXIT (|NRTgetLocalIndex| |x|)))) - (SPADLET |LETTMP#1| - (|compMakeDeclaration| - (CONS '|:| (CONS '$ (CONS |target| NIL))) |m| - |$e|)) - (SPADLET |$e| (CADDR |LETTMP#1|)) - (COND - ((NEQUAL |$insideCategoryPackageIfTrue| 'T) - (COND - ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |fn| (QCAR |ISTMP#2|)) - 'T))) - (PROGN - (SPADLET |ab| (QCAR |ISTMP#1|)) - 'T) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |ISTMP#4| - (QCAR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCAR |ISTMP#4|) 'CAPSULE) - (PROGN - (SPADLET |cb| - (QCDR |ISTMP#4|)) - 'T))))))) - (MEMQ |fn| '(|List| |Vector|)) - (BOOT-EQUAL (|compDefineFunctor1,FindRep| |cb|) - |ab|)) - (SPADLET |$e| - (|augModemapsFromCategoryRep| '$ |ab| |cb| - |target| |$e|))) - ('T - (SPADLET |$e| - (|augModemapsFromCategory| '$ '$ '$ - |target| |$e|)))))) - (SPADLET |$signature| |signature'|) - (SPADLET |operationAlist| - (SUBLIS |$pairlis| (ELT |$domainShell| 1))) - (SPADLET |parSignature| (SUBLIS |$pairlis| |signature'|)) - (SPADLET |parForm| (SUBLIS |$pairlis| |form|)) - (COND - ((|isPackageFunction|) - (SPADLET |$functorLocalParameters| - (CONS NIL - (PROG (G166315) - (SPADLET G166315 NIL) - (RETURN - (DO - ((G166321 - (MAXINDEX |$domainShell|)) - (|i| 6 (+ |i| 1))) - ((> |i| G166321) - (NREVERSE0 G166315)) - (SEQ - (EXIT - (COND - ((PROGN - (SPADLET |ISTMP#1| - (ELT |$domainShell| |i|)) - (AND (PAIRP |ISTMP#1|) - (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 |ISTMP#4| - (QCAR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (EQ - (QCAR |ISTMP#4|) - 'ELT) - (PROGN - (SPADLET - |ISTMP#5| - (QCDR - |ISTMP#4|)) - (AND - (PAIRP - |ISTMP#5|) - (EQ - (QCAR - |ISTMP#5|) - '$) - (PROGN - (SPADLET - |ISTMP#6| - (QCDR - |ISTMP#5|)) - (AND - (PAIRP - |ISTMP#6|) - (EQ - (QCDR - |ISTMP#6|) - NIL))))))))))))) - (SETQ G166315 - (CONS NIL G166315))))))))))))) - (SPADLET |$functorLocalParameters| - (PROGN - (SPADLET |argPars| - (|makeFunctorArgumentParameters| - |argl| (CDR |signature'|) - (CAR |signature'|))) - |argl|)) - (SPADLET |op'| |$op|) - (SPADLET |rettype| (CAR |signature'|)) - (SETQ |$myFunctorBody| |body|) - (SPADLET T$ - (|compFunctorBody| |body| |rettype| |$e| - |parForm|)) - (COND - ((AND (BOUNDP '|$convert2NewCompiler|) - |$convert2NewCompiler|) - (RETURN - (|markFinish| |$originalBody| - (CONS |$form| - (CONS (CONS '|Mapping| |signature'|) - (CONS (CADDR T$) NIL)))))) - (|$compileOnlyCertainItems| - (|reportOnFunctorCompilation|) - (CONS NIL - (CONS (CONS '|Mapping| |signature'|) - (CONS |originale| NIL)))) - ('T (SPADLET |body'| (CAR T$)) - (SPADLET |lamOrSlam| - (COND (|$mutableDomain| 'LAM) ('T 'SPADSLAM))) - (SPADLET |fun| - (|compile| - (SUBLIS |$pairlis| - (CONS |op'| - (CONS - (CONS |lamOrSlam| - (CONS |argl| - (CONS |body'| NIL))) - NIL))))) - (SPADLET |operationAlist| - (SUBLIS |$pairlis| |$lisplibOperationAlist|)) - (COND - ($LISPLIB - (|augmentLisplibModemapsFromFunctor| |parForm| - |operationAlist| |parSignature|))) - (|reportOnFunctorCompilation|) - (SPADLET |$insideFunctorIfTrue| NIL) - (COND - ($LISPLIB - (SPADLET |$lisplibKind| - (COND - ((AND (PAIRP |$functorTarget|) - (EQ (QCAR |$functorTarget|) - 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |$functorTarget|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |key| - (QCAR |ISTMP#1|)) - 'T))) - (NEQUAL |key| '|domain|)) - '|package|) - ('T '|domain|))) - (SPADLET |$lisplibForm| |form|) - (SPADLET |modemap| - (CONS (CONS |parForm| |parSignature|) - (CONS (CONS 'T (CONS |op'| NIL)) - NIL))) - (SPADLET |$lisplibModemap| |modemap|) - (COND - ((NULL |$bootStrapMode|) - (SPADLET |$NRTslot1Info| (|NRTmakeSlot1Info|)) - (SPADLET |$isOpPackageName| - (|isCategoryPackageName| |$op|)) - (COND - (|$isOpPackageName| - (|lisplibWrite| - "slot1DataBase" - (CONS '|updateSlot1DataBase| - (CONS (MKQ |$NRTslot1Info|) NIL)) - |$libFile|))) - (SPADLET |$lisplibFunctionLocations| - (SUBLIS |$pairlis| - |$functionLocations|)) - (SPADLET |$lisplibCategoriesExtended| - (SUBLIS |$pairlis| - |$lisplibCategoriesExtended|)) - (SPADLET |libFn| - (|getConstructorAbbreviation| |op'|)) - (SPADLET |$lookupFunction| - (|NRTgetLookupFunction| - |$functorForm| - (CADAR |$lisplibModemap|) - |$NRTaddForm|)) - (SPADLET |$byteAddress| 0) - (SPADLET |$byteVec| NIL) - (SPADLET |$NRTslot1PredicateList| - (PROG (G166329) - (SPADLET G166329 NIL) - (RETURN - (DO - ((G166334 - |$NRTslot1PredicateList| - (CDR G166334)) - (|x| NIL)) - ((OR (ATOM G166334) - (PROGN - (SETQ |x| (CAR G166334)) - NIL)) - (NREVERSE0 G166329)) - (SEQ - (EXIT - (SETQ G166329 - (CONS (|simpBool| |x|) - G166329)))))))) - (|rwriteLispForm| '|loadTimeStuff| - (CONS 'MAKEPROP - (CONS (MKQ |$op|) - (CONS ''|infovec| - (CONS (|getInfovecCode|) NIL))))))) - (SPADLET |$lisplibSlot1| |$NRTslot1Info|) - (SPADLET |$lisplibOperationAlist| - |operationAlist|) - (SPADLET |$lisplibMissingFunctions| - |$CheckVectorList|))) - (|lisplibWrite| "compilerInfo" - (CONS 'SETQ - (CONS '|$CategoryFrame| - (CONS (CONS '|put| - (CONS - (CONS 'QUOTE (CONS |op'| NIL)) - (CONS ''|isFunctor| - (CONS - (CONS 'QUOTE - (CONS |operationAlist| NIL)) - (CONS - (CONS '|addModemap| - (CONS - (CONS 'QUOTE - (CONS |op'| NIL)) - (CONS - (CONS 'QUOTE - (CONS |parForm| NIL)) - (CONS - (CONS 'QUOTE - (CONS |parSignature| - NIL)) - (CONS 'T - (CONS - (CONS 'QUOTE - (CONS |op'| NIL)) - (CONS - (CONS '|put| - (CONS - (CONS 'QUOTE - (CONS |op'| NIL)) - (CONS ''|mode| - (CONS - (CONS 'QUOTE - (CONS - (CONS - '|Mapping| - |parSignature|) - NIL)) - (CONS - '|$CategoryFrame| - NIL))))) - NIL))))))) - NIL))))) - NIL))) - |$libFile|) - (COND - ((NULL |argl|) - (|evalAndRwriteLispForm| 'NILADIC - (CONS 'MAKEPROP - (CONS (CONS 'QUOTE (CONS |op'| NIL)) - (CONS - (CONS 'QUOTE (CONS 'NILADIC NIL)) - (CONS 'T NIL))))))) - (CONS |fun| - (CONS (CONS '|Mapping| |signature'|) - (CONS |originale| NIL)))))))))) - -;makeFunctorArgumentParameters(argl,sigl,target) == -; $alternateViewList: local:= nil -; $forceAdd: local:= true -; $ConditionalOperators: local -; target := markKillAll target -; ("append"/[fn(a,augmentSig(s,findExtras(a,target))) -; for a in argl for s in sigl]) where -; findExtras(a,target) == -; -- see if conditional information implies anything else -; -- in the signature of a -; target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] -; target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where -; findExtras1(a,x) == -; x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] -; x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] -; x is ['IF,c,p,q] => -; union(findExtrasP(a,c), -; union(findExtras1(a,p),findExtras1(a,q))) where -; findExtrasP(a,x) == -; x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] -; x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] -; x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] -; nil -; nil -; augmentSig(s,ss) == -; -- if we find something extra, add it to the signature -; null ss => s -; for u in ss repeat -; $ConditionalOperators:=[CDR u,:$ConditionalOperators] -; s is ['Join,:sl] => -; u:=ASSQ('CATEGORY,ss) => -; SUBST([:u,:ss],u,s) -; ['Join,:sl,['CATEGORY,'package,:ss]] -; ['Join,s,['CATEGORY,'package,:ss]] -; fn(a,s) == -; isCategoryForm(s,$CategoryFrame) => -; s is ["Join",:catlist] => genDomainViewList0(a,rest s) -; [genDomainView(a,a,s,"getDomainView")] -; [a] - -(DEFUN |makeFunctorArgumentParameters,findExtrasP| (|a| |x|) - (PROG (|l| |ISTMP#1| |ISTMP#2| |y|) - (RETURN - (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'AND) - (PROGN (SPADLET |l| (QCDR |x|)) 'T)) - (EXIT (PROG (G166637) - (SPADLET G166637 NIL) - (RETURN - (DO ((G166642 |l| (CDR G166642)) - (|y| NIL)) - ((OR (ATOM G166642) - (PROGN - (SETQ |y| (CAR G166642)) - NIL)) - G166637) - (SEQ (EXIT (SETQ G166637 - (|union| G166637 - (|makeFunctorArgumentParameters,findExtrasP| - |a| |y|)))))))))) - (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'OR) - (PROGN (SPADLET |l| (QCDR |x|)) 'T)) - (EXIT (PROG (G166648) - (SPADLET G166648 NIL) - (RETURN - (DO ((G166653 |l| (CDR G166653)) - (|y| NIL)) - ((OR (ATOM G166653) - (PROGN - (SETQ |y| (CAR G166653)) - NIL)) - G166648) - (SEQ (EXIT (SETQ G166648 - (|union| G166648 - (|makeFunctorArgumentParameters,findExtrasP| - |a| |y|)))))))))) - (IF (AND (AND (PAIRP |x|) (EQ (QCAR |x|) '|has|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |a|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y| (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |y|) (EQ (QCAR |y|) 'SIGNATURE))) - (EXIT (CONS |y| NIL))) - (EXIT NIL))))) - - -(DEFUN |makeFunctorArgumentParameters,findExtras1| (|a| |x|) - (PROG (|l| |ISTMP#1| |c| |ISTMP#2| |p| |ISTMP#3| |q|) - (RETURN - (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'AND) - (PROGN (SPADLET |l| (QCDR |x|)) 'T)) - (EXIT (PROG (G166671) - (SPADLET G166671 NIL) - (RETURN - (DO ((G166676 |l| (CDR G166676)) - (|y| NIL)) - ((OR (ATOM G166676) - (PROGN - (SETQ |y| (CAR G166676)) - NIL)) - G166671) - (SEQ (EXIT (SETQ G166671 - (|union| G166671 - (|makeFunctorArgumentParameters,findExtras1| - |a| |y|)))))))))) - (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'OR) - (PROGN (SPADLET |l| (QCDR |x|)) 'T)) - (EXIT (PROG (G166682) - (SPADLET G166682 NIL) - (RETURN - (DO ((G166687 |l| (CDR G166687)) - (|y| NIL)) - ((OR (ATOM G166687) - (PROGN - (SETQ |y| (CAR G166687)) - NIL)) - G166682) - (SEQ (EXIT (SETQ G166682 - (|union| G166682 - (|makeFunctorArgumentParameters,findExtras1| - |a| |y|)))))))))) - (EXIT (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |c| (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|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |q| (QCAR |ISTMP#3|)) - 'T)))))))) - (EXIT (|union| (|makeFunctorArgumentParameters,findExtrasP| - |a| |c|) - (|union| - (|makeFunctorArgumentParameters,findExtras1| - |a| |p|) - (|makeFunctorArgumentParameters,findExtras1| - |a| |q|)))))))))) - - -(DEFUN |makeFunctorArgumentParameters,fn| (|a| |s|) - (PROG (|catlist|) - (declare (special |$CategoryFrame|)) - (RETURN - (SEQ (IF (|isCategoryForm| |s| |$CategoryFrame|) - (EXIT (SEQ (IF (AND (PAIRP |s|) (EQ (QCAR |s|) '|Join|) - (PROGN - (SPADLET |catlist| (QCDR |s|)) - 'T)) - (EXIT (|genDomainViewList0| |a| - (CDR |s|)))) - (EXIT (CONS (|genDomainView| |a| |a| |s| - '|getDomainView|) - NIL))))) - (EXIT (CONS |a| NIL)))))) - -(DEFUN |makeFunctorArgumentParameters,augmentSig| (|s| |ss|) - (PROG (|sl| |u|) - (declare (special |$ConditionalOperators|)) - (RETURN - (SEQ (IF (NULL |ss|) (EXIT |s|)) - (DO ((G166720 |ss| (CDR G166720)) (|u| NIL)) - ((OR (ATOM G166720) - (PROGN (SETQ |u| (CAR G166720)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |$ConditionalOperators| - (CONS (CDR |u|) |$ConditionalOperators|))))) - (IF (AND (PAIRP |s|) (EQ (QCAR |s|) '|Join|) - (PROGN (SPADLET |sl| (QCDR |s|)) 'T)) - (EXIT (SEQ (IF (SPADLET |u| (ASSQ 'CATEGORY |ss|)) - (EXIT (MSUBST (APPEND |u| |ss|) |u| |s|))) - (EXIT (CONS '|Join| - (APPEND |sl| - (CONS - (CONS 'CATEGORY - (CONS '|package| |ss|)) - NIL))))))) - (EXIT (CONS '|Join| - (CONS |s| - (CONS (CONS 'CATEGORY - (CONS '|package| |ss|)) - NIL)))))))) - -(DEFUN |makeFunctorArgumentParameters,findExtras| (|a| |target|) - (PROG (|ISTMP#1| |l|) - (RETURN - (SEQ (IF (AND (PAIRP |target|) (EQ (QCAR |target|) '|Join|) - (PROGN (SPADLET |l| (QCDR |target|)) 'T)) - (EXIT (PROG (G166732) - (SPADLET G166732 NIL) - (RETURN - (DO ((G166737 |l| (CDR G166737)) - (|x| NIL)) - ((OR (ATOM G166737) - (PROGN - (SETQ |x| (CAR G166737)) - NIL)) - G166732) - (SEQ (EXIT (SETQ G166732 - (|union| G166732 - (|makeFunctorArgumentParameters,findExtras| - |a| |x|)))))))))) - (EXIT (IF (AND (PAIRP |target|) - (EQ (QCAR |target|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |l| (QCDR |ISTMP#1|)) - 'T)))) - (EXIT (PROG (G166743) - (SPADLET G166743 NIL) - (RETURN - (DO ((G166748 |l| (CDR G166748)) - (|x| NIL)) - ((OR (ATOM G166748) - (PROGN - (SETQ |x| (CAR G166748)) - NIL)) - G166743) - (SEQ (EXIT - (SETQ G166743 - (|union| G166743 - (|makeFunctorArgumentParameters,findExtras1| - |a| |x|))))))))))))))) - - -(DEFUN |makeFunctorArgumentParameters| (|argl| |sigl| |target|) - (PROG (|$alternateViewList| |$forceAdd| |$ConditionalOperators|) - (DECLARE (SPECIAL |$alternateViewList| |$forceAdd| - |$ConditionalOperators|)) - (RETURN - (SEQ (PROGN - (SPADLET |$alternateViewList| NIL) - (SPADLET |$forceAdd| 'T) - (SPADLET |$ConditionalOperators| NIL) - (SPADLET |target| (|markKillAll| |target|)) - (PROG (G166764) - (SPADLET G166764 NIL) - (RETURN - (DO ((G166770 |argl| (CDR G166770)) (|a| NIL) - (G166771 |sigl| (CDR G166771)) (|s| NIL)) - ((OR (ATOM G166770) - (PROGN (SETQ |a| (CAR G166770)) NIL) - (ATOM G166771) - (PROGN (SETQ |s| (CAR G166771)) NIL)) - G166764) - (SEQ (EXIT (SETQ G166764 - (APPEND G166764 - (|makeFunctorArgumentParameters,fn| - |a| - (|makeFunctorArgumentParameters,augmentSig| - |s| - (|makeFunctorArgumentParameters,findExtras| - |a| |target|))))))))))))))) - -;compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == -; ['DEF,form,originalSignature,specialCases,body] := df -; signature := markKillAll originalSignature -; $markFreeStack: local := nil --holds "free variables" -; $localImportStack : local := nil --local import stack for function -; $localDeclareStack: local := nil -; $localLoopVariables: local := nil -; originalDef := COPY df -; [lineNumber,:specialCases] := specialCases -; e := oldE -; --1. bind global variables -; $form: local -; $op: local -; $functionStats: local:= [0,0] -; $argumentConditionList: local -; $finalEnv: local -; --used by ReplaceExitEtc to get a common environment -; $initCapsuleErrorCount: local:= #$semanticErrorStack -; $insideCapsuleFunctionIfTrue: local:= true -; $CapsuleModemapFrame: local:= e -; $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) -; $insideExpressionIfTrue: local:= true -; $returnMode:= m -; [$op,:argl]:= form -; $form:= [$op,:argl] -; argl:= stripOffArgumentConditions argl -; $formalArgList:= [:argl,:$formalArgList] -; -; --let target and local signatures help determine modes of arguments -; argModeList:= -; identSig:= hasSigInTargetCategory(argl,form,first signature,e) => -; (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) -; [getArgumentModeOrMoan(a,form,e) for a in argl] -; argModeList:= stripOffSubdomainConditions(argModeList,argl) -; signature':= [first signature,:argModeList] -; if null identSig then --make $op a local function -; oldE := put($op,'mode,['Mapping,:signature'],oldE) -; -; --obtain target type if not given -; if null first signature' then signature':= -; identSig => identSig -; getSignature($op,rest signature',e) or return nil -; e:= giveFormalParametersValues(argl,e) -; -; $signatureOfForm:= signature' --this global is bound in compCapsuleItems -; $functionLocations := [[[$op,$signatureOfForm],:lineNumber], -; :$functionLocations] -; e:= addDomain(first signature',e) -; e:= compArgumentConditions e -; -; if $profileCompiler then -; for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) -; -; -; --4. introduce needed domains into extendedEnv -; for domain in signature' repeat e:= addDomain(domain,e) -; -; --6. compile body in environment with extended environment -; rettype:= resolve(signature'.target,$returnMode) -; -; localOrExported := -; null MEMBER($op,$formalArgList) and -; getmode($op,e) is ['Mapping,:.] => 'local -; 'exported -; -; --6a skip if compiling only certain items but not this one -; -- could be moved closer to the top -; formattedSig := formatUnabbreviated ['Mapping,:signature'] -; $compileOnlyCertainItems and _ -; not MEMBER($op, $compileOnlyCertainItems) => -; sayBrightly ['" skipping ", localOrExported,:bright $op] -; [nil,['Mapping,:signature'],oldE] -; sayBrightly ['" compiling ",localOrExported, -; :bright $op,'": ",:formattedSig] -;---------------------> new <--------------------------------- -; returnType := signature'.target -;-- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) -; trialT := returnType = "$" and comp(body,$EmptyMode,e) -; ------------------------------------------------------ 11/1/94 -; -- try comp-ing in $EmptyMode; if succeed -; -- if we succeed then trialT.mode = "$" or "Rep" -; -- do a coerce to get the correct result -; T := (trialT and coerce(trialT,returnType)) -; -------------------------------------- 11/1/94 -; or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) -; markChanges(originalDef,T,$signatureOfForm) -; [nil,['Mapping,:signature'],oldE] - -(DEFUN |compDefineCapsuleFunction| (|df| |m| |oldE| |$prefix| |$formalArgList|) - (DECLARE (SPECIAL |$prefix| |$formalArgList|)) - (PROG (|$markFreeStack| |$localImportStack| |$localDeclareStack| - |$localLoopVariables| |$form| |$op| |$functionStats| - |$argumentConditionList| |$finalEnv| - |$initCapsuleErrorCount| |$insideCapsuleFunctionIfTrue| - |$CapsuleModemapFrame| |$CapsuleDomainsInScope| - |$insideExpressionIfTrue| |form| |originalSignature| |body| - |signature| |originalDef| |LETTMP#1| |lineNumber| - |specialCases| |argl| |identSig| |argModeList| |signature'| - |e| |rettype| |ISTMP#1| |localOrExported| |formattedSig| - |returnType| |trialT| T$) - (DECLARE (SPECIAL |$markFreeStack| |$localImportStack| |$functionLocations| - |$localDeclareStack| |$localLoopVariables| - |$form| |$op| |$functionStats| |$profileCompiler| - |$argumentConditionList| |$finalEnv| |$returnMode| - |$initCapsuleErrorCount| |$compileOnlyCertainItems| - |$insideCapsuleFunctionIfTrue| |$EmptyMode| - |$CapsuleModemapFrame| |$CapsuleDomainsInScope| - |$insideExpressionIfTrue| |$signatureOfForm| - |$DomainsInScope| |$semanticErrorStack|)) - (RETURN - (SEQ (PROGN - (SPADLET |form| (CADR |df|)) - (SPADLET |originalSignature| (CADDR |df|)) - (SPADLET |specialCases| (CADDDR |df|)) - (SPADLET |body| (CAR (CDDDDR |df|))) - (SPADLET |signature| (|markKillAll| |originalSignature|)) - (SPADLET |$markFreeStack| NIL) - (SPADLET |$localImportStack| NIL) - (SPADLET |$localDeclareStack| NIL) - (SPADLET |$localLoopVariables| NIL) - (SPADLET |originalDef| (COPY |df|)) - (SPADLET |LETTMP#1| |specialCases|) - (SPADLET |lineNumber| (CAR |LETTMP#1|)) - (SPADLET |specialCases| (CDR |LETTMP#1|)) - (SPADLET |e| |oldE|) - (SPADLET |$form| NIL) - (SPADLET |$op| NIL) - (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) - (SPADLET |$argumentConditionList| NIL) - (SPADLET |$finalEnv| NIL) - (SPADLET |$initCapsuleErrorCount| - (|#| |$semanticErrorStack|)) - (SPADLET |$insideCapsuleFunctionIfTrue| 'T) - (SPADLET |$CapsuleModemapFrame| |e|) - (SPADLET |$CapsuleDomainsInScope| - (|get| '|$DomainsInScope| '|special| |e|)) - (SPADLET |$insideExpressionIfTrue| 'T) - (SPADLET |$returnMode| |m|) - (SPADLET |$op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |$form| (CONS |$op| |argl|)) - (SPADLET |argl| (|stripOffArgumentConditions| |argl|)) - (SPADLET |$formalArgList| - (APPEND |argl| |$formalArgList|)) - (SPADLET |argModeList| - (COND - ((SPADLET |identSig| - (|hasSigInTargetCategory| |argl| - |form| (CAR |signature|) |e|)) - (SPADLET |e| - (|checkAndDeclare| |argl| |form| - |identSig| |e|)) - (CDR |identSig|)) - ('T - (PROG (G166821) - (SPADLET G166821 NIL) - (RETURN - (DO ((G166826 |argl| (CDR G166826)) - (|a| NIL)) - ((OR (ATOM G166826) - (PROGN - (SETQ |a| (CAR G166826)) - NIL)) - (NREVERSE0 G166821)) - (SEQ (EXIT - (SETQ G166821 - (CONS - (|getArgumentModeOrMoan| |a| - |form| |e|) - G166821)))))))))) - (SPADLET |argModeList| - (|stripOffSubdomainConditions| |argModeList| - |argl|)) - (SPADLET |signature'| - (CONS (CAR |signature|) |argModeList|)) - (COND - ((NULL |identSig|) - (SPADLET |oldE| - (|put| |$op| '|mode| - (CONS '|Mapping| |signature'|) |oldE|)))) - (COND - ((NULL (CAR |signature'|)) - (SPADLET |signature'| - (COND - (|identSig| |identSig|) - ('T - (OR (|getSignature| |$op| - (CDR |signature'|) |e|) - (RETURN NIL))))))) - (SPADLET |e| (|giveFormalParametersValues| |argl| |e|)) - (SPADLET |$signatureOfForm| |signature'|) - (SPADLET |$functionLocations| - (CONS (CONS (CONS |$op| - (CONS |$signatureOfForm| NIL)) - |lineNumber|) - |$functionLocations|)) - (SPADLET |e| (|addDomain| (CAR |signature'|) |e|)) - (SPADLET |e| (|compArgumentConditions| |e|)) - (COND - (|$profileCompiler| - (DO ((G166836 |argl| (CDR G166836)) (|x| NIL) - (G166837 (CDR |signature'|) (CDR G166837)) - (|t| NIL)) - ((OR (ATOM G166836) - (PROGN (SETQ |x| (CAR G166836)) NIL) - (ATOM G166837) - (PROGN (SETQ |t| (CAR G166837)) NIL)) - NIL) - (SEQ (EXIT (|profileRecord| '|arguments| |x| |t|)))))) - (DO ((G166849 |signature'| (CDR G166849)) - (|domain| NIL)) - ((OR (ATOM G166849) - (PROGN (SETQ |domain| (CAR G166849)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |e| (|addDomain| |domain| |e|))))) - (SPADLET |rettype| - (|resolve| (CAR |signature'|) |$returnMode|)) - (SPADLET |localOrExported| - (COND - ((AND (NULL (|member| |$op| |$formalArgList|)) - (PROGN - (SPADLET |ISTMP#1| - (|getmode| |$op| |e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|)))) - '|local|) - ('T '|exported|))) - (SPADLET |formattedSig| - (|formatUnabbreviated| - (CONS '|Mapping| |signature'|))) - (COND - ((AND |$compileOnlyCertainItems| - (NULL (|member| |$op| |$compileOnlyCertainItems|))) - (|sayBrightly| - (CONS " skipping " - (CONS |localOrExported| (|bright| |$op|)))) - (CONS NIL - (CONS (CONS '|Mapping| |signature'|) - (CONS |oldE| NIL)))) - ('T - (|sayBrightly| - (CONS " compiling " - (CONS |localOrExported| - (APPEND (|bright| |$op|) - (CONS ": " - |formattedSig|))))) - (SPADLET |returnType| (CAR |signature'|)) - (SPADLET |trialT| - (AND (BOOT-EQUAL |returnType| '$) - (|comp| |body| |$EmptyMode| |e|))) - (SPADLET T$ - (OR (AND |trialT| - (|coerce| |trialT| |returnType|)) - (CATCH '|compCapsuleBody| - (|compOrCroak| |body| |returnType| |e|)))) - (|markChanges| |originalDef| T$ |$signatureOfForm|) - (CONS NIL - (CONS (CONS '|Mapping| |signature'|) - (CONS |oldE| NIL)))))))))) - -;compCapsuleInner(itemList,m,e) == -; e:= addInformation(m,e) -; --puts a new 'special' property of $Information -; data:= ["PROGN",:itemList] -; --RPLACd by compCapsuleItems and Friends -; e:= compCapsuleItems(itemList,nil,e) -; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => -; [nil,m,e] --nonsense but that's fine -; localParList:= $functorLocalParameters -; if $addForm then data:= ['add,$addForm,data] -; code:= -; $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data -; processFunctorOrPackage($form,$signature,data,localParList,m,e) -; [MKPF([:$getDomainCode,code],"PROGN"),m,e] - -(DEFUN |compCapsuleInner| (|itemList| |m| |e|) - (PROG (|localParList| |data| |code|) - (declare (special |$getDomainCode| |$signature| |$form| |$addForm| - |$insideCategoryPackageIfTrue| |$insideCategoryIfTrue| - |$functorLocalParameters| |$convert2NewCompiler|)) - (RETURN - (PROGN - (SPADLET |e| (|addInformation| |m| |e|)) - (SPADLET |data| (CONS 'PROGN |itemList|)) - (SPADLET |e| (|compCapsuleItems| |itemList| NIL |e|)) - (COND - ((AND (BOUNDP '|$convert2NewCompiler|) - |$convert2NewCompiler|) - (CONS NIL (CONS |m| (CONS |e| NIL)))) - ('T (SPADLET |localParList| |$functorLocalParameters|) - (COND - (|$addForm| - (SPADLET |data| - (CONS '|add| - (CONS |$addForm| (CONS |data| NIL)))))) - (SPADLET |code| - (COND - ((AND |$insideCategoryIfTrue| - (NULL |$insideCategoryPackageIfTrue|)) - |data|) - ('T - (|processFunctorOrPackage| |$form| |$signature| - |data| |localParList| |m| |e|)))) - (CONS (MKPF (APPEND |$getDomainCode| (CONS |code| NIL)) - 'PROGN) - (CONS |m| (CONS |e| NIL))))))))) - -;compSingleCapsuleItem(item,$predl,$e) == -; $localImportStack : local := nil -; $localDeclareStack: local := nil -; $markFreeStack: local := nil -; newItem := macroExpandInPlace(item,qe(25,$e)) -; qe(26,$e) -; doIt(newItem, $predl) -; qe(27,$e) -; $e - -(DEFUN |compSingleCapsuleItem| (|item| |$predl| |$e|) - (DECLARE (SPECIAL |$predl| |$e|)) - (PROG (|$localImportStack| |$localDeclareStack| |$markFreeStack| - |newItem|) - (DECLARE (SPECIAL |$localImportStack| |$localDeclareStack| - |$markFreeStack|)) - (RETURN - (PROGN - (SPADLET |$localImportStack| NIL) - (SPADLET |$localDeclareStack| NIL) - (SPADLET |$markFreeStack| NIL) - (SPADLET |newItem| - (|macroExpandInPlace| |item| (|qe| 25 |$e|))) - (|qe| 26 |$e|) - (|doIt| |newItem| |$predl|) - (|qe| 27 |$e|) - |$e|)))) - -;compImport(["import",:doms],m,e) == -; for dom in doms repeat -; dom := markKillAll dom -; markImport dom -; e:=addDomain(dom,e) -; ["/throwAway",$NoValueMode,e] - -(DEFUN |compImport| (G166966 |m| |e|) - (declare (ignore |m|)) - (PROG (|doms|) - (declare (special |$NoValueMode|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G166966) '|import|) (CAR G166966))) - (SPADLET |doms| (CDR G166966)) - (DO ((G166981 |doms| (CDR G166981)) (|dom| NIL)) - ((OR (ATOM G166981) - (PROGN (SETQ |dom| (CAR G166981)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |dom| (|markKillAll| |dom|)) - (|markImport| |dom|) - (SPADLET |e| (|addDomain| |dom| |e|)))))) - (CONS '|/throwAway| (CONS |$NoValueMode| (CONS |e| NIL)))))))) - -;mkUnion(a,b) == -; b="$" and $Rep is ["Union",:l] => b -; a is ["Union",:l] => -; b is ["Union",:l'] => ["Union",:setUnion(l,l')] -; MEMBER(b, l) => a -; ["Union",:setUnion([b],l)] -; b is ["Union",:l] => -; MEMBER(a, l) => b -; ["Union",:setUnion([a],l)] -; STRINGP a => ["Union",b,a] -; ["Union",a,b] - -(DEFUN |mkUnion| (|a| |b|) - (PROG (|l'| |l|) - (declare (special |$Rep|)) - (RETURN - (COND - ((AND (BOOT-EQUAL |b| '$) (PAIRP |$Rep|) - (EQ (QCAR |$Rep|) '|Union|) - (PROGN (SPADLET |l| (QCDR |$Rep|)) 'T)) - |b|) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|Union|) - (PROGN (SPADLET |l| (QCDR |a|)) 'T)) - (COND - ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) - (PROGN (SPADLET |l'| (QCDR |b|)) 'T)) - (CONS '|Union| (|union| |l| |l'|))) - ((|member| |b| |l|) |a|) - ('T (CONS '|Union| (|union| (CONS |b| NIL) |l|))))) - ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) - (PROGN (SPADLET |l| (QCDR |b|)) 'T)) - (COND - ((|member| |a| |l|) |b|) - ('T (CONS '|Union| (|union| (CONS |a| NIL) |l|))))) - ((STRINGP |a|) (CONS '|Union| (CONS |b| (CONS |a| NIL)))) - ('T (CONS '|Union| (CONS |a| (CONS |b| NIL)))))))) - -;compForMode(x,m,e) == -; $compForModeIfTrue: local:= true -; $convert2NewCompiler: local := nil -; comp(x,m,e) - -(DEFUN |compForMode| (|x| |m| |e|) - (PROG (|$compForModeIfTrue| |$convert2NewCompiler|) - (DECLARE (SPECIAL |$compForModeIfTrue| |$convert2NewCompiler|)) - (RETURN - (PROGN - (SPADLET |$compForModeIfTrue| 'T) - (SPADLET |$convert2NewCompiler| NIL) - (|comp| |x| |m| |e|))))) - -;compMakeCategoryObject(c,$e) == -; not isCategoryForm(c,$e) => nil -; c := markKillAll c -; u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] -; nil - -(DEFUN |compMakeCategoryObject| (|c| |$e|) - (DECLARE (SPECIAL |$e|)) - (PROG (|u|) - (declare (special |$Category|)) - (RETURN - (COND - ((NULL (|isCategoryForm| |c| |$e|)) NIL) - ('T (SPADLET |c| (|markKillAll| |c|)) - (COND - ((SPADLET |u| (|mkEvalableCategoryForm| |c|)) - (CONS (|eval| (|markKillAll| |u|)) - (CONS |$Category| (CONS |$e| NIL)))) - ('T NIL))))))) - -;macroExpand(x,e) == --not worked out yet -; atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) -; x is ['DEF,lhs,sig,spCases,rhs] => -; ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), -; macroExpand(rhs,e)] -; x is ['MI,a,b] => -; ['MI,a,macroExpand(b,e)] -; macroExpandList(x,e) - -(DEFUN |macroExpand| (|x| |e|) - (PROG (|u| |lhs| |sig| |ISTMP#3| |spCases| |ISTMP#4| |rhs| |ISTMP#1| - |a| |ISTMP#2| |b|) - (RETURN - (COND - ((ATOM |x|) - (COND - ((SPADLET |u| (|get| |x| '|macro| |e|)) - (|macroExpand| |u| |e|)) - ('T |x|))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |lhs| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |sig| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |spCases| - (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |rhs| - (QCAR |ISTMP#4|)) - 'T)))))))))) - (CONS 'DEF - (CONS (|macroExpand| |lhs| |e|) - (CONS (|macroExpandList| |sig| |e|) - (CONS (|macroExpandList| |spCases| |e|) - (CONS (|macroExpand| |rhs| |e|) NIL)))))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) - (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)))))) - (CONS 'MI (CONS |a| (CONS (|macroExpand| |b| |e|) NIL)))) - ('T (|macroExpandList| |x| |e|)))))) - -;getSuccessEnvironment(a,e) == -; -- the next four lines try to ensure that explicit special-case tests -; -- prevent implicit ones from being generated -; a is ["has",x,m] => -; x := unLet x -; IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) -; e -; a is ["is",id,m] => -; id := unLet id -; IDENTP id and isDomainForm(m,$EmptyEnvironment) => -; e:=put(id,"specialCase",m,e) -; currentProplist:= getProplist(id,e) -; [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs -; newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) -; addBinding(id,newProplist,e) -; e -; a is ["case",x,m] and (x := unLet x) and IDENTP x => -; put(x,"condition",[a,:get(x,"condition",e)],e) -; e - -(DEFUN |getSuccessEnvironment| (|a| |e|) - (PROG (|id| |currentProplist| T$ |newProplist| |ISTMP#1| |ISTMP#2| |m| |x|) - (declare (special |$EmptyMode| |$EmptyEnvironment|)) - (RETURN - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|has|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (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 |m| (QCAR |ISTMP#2|)) 'T)))))) - (SPADLET |x| (|unLet| |x|)) - (COND - ((AND (IDENTP |x|) (|isDomainForm| |m| |$EmptyEnvironment|)) - (|put| |x| '|specialCase| |m| |e|)) - ('T |e|))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|is|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |id| (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)))))) - (SPADLET |id| (|unLet| |id|)) - (COND - ((AND (IDENTP |id|) - (|isDomainForm| |m| |$EmptyEnvironment|)) - (SPADLET |e| (|put| |id| '|specialCase| |m| |e|)) - (SPADLET |currentProplist| (|getProplist| |id| |e|)) - (SPADLET T$ - (OR (|comp| |m| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |e| (CADDR T$)) - (SPADLET |newProplist| - (|consProplistOf| |id| |currentProplist| '|value| - (|removeEnv| T$))) - (|addBinding| |id| |newProplist| |e|)) - ('T |e|))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|case|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (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 |m| (QCAR |ISTMP#2|)) 'T))))) - (SPADLET |x| (|unLet| |x|)) (IDENTP |x|)) - (|put| |x| '|condition| - (CONS |a| (|get| |x| '|condition| |e|)) |e|)) - ('T |e|))))) - -;getInverseEnvironment(a,E) == -; atom a => E -; [op,:argl]:= a -;-- the next five lines try to ensure that explicit special-case tests -;-- prevent implicit ones from being generated -; op="has" => -; [x,m]:= argl -; x := unLet x -; IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) -; E -; a is ["case",x,m] and (x := unLet x) and IDENTP x => -; --the next two lines are necessary to get 3-branched Unions to work -; -- old-style unions, that is -; if corrupted? get(x,"condition",E) then systemError 'condition -; (get(x,"condition",E) is [["OR",:oldpred]]) and MEMBER(a,oldpred) => -; put(x,"condition",LIST MKPF(DELETE(a,oldpred),"OR"),E) -; getUnionMode(x,E) is ["Union",:l] or systemError 'Union -; if corrupted? l then systemError 'list -; l':= DELETE(m,l) -; for u in l' repeat -; if u is ['_:,=m,:.] then l':=DELETE(u,l') -; newpred:= MKPF([["case",x,m'] for m' in l'],"OR") -; put(x,"condition",[newpred,:get(x,"condition",E)],E) -; E - -(DEFUN |getInverseEnvironment| (|a| E) - (PROG (|op| |argl| |m| |x| |ISTMP#2| |oldpred| |l| |ISTMP#1| |l'| - |newpred|) - (declare (special |$EmptyEnvironment|)) - (RETURN - (SEQ (COND - ((ATOM |a|) E) - ('T (SPADLET |op| (CAR |a|)) (SPADLET |argl| (CDR |a|)) - (COND - ((BOOT-EQUAL |op| '|has|) (SPADLET |x| (CAR |argl|)) - (SPADLET |m| (CADR |argl|)) - (SPADLET |x| (|unLet| |x|)) - (COND - ((AND (IDENTP |x|) - (|isDomainForm| |m| |$EmptyEnvironment|)) - (|put| |x| '|specialCase| |m| E)) - ('T E))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|case|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (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 |m| (QCAR |ISTMP#2|)) - 'T))))) - (SPADLET |x| (|unLet| |x|)) (IDENTP |x|)) - (COND - ((|corrupted?| (|get| |x| '|condition| E)) - (|systemError| '|condition|))) - (COND - ((AND (PROGN - (SPADLET |ISTMP#1| - (|get| |x| '|condition| E)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) 'OR) - (PROGN - (SPADLET |oldpred| - (QCDR |ISTMP#2|)) - 'T))))) - (|member| |a| |oldpred|)) - (|put| |x| '|condition| - (LIST (MKPF (|delete| |a| |oldpred|) 'OR)) - E)) - ('T - (OR (PROGN - (SPADLET |ISTMP#1| (|getUnionMode| |x| E)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Union|) - (PROGN - (SPADLET |l| (QCDR |ISTMP#1|)) - 'T))) - (|systemError| '|Union|)) - (COND - ((|corrupted?| |l|) (|systemError| '|list|))) - (SPADLET |l'| (|delete| |m| |l|)) - (DO ((G167238 |l'| (CDR G167238)) (|u| NIL)) - ((OR (ATOM G167238) - (PROGN (SETQ |u| (CAR G167238)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (PAIRP |u|) - (EQ (QCAR |u|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |m|)))) - (SPADLET |l'| (|delete| |u| |l'|))) - ('T NIL))))) - (SPADLET |newpred| - (MKPF (PROG (G167248) - (SPADLET G167248 NIL) - (RETURN - (DO - ((G167253 |l'| - (CDR G167253)) - (|m'| NIL)) - ((OR (ATOM G167253) - (PROGN - (SETQ |m'| (CAR G167253)) - NIL)) - (NREVERSE0 G167248)) - (SEQ - (EXIT - (SETQ G167248 - (CONS - (CONS '|case| - (CONS |x| - (CONS |m'| NIL))) - G167248))))))) - 'OR)) - (|put| |x| '|condition| - (CONS |newpred| (|get| |x| '|condition| E)) - E)))) - ('T E)))))))) - -;unLet x == -; x is ['LET,u,:.] => unLet u -; x - -(DEFUN |unLet| (|x|) - (PROG (|ISTMP#1| |u|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) 'T)))) - (|unLet| |u|)) - ('T |x|))))) - -;corrupted? u == -; u is [op,:r] => -; MEMQ(op,'(WI MI PART)) => true -; or/[corrupted? x for x in r] -; false - -(DEFUN |corrupted?| (|u|) - (PROG (|op| |r|) - (RETURN - (SEQ (COND - ((AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |r| (QCDR |u|)) - 'T)) - (COND - ((MEMQ |op| '(WI MI PART)) 'T) - ('T - (PROG (G167297) - (SPADLET G167297 NIL) - (RETURN - (DO ((G167303 NIL G167297) - (G167304 |r| (CDR G167304)) (|x| NIL)) - ((OR G167303 (ATOM G167304) - (PROGN (SETQ |x| (CAR G167304)) NIL)) - G167297) - (SEQ (EXIT (SETQ G167297 - (OR G167297 - (|corrupted?| |x|))))))))))) - ('T NIL)))))) - -;--====================================================================== -;-- From apply.boot -;--====================================================================== -;applyMapping([op,:argl],m,e,ml) == -; #argl^=#ml-1 => nil -; isCategoryForm(first ml,e) => -; --is op a functor? -; pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] -; ml' := SUBLIS(pairlis, ml) -; argl':= -; [T.expr for x in argl for m' in rest ml'] where -; T() == [.,.,e]:= comp(x,m',e) or return "failed" -; if argl'="failed" then return nil -; form:= [op,:argl'] -;---------------------> new <---------------------------- -; if constructor? op then form := markKillAll form -;---------------------> new <---------------------------- -; convert([form,first ml',e],m) -; argl':= -; [T.expr for x in argl for m' in rest ml] where -; T() == [.,.,e]:= comp(x,m',e) or return "failed" -; if argl'="failed" then return nil -; form:= -; not MEMBER(op,$formalArgList) and ATOM op and not get(op,'value,e) => -; nprefix := $prefix or -; -- following needed for referencing local funs at capsule level -; getAbbreviation($op,#rest $form) -; [op',:argl',"$"] where -; op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) -; ['call,['applyFun,op],:argl'] -; pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] -; convert([form,SUBLIS(pairlis,first ml),e],m) - -(DEFUN |applyMapping| (G167341 |m| |e| |ml|) - (PROG (|op| |argl| |ml'| |LETTMP#1| |argl'| |nprefix| |op'| |form| - |pairlis|) - (declare (special |$FormalMapVariableList| |$form| |$op| |$prefix| - |$formalArgList|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR G167341)) - (SPADLET |argl| (CDR G167341)) - (COND - ((NEQUAL (|#| |argl|) (SPADDIFFERENCE (|#| |ml|) 1)) - NIL) - ((|isCategoryForm| (CAR |ml|) |e|) - (SPADLET |pairlis| - (PROG (G167363) - (SPADLET G167363 NIL) - (RETURN - (DO ((G167369 |argl| (CDR G167369)) - (|a| NIL) - (G167370 |$FormalMapVariableList| - (CDR G167370)) - (|v| NIL)) - ((OR (ATOM G167369) - (PROGN - (SETQ |a| (CAR G167369)) - NIL) - (ATOM G167370) - (PROGN - (SETQ |v| (CAR G167370)) - NIL)) - (NREVERSE0 G167363)) - (SEQ (EXIT - (SETQ G167363 - (CONS (CONS |v| |a|) G167363)))))))) - (SPADLET |ml'| (SUBLIS |pairlis| |ml|)) - (SPADLET |argl'| - (PROG (G167387) - (SPADLET G167387 NIL) - (RETURN - (DO ((G167396 |argl| (CDR G167396)) - (|x| NIL) - (G167397 (CDR |ml'|) - (CDR G167397)) - (|m'| NIL)) - ((OR (ATOM G167396) - (PROGN - (SETQ |x| (CAR G167396)) - NIL) - (ATOM G167397) - (PROGN - (SETQ |m'| (CAR G167397)) - NIL)) - (NREVERSE0 G167387)) - (SEQ (EXIT - (SETQ G167387 - (CONS - (CAR - (PROGN - (SPADLET |LETTMP#1| - (OR (|comp| |x| |m'| |e|) - (RETURN '|failed|))) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|)) - G167387)))))))) - (COND ((BOOT-EQUAL |argl'| '|failed|) (RETURN NIL))) - (SPADLET |form| (CONS |op| |argl'|)) - (COND - ((|constructor?| |op|) - (SPADLET |form| (|markKillAll| |form|)))) - (|convert| - (CONS |form| (CONS (CAR |ml'|) (CONS |e| NIL))) - |m|)) - ('T - (SPADLET |argl'| - (PROG (G167414) - (SPADLET G167414 NIL) - (RETURN - (DO ((G167423 |argl| (CDR G167423)) - (|x| NIL) - (G167424 (CDR |ml|) - (CDR G167424)) - (|m'| NIL)) - ((OR (ATOM G167423) - (PROGN - (SETQ |x| (CAR G167423)) - NIL) - (ATOM G167424) - (PROGN - (SETQ |m'| (CAR G167424)) - NIL)) - (NREVERSE0 G167414)) - (SEQ (EXIT - (SETQ G167414 - (CONS - (CAR - (PROGN - (SPADLET |LETTMP#1| - (OR (|comp| |x| |m'| |e|) - (RETURN '|failed|))) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|)) - G167414)))))))) - (COND ((BOOT-EQUAL |argl'| '|failed|) (RETURN NIL))) - (SPADLET |form| - (COND - ((AND (NULL (|member| |op| |$formalArgList|)) - (ATOM |op|) - (NULL (|get| |op| '|value| |e|))) - (SPADLET |nprefix| - (OR |$prefix| - (|getAbbreviation| |$op| - (|#| (CDR |$form|))))) - (SPADLET |op'| - (INTERN - (STRCONC (|encodeItem| |nprefix|) - '|;| (|encodeItem| |op|)))) - (CONS |op'| (APPEND |argl'| (CONS '$ NIL)))) - ('T - (CONS '|call| - (CONS (CONS '|applyFun| - (CONS |op| NIL)) - |argl'|))))) - (SPADLET |pairlis| - (PROG (G167438) - (SPADLET G167438 NIL) - (RETURN - (DO ((G167444 |argl'| (CDR G167444)) - (|a| NIL) - (G167445 |$FormalMapVariableList| - (CDR G167445)) - (|v| NIL)) - ((OR (ATOM G167444) - (PROGN - (SETQ |a| (CAR G167444)) - NIL) - (ATOM G167445) - (PROGN - (SETQ |v| (CAR G167445)) - NIL)) - (NREVERSE0 G167438)) - (SEQ (EXIT - (SETQ G167438 - (CONS (CONS |v| |a|) G167438)))))))) - (|convert| - (CONS |form| - (CONS (SUBLIS |pairlis| (CAR |ml|)) - (CONS |e| NIL))) - |m|)))))))) - -;compFormWithModemap(form,m,e,modemap) == -; compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) - -(DEFUN |compFormWithModemap| (|form| |m| |e| |modemap|) - (OR (|compFormWithModemap1| |form| |m| |e| |modemap| 'T) - (|compFormWithModemap1| |form| |m| |e| |modemap| NIL))) - -;compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == -; [op,:argl] := form := markKillExpr form -; [[dc,:.],:.] := modemap -;----------> new: <----------- -; if Rep2Dollar? then -; if dc = 'Rep then -; modemap := SUBST('Rep,'_$,modemap) -; m := SUBST('Rep,'_$,m) -; else return nil -;----------> new: <----------- -; [map:= [.,target,:.],[pred,impl]]:= modemap -; -- this fails if the subsuming modemap is conditional -; --impl is ['Subsumed,:.] => nil -; if isCategoryForm(target,e) and isFunctor op then -; [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil -; [map:= [.,target,:.],:cexpr]:= modemap -; sv:=listOfSharpVars map -; if sv then -; -- SAY [ "compiling ", op, " in compFormWithModemap, -; -- mode= ",map," sharp vars=",sv] -; for x in argl for ss in $FormalMapVariableList repeat -; if ss in sv then -; [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) -; -- SAY ["new map is",map] -; not (target':= coerceable(target,m,e)) => nil -; markMap := map -; map:= [target',:rest map] -; [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil -; -; --generate code; return -; T:= -; e':= -; Tl => (LAST Tl).env -; e -; [x',m',e'] where -; m':= SUBLIS(sl,map.(1)) -; x':= -; form':= [f,:[t.expr for t in Tl]] -; m'=$Category or isCategoryForm(m',e) => form' -; -- try to deal with new-style Unions where we know the conditions -; op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and -; (c:=get(z,'condition,e)) and -; c is [['case,=z,c1]] and -; (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => -;-- first is a full tag, as placed by getInverseEnvironment -;-- second is what getSuccessEnvironment will place there -; ["CDR",z] -; markTran(form,form',markMap,e') -; qt(18,T) -; convert(T,m) - -(DEFUN |compFormWithModemap1| (|form| |m| |e| |modemap| |Rep2Dollar?|) - (PROG (|op| |argl| |dc| |pred| |impl| |sv| |target| |cexpr| |target'| - |markMap| |map| |LETTMP#1| |f| |Tl| |sl| |e'| |m'| - |form'| |z| |c| |ISTMP#3| |c1| |ISTMP#1| |ISTMP#2| |x'| - T$) - (declare (special |$Category| |$FormalMapVariableList|)) - (RETURN - (SEQ (PROGN - (SPADLET |form| (|markKillExpr| |form|)) - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |dc| (CAAR |modemap|)) - (COND - (|Rep2Dollar?| - (COND - ((BOOT-EQUAL |dc| '|Rep|) - (SPADLET |modemap| (MSUBST '|Rep| '$ |modemap|)) - (SPADLET |m| (MSUBST '|Rep| '$ |m|))) - ('T (RETURN NIL))))) - (SPADLET |map| (CAR |modemap|)) - (SPADLET |target| (CADAR |modemap|)) - (SPADLET |pred| (CAADR |modemap|)) - (SPADLET |impl| (CADADR |modemap|)) - (COND - ((AND (|isCategoryForm| |target| |e|) - (|isFunctor| |op|)) - (SPADLET |LETTMP#1| - (OR (|substituteIntoFunctorModemap| |argl| - |modemap| |e|) - (RETURN NIL))) - (SPADLET |modemap| (CAR |LETTMP#1|)) - (SPADLET |e| (CADR |LETTMP#1|)) - (SPADLET |map| (CAR |modemap|)) - (SPADLET |target| (CADAR |modemap|)) - (SPADLET |cexpr| (CDR |modemap|)) |modemap|)) - (SPADLET |sv| (|listOfSharpVars| |map|)) - (COND - (|sv| (DO ((G167572 |argl| (CDR G167572)) (|x| NIL) - (G167573 |$FormalMapVariableList| - (CDR G167573)) - (|ss| NIL)) - ((OR (ATOM G167572) - (PROGN (SETQ |x| (CAR G167572)) NIL) - (ATOM G167573) - (PROGN (SETQ |ss| (CAR G167573)) NIL)) - NIL) - (SEQ (EXIT (COND - ((|member| |ss| |sv|) - (SPADLET |modemap| - (MSUBST |x| |ss| |modemap|)) - (SPADLET |map| (CAR |modemap|)) - (SPADLET |target| - (CADAR |modemap|)) - (SPADLET |cexpr| (CDR |modemap|)) - |modemap|) - ('T NIL))))))) - (COND - ((NULL (SPADLET |target'| - (|coerceable| |target| |m| |e|))) - NIL) - ('T (SPADLET |markMap| |map|) - (SPADLET |map| (CONS |target'| (CDR |map|))) - (SPADLET |LETTMP#1| - (OR (|compApplyModemap| |form| |modemap| |e| - NIL) - (RETURN NIL))) - (SPADLET |f| (CAR |LETTMP#1|)) - (SPADLET |Tl| (CADR |LETTMP#1|)) - (SPADLET |sl| (CADDR |LETTMP#1|)) - (SPADLET T$ - (PROGN - (SPADLET |e'| - (COND - (|Tl| (CADDR (|last| |Tl|))) - ('T |e|))) - (SPADLET |m'| (SUBLIS |sl| (ELT |map| 1))) - (SPADLET |x'| - (PROGN - (SPADLET |form'| - (CONS |f| - (PROG (G167586) - (SPADLET G167586 NIL) - (RETURN - (DO - ((G167591 |Tl| - (CDR G167591)) - (|t| NIL)) - ((OR (ATOM G167591) - (PROGN - (SETQ |t| - (CAR G167591)) - NIL)) - (NREVERSE0 G167586)) - (SEQ - (EXIT - (SETQ G167586 - (CONS (CAR |t|) - G167586))))))))) - (COND - ((OR - (BOOT-EQUAL |m'| |$Category|) - (|isCategoryForm| |m'| |e|)) - |form'|) - ((AND (BOOT-EQUAL |op| '|elt|) - (PAIRP |f|) - (EQ (QCAR |f|) 'XLAM) - (IDENTP - (SPADLET |z| (CAR |argl|))) - (SPADLET |c| - (|get| |z| '|condition| |e|)) - (PAIRP |c|) - (EQ (QCDR |c|) NIL) - (PROGN - (SPADLET |ISTMP#1| - (QCAR |c|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) - '|case|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQUAL (QCAR |ISTMP#2|) - |z|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) - NIL) - (PROGN - (SPADLET |c1| - (QCAR |ISTMP#3|)) - 'T))))))) - (OR - (AND (PAIRP |c1|) - (EQ (QCAR |c1|) '|:|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |c1|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) - (CADR |argl|)) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (EQUAL - (QCAR |ISTMP#2|) - |m|)))))) - (EQ |c1| (CADR |argl|)))) - (CONS 'CDR (CONS |z| NIL))) - ('T - (|markTran| |form| |form'| - |markMap| |e'|))))) - (CONS |x'| (CONS |m'| (CONS |e'| NIL))))) - (|qt| 18 T$) (|convert| T$ |m|)))))))) - -;convert(T,m) == -; tcheck T -; qe(23,T.env) -; coerce(T,resolve(T.mode,m) or return nil) - -(DEFUN |convert| (T$ |m|) - (PROG () - (RETURN - (PROGN - (|tcheck| T$) - (|qe| 23 (CADDR T$)) - (|coerce| T$ (OR (|resolve| (CADR T$) |m|) (RETURN NIL))))))) - -;compElt(origForm,m,E) == -; form := markKillAll origForm -; form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) -; aDomain="Lisp" => -; markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) -; isDomainForm(aDomain,E) => -; markImport opOf aDomain -; E:= addDomain(aDomain,E) -; mmList:= getModemapListFromDomain(anOp,0,aDomain,E) -; modemap:= -; n:=#mmList -; 1=n => mmList.(0) -; 0=n => -; return -; stackMessage ['"Operation ","%b",anOp,"%d", -; '"missing from domain: ", aDomain] -; stackWarning ['"more than 1 modemap for: ",anOp, -; '" with dc=",aDomain,'" ===>" -; ,mmList] -; mmList.(0) -;----------> new: <----------- -; if aDomain = 'Rep then -; modemap := SUBST('Rep,'_$,modemap) -; m := SUBST('Rep,'_$,m) -;----------> new: <----------- -; [sig,[pred,val]]:= modemap -; #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? -;--+ -; val := genDeltaEntry [opOf anOp,:modemap] -; x := markTran(origForm,[val],sig,[E]) -; [x,first rest sig,E] --implies fn calls used to access constants -; compForm(origForm,m,E) - -(DEFUN |compElt| (|origForm| |m| E) - (PROG (|form| |ISTMP#1| |aDomain| |ISTMP#2| |anOp| |mmList| |n| - |modemap| |sig| |pred| |val| |x|) - (declare (special |$Zero| |$One|)) - (RETURN - (PROGN - (SPADLET |form| (|markKillAll| |origForm|)) - (COND - ((NULL (AND (PAIRP |form|) (EQ (QCAR |form|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |aDomain| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |anOp| (QCAR |ISTMP#2|)) - 'T))))))) - (|compForm| |origForm| |m| E)) - ((BOOT-EQUAL |aDomain| '|Lisp|) - (|markLisp| - (CONS (COND - ((BOOT-EQUAL |anOp| |$Zero|) 0) - ((BOOT-EQUAL |anOp| |$One|) 1) - ('T |anOp|)) - (CONS |m| (CONS E NIL))) - E)) - ((|isDomainForm| |aDomain| E) - (|markImport| (|opOf| |aDomain|)) - (SPADLET E (|addDomain| |aDomain| E)) - (SPADLET |mmList| - (|getModemapListFromDomain| |anOp| 0 |aDomain| E)) - (SPADLET |modemap| - (PROGN - (SPADLET |n| (|#| |mmList|)) - (COND - ((EQL 1 |n|) (ELT |mmList| 0)) - ((EQL 0 |n|) - (RETURN - (|stackMessage| - (CONS "Operation " - (CONS '|%b| - (CONS |anOp| - (CONS '|%d| - (CONS - "missing from domain: " - (CONS |aDomain| NIL))))))))) - ('T - (|stackWarning| - (CONS "more than 1 modemap for: " - (CONS |anOp| - (CONS " with dc=" - (CONS |aDomain| - (CONS " ===>" - (CONS |mmList| NIL))))))) - (ELT |mmList| 0))))) - (COND - ((BOOT-EQUAL |aDomain| '|Rep|) - (SPADLET |modemap| (MSUBST '|Rep| '$ |modemap|)) - (SPADLET |m| (MSUBST '|Rep| '$ |m|)))) - (SPADLET |sig| (CAR |modemap|)) - (SPADLET |pred| (CAADR |modemap|)) - (SPADLET |val| (CADADR |modemap|)) - (COND - ((AND (NEQUAL (|#| |sig|) 2) - (NULL (AND (PAIRP |val|) (EQ (QCAR |val|) '|elt|)))) - NIL) - ('T - (SPADLET |val| - (|genDeltaEntry| - (CONS (|opOf| |anOp|) |modemap|))) - (SPADLET |x| - (|markTran| |origForm| (CONS |val| NIL) |sig| - (CONS E NIL))) - (CONS |x| (CONS (CAR (CDR |sig|)) (CONS E NIL)))))) - ('T (|compForm| |origForm| |m| E))))))) - -;pause op == op - -(DEFUN |pause| (|op|) |op|) - -;compApplyModemap(form,modemap,$e,sl) == -; [op,:argl] := form --form to be compiled -; [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing -; -; -- $e is the current environment -; -- sl substitution list, nil means bottom-up, otherwise top-down -; -; -- 0. fail immediately if #argl=#margl -; -; if #argl^=#margl then return nil -; -; -- 1. use modemap to evaluate arguments, returning failed if -; -- not possible -; -; lt:= -; [[.,m',$e]:= -; comp(y,g,$e) or return "failed" where -; g:= SUBLIS(sl,m) where -; sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] -; lt="failed" => return nil -; -; -- 2. coerce each argument to final domain, returning failed -; -- if not possible -; -; lt':= [coerce(y,d) or return "failed" -; for y in lt for d in SUBLIS(sl,margl)] -; lt'="failed" => return nil -; -; -- 3. obtain domain-specific function, if possible, and return -; -; --$bindings is bound by compMapCond -; [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil -; -;--+ can no longer trust what the modemap says for a reference into -;--+ an exterior domain (it is calculating the displacement based on view -;--+ information which is no longer valid; thus ignore this index and -;--+ store the signature instead. -; -;--$NRTflag=true and f is [op1,d,.] and NE(d,'$) and MEMBER(op1,'(ELT CONST)) => -; f is [op1,d,.] and MEMBER(op1,'(ELT CONST Subsumed)) => -; [genDeltaEntry [op,:modemap],lt',$bindings] -; markImport mc -; [f,lt',$bindings] - -(DEFUN |compApplyModemap| (|form| |modemap| |$e| |sl|) - (DECLARE (SPECIAL |$e|)) - (PROG (|op| |argl| |mc| |mr| |margl| |fnsel| |g| |m'| |lt| |lt'| - |LETTMP#1| |f| |op1| |ISTMP#1| |d| |ISTMP#2|) - (declare (special |$bindings|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |mc| (CAAR |modemap|)) - (SPADLET |mr| (CADAR |modemap|)) - (SPADLET |margl| (CDDAR |modemap|)) - (SPADLET |fnsel| (CDR |modemap|)) - (COND ((NEQUAL (|#| |argl|) (|#| |margl|)) (RETURN NIL))) - (SPADLET |lt| - (PROG (G167753) - (SPADLET G167753 NIL) - (RETURN - (DO ((G167765 |argl| (CDR G167765)) - (|y| NIL) - (G167766 |margl| (CDR G167766)) - (|m| NIL)) - ((OR (ATOM G167765) - (PROGN - (SETQ |y| (CAR G167765)) - NIL) - (ATOM G167766) - (PROGN - (SETQ |m| (CAR G167766)) - NIL)) - (NREVERSE0 G167753)) - (SEQ (EXIT (SETQ G167753 - (CONS - (PROGN - (SPADLET |sl| - (|pmatchWithSl| |m'| |m| - |sl|)) - (SPADLET |g| - (SUBLIS |sl| |m|)) - (SPADLET |LETTMP#1| - (OR (|comp| |y| |g| |$e|) - (RETURN '|failed|))) - (SPADLET |m'| - (CADR |LETTMP#1|)) - (SPADLET |$e| - (CADDR |LETTMP#1|)) - |LETTMP#1|) - G167753)))))))) - (COND - ((BOOT-EQUAL |lt| '|failed|) (RETURN NIL)) - ('T - (SPADLET |lt'| - (PROG (G167780) - (SPADLET G167780 NIL) - (RETURN - (DO ((G167786 |lt| (CDR G167786)) - (|y| NIL) - (G167787 (SUBLIS |sl| |margl|) - (CDR G167787)) - (|d| NIL)) - ((OR (ATOM G167786) - (PROGN - (SETQ |y| (CAR G167786)) - NIL) - (ATOM G167787) - (PROGN - (SETQ |d| (CAR G167787)) - NIL)) - (NREVERSE0 G167780)) - (SEQ (EXIT - (SETQ G167780 - (CONS - (OR (|coerce| |y| |d|) - (RETURN '|failed|)) - G167780)))))))) - (COND - ((BOOT-EQUAL |lt'| '|failed|) (RETURN NIL)) - ('T - (SPADLET |LETTMP#1| - (OR (|compMapCond| |op| |mc| |sl| |fnsel|) - (RETURN NIL))) - (SPADLET |f| (CAR |LETTMP#1|)) - (SPADLET |$bindings| (CADR |LETTMP#1|)) - (COND - ((AND (PAIRP |f|) - (PROGN - (SPADLET |op1| (QCAR |f|)) - (SPADLET |ISTMP#1| (QCDR |f|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |d| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL))))) - (|member| |op1| '(ELT CONST |Subsumed|))) - (CONS (|genDeltaEntry| (CONS |op| |modemap|)) - (CONS |lt'| (CONS |$bindings| NIL)))) - ('T (|markImport| |mc|) - (CONS |f| (CONS |lt'| (CONS |$bindings| NIL)))))))))))))) - -;compMapCond''(cexpr,dc) == -; cexpr=true => true -; --cexpr = "true" => true -;---------------> new <---------------------- -; cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] -; cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] -;---------------> new <---------------------- -; cexpr is ["not",u] => not compMapCond''(u,dc) -; cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) -; --for the time being we'll stop here - shouldn't happen so far -; --$disregardConditionIfTrue => true -; --stackSemanticError(("not known that",'%b,name, -; -- '%d,"has",'%b,cat,'%d),nil) -; --now it must be an attribute -; MEMBER(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true -; --for the time being we'll stop here - shouldn't happen so far -; stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] -; false - -(DEFUN |compMapCond''| (|cexpr| |dc|) - (PROG (|op| |l| |u| |ISTMP#1| |name| |ISTMP#2| |cat|) - (declare (special |$e| |$Information|)) - (RETURN - (SEQ (COND - ((BOOT-EQUAL |cexpr| 'T) 'T) - ((AND (PAIRP |cexpr|) - (PROGN - (SPADLET |op| (QCAR |cexpr|)) - (SPADLET |l| (QCDR |cexpr|)) - 'T) - (MEMQ |op| '(|and| AND))) - (PROG (G167850) - (SPADLET G167850 'T) - (RETURN - (DO ((G167856 NIL (NULL G167850)) - (G167857 |l| (CDR G167857)) (|u| NIL)) - ((OR G167856 (ATOM G167857) - (PROGN (SETQ |u| (CAR G167857)) NIL)) - G167850) - (SEQ (EXIT (SETQ G167850 - (AND G167850 - (|compMapCond''| |u| |dc|))))))))) - ((AND (PAIRP |cexpr|) - (PROGN - (SPADLET |op| (QCAR |cexpr|)) - (SPADLET |l| (QCDR |cexpr|)) - 'T) - (MEMQ |op| '(|or| OR))) - (PROG (G167864) - (SPADLET G167864 NIL) - (RETURN - (DO ((G167870 NIL G167864) - (G167871 |l| (CDR G167871)) (|u| NIL)) - ((OR G167870 (ATOM G167871) - (PROGN (SETQ |u| (CAR G167871)) NIL)) - G167864) - (SEQ (EXIT (SETQ G167864 - (OR G167864 - (|compMapCond''| |u| |dc|))))))))) - ((AND (PAIRP |cexpr|) (EQ (QCAR |cexpr|) '|not|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cexpr|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) 'T)))) - (NULL (|compMapCond''| |u| |dc|))) - ((AND (PAIRP |cexpr|) (EQ (QCAR |cexpr|) '|has|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cexpr|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |name| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |cat| (QCAR |ISTMP#2|)) - 'T)))))) - (COND ((|knownInfo| |cexpr|) 'T) ('T NIL))) - ((|member| (CONS 'ATTRIBUTE - (CONS |dc| (CONS |cexpr| NIL))) - (|get| '|$Information| '|special| |$e|)) - 'T) - ('T - (|stackMessage| - (CONS '|not known that| - (CONS '|%b| - (CONS |dc| - (CONS '|%d| - (CONS '|has| - (CONS '|%b| - (CONS |cexpr| (CONS '|%d| NIL))))))))) - NIL)))))) - -;--====================================================================== -;-- From nruncomp.boot -;--====================================================================== -;NRTgetLocalIndex1(item,killBindingIfTrue) == -; k := NRTassocIndex item => k -; item = $NRTaddForm => 5 -; item = '$ => 0 -; item = '_$_$ => 2 -; value:= -; MEMQ(item,$formalArgList) => item -; nil -; atom item and null MEMQ(item,'($ _$_$)) -; and null value => --give slots to atoms -; $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] -; $NRTdeltaListComp:=[item,:$NRTdeltaListComp] -; $NRTdeltaLength := $NRTdeltaLength+1 -; $NRTbase + $NRTdeltaLength - 1 -; $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] -; saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] -; saveIndex := $NRTbase + $NRTdeltaLength -; $NRTdeltaLength := $NRTdeltaLength+1 -; compEntry:= item -; ----94/11/07 -; -- WAS: compOrCroak(item,$EmptyMode,$e).expr -; RPLACA(saveNRTdeltaListComp,compEntry) -; saveIndex - -(DEFUN |NRTgetLocalIndex1| (|item| |killBindingIfTrue|) - (declare (ignore |killBindingIfTrue|)) - (PROG (|k| |value| |saveNRTdeltaListComp| |saveIndex| |compEntry|) - (declare (special |$NRTdeltaLength| |$NRTbase| |$NRTdeltaListComp| - |$NRTdeltaList| |$formalArgList| |$NRTaddForm|)) - (RETURN - (COND - ((SPADLET |k| (|NRTassocIndex| |item|)) |k|) - ((BOOT-EQUAL |item| |$NRTaddForm|) 5) - ((BOOT-EQUAL |item| '$) 0) - ((BOOT-EQUAL |item| '$$) 2) - ('T - (SPADLET |value| - (COND - ((MEMQ |item| |$formalArgList|) |item|) - ('T NIL))) - (COND - ((AND (ATOM |item|) (NULL (MEMQ |item| '($ $$))) - (NULL |value|)) - (SPADLET |$NRTdeltaList| - (CONS (CONS '|domain| - (CONS (|NRTaddInner| |item|) |value|)) - |$NRTdeltaList|)) - (SPADLET |$NRTdeltaListComp| - (CONS |item| |$NRTdeltaListComp|)) - (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1)) - (SPADDIFFERENCE (PLUS |$NRTbase| |$NRTdeltaLength|) 1)) - ('T - (SPADLET |$NRTdeltaList| - (CONS (CONS '|domain| - (CONS (|NRTaddInner| |item|) |value|)) - |$NRTdeltaList|)) - (SPADLET |saveNRTdeltaListComp| - (SPADLET |$NRTdeltaListComp| - (CONS NIL |$NRTdeltaListComp|))) - (SPADLET |saveIndex| (PLUS |$NRTbase| |$NRTdeltaLength|)) - (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1)) - (SPADLET |compEntry| |item|) - (RPLACA |saveNRTdeltaListComp| |compEntry|) |saveIndex|))))))) - -;optDeltaEntry(op,sig,dc,eltOrConst) == -; return nil --------> kill it -; $killOptimizeIfTrue = true => nil -; ndc := -; dc = '$ => $functorForm -; atom dc and (dcval := get(dc,'value,$e)) => dcval.expr -; dc -;--if (atom dc) and (dcval := get(dc,'value,$e)) -;-- then ndc := dcval.expr -;-- else ndc := dc -; sig := SUBST(ndc,dc,sig) -; not MEMQ(KAR ndc,$optimizableConstructorNames) => nil -; dcval := optCallEval ndc -; -- MSUBST guarantees to use EQUAL testing -; sig := MSUBST(devaluate dcval, ndc, sig) -; if rest ndc then -; for new in rest devaluate dcval for old in rest ndc repeat -; sig := MSUBST(new,old,sig) -; -- optCallEval sends (List X) to (LIst (Integer)) etc, -; -- so we should make the same transformation -; fn := compiledLookup(op,sig,dcval) -; if null fn then -; -- following code is to handle selectors like first, rest -; nsig := [quoteSelector tt for tt in sig] where -; quoteSelector(x) == -; not(IDENTP x) => x -; get(x,'value,$e) => x -; x='$ => x -; MKQ x -; fn := compiledLookup(op,nsig,dcval) -; if null fn then return nil -; eltOrConst="CONST" => -; hehe fn -; [op] -----------> return just the op here -;-- ['XLAM,'ignore,MKQ SPADCALL fn] -; GET(compileTimeBindingOf first fn,'SPADreplace) - -(DEFUN |optDeltaEntry,quoteSelector| (|x|) - (declare (special |$e|)) - (SEQ (IF (NULL (IDENTP |x|)) (EXIT |x|)) - (IF (|get| |x| '|value| |$e|) (EXIT |x|)) - (IF (BOOT-EQUAL |x| '$) (EXIT |x|)) (EXIT (MKQ |x|)))) - -(DEFUN |optDeltaEntry| (|op| |sig| |dc| |eltOrConst|) - (PROG (|ndc| |dcval| |nsig| |fn|) - (declare (special |$optimizableConstructorNames| |$e| |$functorForm| - |$killOptimizeIfTrue|)) - (RETURN - (SEQ (PROGN - (RETURN NIL) - (COND - ((BOOT-EQUAL |$killOptimizeIfTrue| 'T) NIL) - ('T - (SPADLET |ndc| - (COND - ((BOOT-EQUAL |dc| '$) |$functorForm|) - ((AND (ATOM |dc|) - (SPADLET |dcval| - (|get| |dc| '|value| |$e|))) - (CAR |dcval|)) - ('T |dc|))) - (SPADLET |sig| (MSUBST |ndc| |dc| |sig|)) - (COND - ((NULL (MEMQ (KAR |ndc|) - |$optimizableConstructorNames|)) - NIL) - ('T (SPADLET |dcval| (|optCallEval| |ndc|)) - (SPADLET |sig| - (MSUBST (|devaluate| |dcval|) |ndc| |sig|)) - (COND - ((CDR |ndc|) - (DO ((G167923 (CDR (|devaluate| |dcval|)) - (CDR G167923)) - (|new| NIL) - (G167924 (CDR |ndc|) (CDR G167924)) - (|old| NIL)) - ((OR (ATOM G167923) - (PROGN - (SETQ |new| (CAR G167923)) - NIL) - (ATOM G167924) - (PROGN - (SETQ |old| (CAR G167924)) - NIL)) - NIL) - (SEQ (EXIT (SPADLET |sig| - (MSUBST |new| |old| |sig|))))))) - (SPADLET |fn| (|compiledLookup| |op| |sig| |dcval|)) - (COND - ((NULL |fn|) - (SPADLET |nsig| - (PROG (G167937) - (SPADLET G167937 NIL) - (RETURN - (DO - ((G167942 |sig| (CDR G167942)) - (|tt| NIL)) - ((OR (ATOM G167942) - (PROGN - (SETQ |tt| (CAR G167942)) - NIL)) - (NREVERSE0 G167937)) - (SEQ - (EXIT - (SETQ G167937 - (CONS - (|optDeltaEntry,quoteSelector| - |tt|) - G167937)))))))) - (SPADLET |fn| - (|compiledLookup| |op| |nsig| |dcval|)) - (COND ((NULL |fn|) (RETURN NIL)) ('T NIL)))) - (COND - ((BOOT-EQUAL |eltOrConst| 'CONST) (|hehe| |fn|) - (CONS |op| NIL)) - ('T - (GETL (|compileTimeBindingOf| (CAR |fn|)) - '|SPADreplace|)))))))))))) - -;genDeltaEntry opMmPair == -;--called from compApplyModemap -;--$NRTdeltaLength=0.. always equals length of $NRTdeltaList -; [.,[odc,:.],.] := opMmPair -; --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) -; [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair -; if $profileCompiler = true then -; profileRecord(dc,op,sig) -;-- markImport dc -; eltOrConst = 'XLAM => cform -; if eltOrConst = 'Subsumed then eltOrConst := 'ELT -; -- following hack needed to invert Rep to $ substitution -; if odc = 'Rep and cform is [.,.,osig] then sig:=osig -; newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp -; setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => -; ['applyFun,['compiledLookupCheck,MKQ op, -; mkList consSig(sig,dc),consDomainForm(dc,nil)]] -; --if null atom dc then -; -- sig := substitute('$,dc,sig) -; -- cform := substitute('$,dc,cform) -; opModemapPair := -; [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T -; if null NRTassocIndex dc and dc ^= $NRTaddForm and -; (MEMBER(dc,$functorLocalParameters) or null atom dc) then -; --create "domain" entry to $NRTdeltaList -; $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] -; saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] -; $NRTdeltaLength := $NRTdeltaLength+1 -; compEntry:= -; dc -; RPLACA(saveNRTdeltaListComp,compEntry) -; chk(saveNRTdeltaListComp,102) -; u := -; [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == -; (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 -; --n + 1 since $NRTdeltaLength is 1 too large -; $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] -; $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] -; $NRTdeltaLength := $NRTdeltaLength+1 -; 0 -; u - -(DEFUN |genDeltaEntry| (|opMmPair|) - (PROG (|odc| |op| |dc| |cform| |eltOrConst| |ISTMP#1| |ISTMP#2| - |osig| |sig| |newimp| |opModemapPair| - |saveNRTdeltaListComp| |compEntry| |n| |u|) - (declare (special |$NRTdeltaLength| |$NRTdeltaListComp| |$NRTbase| - |$functorLocalParameters| |$NRTaddForm| - |$profileCompiler| |$NRTdeltaList|)) - (RETURN - (SEQ (PROGN - (SPADLET |odc| (CAADR |opMmPair|)) - (SPADLET |op| (CAR |opMmPair|)) - (SPADLET |dc| (CAADR |opMmPair|)) - (SPADLET |sig| (CDADR |opMmPair|)) - (SPADLET |cform| (CAR (CDADDR |opMmPair|))) - (SPADLET |eltOrConst| (CAAR (CDADDR |opMmPair|))) - (COND - ((BOOT-EQUAL |$profileCompiler| 'T) - (|profileRecord| |dc| |op| |sig|))) - (COND - ((BOOT-EQUAL |eltOrConst| 'XLAM) |cform|) - ('T - (COND - ((BOOT-EQUAL |eltOrConst| '|Subsumed|) - (SPADLET |eltOrConst| 'ELT))) - (COND - ((AND (BOOT-EQUAL |odc| '|Rep|) (PAIRP |cform|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cform|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |osig| - (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |sig| |osig|))) - (COND - ((SPADLET |newimp| - (|optDeltaEntry| |op| |sig| |dc| - |eltOrConst|)) - |newimp|) - ((NEQUAL (SETDIFFERENCE (|listOfBoundVars| |dc|) - |$functorLocalParameters|) - NIL) - (CONS '|applyFun| - (CONS (CONS '|compiledLookupCheck| - (CONS (MKQ |op|) - (CONS - (|mkList| - (|consSig| |sig| |dc|)) - (CONS - (|consDomainForm| |dc| NIL) - NIL)))) - NIL))) - ('T - (SPADLET |opModemapPair| - (CONS |op| - (CONS (CONS |dc| - (PROG (G167987) - (SPADLET G167987 NIL) - (RETURN - (DO - ((G167992 |sig| - (CDR G167992)) - (|x| NIL)) - ((OR (ATOM G167992) - (PROGN - (SETQ |x| - (CAR G167992)) - NIL)) - (NREVERSE0 G167987)) - (SEQ - (EXIT - (SETQ G167987 - (CONS - (|genDeltaSig| |x|) - G167987)))))))) - (CONS - (CONS 'T (CONS |cform| NIL)) - NIL)))) - (COND - ((AND (NULL (|NRTassocIndex| |dc|)) - (NEQUAL |dc| |$NRTaddForm|) - (OR (|member| |dc| - |$functorLocalParameters|) - (NULL (ATOM |dc|)))) - (SPADLET |$NRTdeltaList| - (CONS (CONS '|domain| - (CONS (|NRTaddInner| |dc|) |dc|)) - |$NRTdeltaList|)) - (SPADLET |saveNRTdeltaListComp| - (SPADLET |$NRTdeltaListComp| - (CONS NIL |$NRTdeltaListComp|))) - (SPADLET |$NRTdeltaLength| - (PLUS |$NRTdeltaLength| 1)) - (SPADLET |compEntry| |dc|) - (RPLACA |saveNRTdeltaListComp| |compEntry|) - (|chk| |saveNRTdeltaListComp| 102))) - (SPADLET |u| - (CONS |eltOrConst| - (CONS '$ - (CONS - (SPADDIFFERENCE - (PLUS |$NRTbase| - |$NRTdeltaLength|) - (COND - ((SPADLET |n| - (POSN1 |opModemapPair| - |$NRTdeltaList|)) - (PLUS |n| 1)) - ('T - (SPADLET |$NRTdeltaList| - (CONS |opModemapPair| - |$NRTdeltaList|)) - (SPADLET - |$NRTdeltaListComp| - (CONS NIL - |$NRTdeltaListComp|)) - (SPADLET |$NRTdeltaLength| - (PLUS |$NRTdeltaLength| - 1)) - 0))) - NIL)))) - |u|))))))))) - -;--====================================================================== -;-- From nruncomp.boot -;--====================================================================== -;parseIf t == -; t isnt [p,a,b] => t -; ifTran(parseTran p,parseTran a,parseTran b) where -; ifTran(p,a,b) == -; null($InteractiveMode) and p='true => a -; null($InteractiveMode) and p='false => b -; p is ['not,p'] => ifTran(p',b,a) -; p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) -; p is ['SEQ,:l,['exit,1,p']] => -; ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] -; --this assumes that l has no exits -; a is ['IF, =p,a',.] => ['IF,p,a',b] -; b is ['IF, =p,.,b'] => ['IF,p,a,b'] -; ['IF,p,a,b] - -;;; *** |parseIf,ifTran| REDEFINED - -(DEFUN |parseIf,ifTran| (|p| |a| |b|) - (PROG (|ISTMP#4| |ISTMP#5| |p'| |l| |a'| |ISTMP#1| |ISTMP#2| - |ISTMP#3| |b'|) - (declare (special |$InteractiveMode|)) - (RETURN - (SEQ (IF (AND (NULL |$InteractiveMode|) (BOOT-EQUAL |p| '|true|)) - (EXIT |a|)) - (IF (AND (NULL |$InteractiveMode|) - (BOOT-EQUAL |p| '|false|)) - (EXIT |b|)) - (IF (AND (PAIRP |p|) (EQ (QCAR |p|) '|not|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |p|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |p'| (QCAR |ISTMP#1|)) 'T)))) - (EXIT (|parseIf,ifTran| |p'| |b| |a|))) - (IF (AND (PAIRP |p|) (EQ (QCAR |p|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |p|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p'| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a'| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |b'| (QCAR |ISTMP#3|)) - 'T)))))))) - (EXIT (|parseIf,ifTran| |p'| - (|parseIf,ifTran| |a'| (COPY |a|) (COPY |b|)) - (|parseIf,ifTran| |b'| |a| |b|)))) - (IF (AND (PAIRP |p|) (EQ (QCAR |p|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |p|)) - (AND (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (REVERSE |ISTMP#1|)) - 'T)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) '|exit|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQUAL (QCAR |ISTMP#4|) 1) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |p'| - (QCAR |ISTMP#5|)) - 'T))))))) - (PROGN - (SPADLET |l| (QCDR |ISTMP#2|)) - 'T)) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) - (EXIT (CONS 'SEQ - (APPEND |l| - (CONS - (CONS '|exit| - (CONS 1 - (CONS - (|parseIf,ifTran| |p'| - (|incExitLevel| |a|) - (|incExitLevel| |b|)) - NIL))) - NIL))))) - (IF (AND (PAIRP |a|) (EQ (QCAR |a|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |p|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a'| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL)))))))) - (EXIT (CONS 'IF (CONS |p| (CONS |a'| (CONS |b| NIL)))))) - (IF (AND (PAIRP |b|) (EQ (QCAR |b|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |p|) - (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 |b'| (QCAR |ISTMP#3|)) - 'T)))))))) - (EXIT (CONS 'IF (CONS |p| (CONS |a| (CONS |b'| NIL)))))) - (EXIT (CONS 'IF (CONS |p| (CONS |a| (CONS |b| NIL))))))))) - -;;; *** |parseIf| REDEFINED - -(DEFUN |parseIf| (|t|) - (PROG (|p| |ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (COND - ((NULL (AND (PAIRP |t|) - (PROGN - (SPADLET |p| (QCAR |t|)) - (SPADLET |ISTMP#1| (QCDR |t|)) - (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))))))) - |t|) - ('T - (|parseIf,ifTran| (|parseTran| |p|) (|parseTran| |a|) - (|parseTran| |b|))))))) - -;--====================================================================== -;-- From parse.boot -;--====================================================================== -;parseNot u == ['not,parseTran first u] - -;;; *** |parseNot| REDEFINED - -(DEFUN |parseNot| (|u|) - (CONS '|not| (CONS (|parseTran| (CAR |u|)) NIL))) - -;--====================================================================== -;-- From g-cndata.boot -;--====================================================================== -;mkUserConstructorAbbreviation(c,a,type) == -; if $AnalyzeOnly or $convert2NewCompiler then -; $abbreviationStack := [[type,a,:c],:$abbreviationStack] -; if not atom c then c:= CAR c -- Existing constructors will be wrapped -; constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) -; clearClams() -; clearConstructorCache(c) -; installConstructor(c,type) -; setAutoLoadProperty(c) - -(DEFUN |mkUserConstructorAbbreviation| (|c| |a| |type|) - (declare (special |$abbreviationStack| |$AnalyzeOnly| |$convert2NewCompiler|)) - (PROGN - (COND - ((OR |$AnalyzeOnly| |$convert2NewCompiler|) - (SPADLET |$abbreviationStack| - (CONS (CONS |type| (CONS |a| |c|)) - |$abbreviationStack|)))) - (COND ((NULL (ATOM |c|)) (SPADLET |c| (CAR |c|)))) - (|constructorAbbreviationErrorCheck| |c| |a| |type| - '|abbreviationError|) - (|clearClams|) - (|clearConstructorCache| |c|) - (|installConstructor| |c| |type|) - (|setAutoLoadProperty| |c|))) - -;--====================================================================== -;-- From iterator.boot -;--====================================================================== -;compreduce(form is [.,op,x],m,e) == -; T := compForm(form,m,e) or return nil -; y := T.expr -; RPLACA(y,"REDUCE") -; ------------------<== distinquish this as the special reduce form -; (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and -; # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) -; T - -(DEFUN |compreduce| (|form| |m| |e|) - (PROG (|op| |x| T$ |y| |id| |u|) - (RETURN - (PROGN - (SPADLET |op| (CADR |form|)) - (SPADLET |x| (CADDR |form|)) - (SPADLET T$ (OR (|compForm| |form| |m| |e|) (RETURN NIL))) - (SPADLET |y| (CAR T$)) - (RPLACA |y| 'REDUCE) - (COND - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'REDUCE) - (SPADLET |id| (|getIdentity| |op| |e|)) - (SPADLET |u| (|comp0| |id| |m| |e|)) - (> (|#| (|getNumberTypesInScope|)) 1)) - (|markSimpleReduce| - (APPEND |y| - (CONS (CONS '@ (CONS (CAR |u|) (CONS |m| NIL))) - NIL)) - T$)) - ('T T$)))))) - -;compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == -;-------------------------------> 11/28 all new to preserve collect forms -; markImport m -; [collectOp,:itl,body]:= collectForm -; $e:= e -; itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] -; itl="failed" => return nil -; e:= $e -; T0 := comp0(body,m,e) or return nil -; md := T0.mode -; T1 := compOrCroak(collectForm,["List",md],e) -; T := [["REDUCE",op,nil,T1.expr],md,T1.env] -; markReduce(form,T) - -(DEFUN |compReduce1| (|form| |m| |e| |$formalArgList|) - (DECLARE (SPECIAL |$formalArgList|)) - (PROG (|op| |collectForm| |collectOp| |body| |LETTMP#1| |itl| T0 |md| - T1 T$) - (declare (special |$e|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |form|) 'REDUCE) (CAR |form|))) - (SPADLET |op| (CADR |form|)) - (SPADLET |collectForm| (CADDDR |form|)) - (|markImport| |m|) - (SPADLET |collectOp| (CAR |collectForm|)) - (SPADLET |LETTMP#1| (REVERSE (CDR |collectForm|))) - (SPADLET |body| (CAR |LETTMP#1|)) - (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) - (SPADLET |$e| |e|) - (SPADLET |itl| - (PROG (G168260) - (SPADLET G168260 NIL) - (RETURN - (DO ((G168268 |itl| (CDR G168268)) - (|x| NIL)) - ((OR (ATOM G168268) - (PROGN - (SETQ |x| (CAR G168268)) - NIL)) - (NREVERSE0 G168260)) - (SEQ (EXIT (SETQ G168260 - (CONS - (ELT - (PROGN - (SPADLET |LETTMP#1| - (OR - (|compIterator| |x| |$e|) - (RETURN '|failed|))) - (SPADLET |$e| - (CADR |LETTMP#1|)) - |LETTMP#1|) - 0) - G168260)))))))) - (COND - ((BOOT-EQUAL |itl| '|failed|) (RETURN NIL)) - ('T (SPADLET |e| |$e|) - (SPADLET T0 (OR (|comp0| |body| |m| |e|) (RETURN NIL))) - (SPADLET |md| (CADR T0)) - (SPADLET T1 - (|compOrCroak| |collectForm| - (CONS '|List| (CONS |md| NIL)) |e|)) - (SPADLET T$ - (CONS (CONS 'REDUCE - (CONS |op| - (CONS NIL (CONS (CAR T1) NIL)))) - (CONS |md| (CONS (CADDR T1) NIL)))) - (|markReduce| |form| T$)))))))) - -;compIterator(it,e) == -; it is ["IN",x,y] => -; --these two lines must be in this order, to get "for f in list f" -; --to give an error message if f is undefined -; ---------------> new <--------------------- -; [y',m,e] := markInValue(y, e) -; x := markKillAll x -; ------------------ -; $formalArgList:= [x,:$formalArgList] -; [.,mUnder]:= -; modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return -; stackMessage ["mode: ",m," must be a list or vector of some mode"] -; if null get(x,"mode",e) then [.,.,e]:= -; compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil -; e:= put(x,"value",[genSomeVariable(),mUnder,e],e) -; markReduceIn(it, [["IN",x,y'],e]) -; it is ["ON",x,y] => -;---------------> new <--------------------- -; x := markKillAll x -; ------------------ -; $formalArgList:= [x,:$formalArgList] -; y := markKillAll y -; markImport m -;---------------> new <--------------------- -; [y',m,e]:= comp(y,$EmptyMode,e) or return nil -; [.,mUnder]:= -; modeIsAggregateOf("List",m,e) or return -; stackMessage ["mode: ",m," must be a list of other modes"] -; if null get(x,"mode",e) then [.,.,e]:= -; compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil -; e:= put(x,"value",[genSomeVariable(),m,e],e) -; [["ON",x,y'],e] -; it is ["STEP",oindex,start,inc,:optFinal] => -; index := markKillAll oindex -; $formalArgList:= [index,:$formalArgList] -; --if all start/inc/end compile as small integers, then loop -; --is compiled as a small integer loop -; final':= nil -;---------------> new <--------------------- -; u := smallIntegerStep(it,index,start,inc,optFinal,e) => u -;---------------> new <--------------------- -; [start,.,e]:= -; comp(markKillAll start,$Integer,e) or return -; stackMessage ["start value of index: ",start," must be an integer"] -; [inc,.,e]:= -; comp(markKillAll inc,$Integer,e) or return -; stackMessage ["index increment:",inc," must be an integer"] -; if optFinal is [final] then -; [final,.,e]:= -; comp(markKillAll final,$Integer,e) or return -; stackMessage ["final value of index: ",final," must be an integer"] -; optFinal:= [final] -; indexmode:= -; comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger -; $Integer -;-- markImport ['Segment,indexmode] -; if null get(index,"mode",e) then [.,.,e]:= -; compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil -; e:= put(index,"value",[genSomeVariable(),indexmode,e],e) -; markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) -; it is ["WHILE",p] => -; [p',m,e]:= -; comp(p,$Boolean,e) or return -; stackMessage ["WHILE operand: ",p," is not Boolean valued"] -; markReduceWhile(it, [["WHILE",p'],e]) -; it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) -; it is ["|",x] => -; u:= -; comp(x,$Boolean,e) or return -; stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] -; markReduceSuchthat(it, [["|",u.expr],u.env]) -; nil - -(DEFUN |compIterator| (|it| |e|) - (PROG (|y| |y'| |mUnder| |oindex| |ISTMP#2| |ISTMP#3| |index| - |final'| |start| |inc| |final| |optFinal| |indexmode| - |LETTMP#1| |p'| |m| |p| |ISTMP#1| |x| |u|) - (declare (special |$Boolean| |$until| |$EmptyMode| |$Integer| - |$NonNegativeInteger| |$formalArgList|)) - (RETURN - (COND - ((AND (PAIRP |it|) (EQ (QCAR |it|) 'IN) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (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| (|markInValue| |y| |e|)) - (SPADLET |y'| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (SPADLET |x| (|markKillAll| |x|)) - (SPADLET |$formalArgList| (CONS |x| |$formalArgList|)) - (SPADLET |LETTMP#1| - (OR (|modeIsAggregateOf| '|List| |m| |e|) - (|modeIsAggregateOf| '|Vector| |m| |e|) - (RETURN - (|stackMessage| - (CONS '|mode: | - (CONS |m| - (CONS - '| must be a list or vector of some mode| - NIL))))))) - (SPADLET |mUnder| (CADR |LETTMP#1|)) - (COND - ((NULL (|get| |x| '|mode| |e|)) - (SPADLET |LETTMP#1| - (OR (|compMakeDeclaration| - (CONS '|:| (CONS |x| (CONS |mUnder| NIL))) - |$EmptyMode| |e|) - (RETURN NIL))) - (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) - (SPADLET |e| - (|put| |x| '|value| - (CONS (|genSomeVariable|) - (CONS |mUnder| (CONS |e| NIL))) - |e|)) - (|markReduceIn| |it| - (CONS (CONS 'IN (CONS |x| (CONS |y'| NIL))) - (CONS |e| NIL)))) - ((AND (PAIRP |it|) (EQ (QCAR |it|) 'ON) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (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 |x| (|markKillAll| |x|)) - (SPADLET |$formalArgList| (CONS |x| |$formalArgList|)) - (SPADLET |y| (|markKillAll| |y|)) (|markImport| |m|) - (SPADLET |LETTMP#1| - (OR (|comp| |y| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |y'| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (SPADLET |LETTMP#1| - (OR (|modeIsAggregateOf| '|List| |m| |e|) - (RETURN - (|stackMessage| - (CONS '|mode: | - (CONS |m| - (CONS - '| must be a list of other modes| - NIL))))))) - (SPADLET |mUnder| (CADR |LETTMP#1|)) - (COND - ((NULL (|get| |x| '|mode| |e|)) - (SPADLET |LETTMP#1| - (OR (|compMakeDeclaration| - (CONS '|:| (CONS |x| (CONS |m| NIL))) - |$EmptyMode| |e|) - (RETURN NIL))) - (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) - (SPADLET |e| - (|put| |x| '|value| - (CONS (|genSomeVariable|) - (CONS |m| (CONS |e| NIL))) - |e|)) - (CONS (CONS 'ON (CONS |x| (CONS |y'| NIL))) (CONS |e| NIL))) - ((AND (PAIRP |it|) (EQ (QCAR |it|) 'STEP) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |oindex| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |start| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |inc| (QCAR |ISTMP#3|)) - (SPADLET |optFinal| - (QCDR |ISTMP#3|)) - 'T)))))))) - (SPADLET |index| (|markKillAll| |oindex|)) - (SPADLET |$formalArgList| (CONS |index| |$formalArgList|)) - (SPADLET |final'| NIL) - (COND - ((SPADLET |u| - (|smallIntegerStep| |it| |index| |start| |inc| - |optFinal| |e|)) - |u|) - ('T - (SPADLET |LETTMP#1| - (OR (|comp| (|markKillAll| |start|) |$Integer| - |e|) - (RETURN - (|stackMessage| - (CONS '|start value of index: | - (CONS |start| - (CONS '| must be an integer| NIL))))))) - (SPADLET |start| (CAR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (SPADLET |LETTMP#1| - (OR (|comp| (|markKillAll| |inc|) |$Integer| |e|) - (RETURN - (|stackMessage| - (CONS '|index increment:| - (CONS |inc| - (CONS '| must be an integer| NIL))))))) - (SPADLET |inc| (CAR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((AND (PAIRP |optFinal|) (EQ (QCDR |optFinal|) NIL) - (PROGN (SPADLET |final| (QCAR |optFinal|)) 'T)) - (SPADLET |LETTMP#1| - (OR (|comp| (|markKillAll| |final|) |$Integer| - |e|) - (RETURN - (|stackMessage| - (CONS '|final value of index: | - (CONS |final| - (CONS '| must be an integer| - NIL))))))) - (SPADLET |final| (CAR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (SPADLET |optFinal| (CONS |final| NIL)))) - (SPADLET |indexmode| - (COND - ((|comp| (CADDR |it|) |$NonNegativeInteger| |e|) - |$NonNegativeInteger|) - ('T |$Integer|))) - (COND - ((NULL (|get| |index| '|mode| |e|)) - (SPADLET |LETTMP#1| - (OR (|compMakeDeclaration| - (CONS '|:| - (CONS |index| - (CONS |indexmode| NIL))) - |$EmptyMode| |e|) - (RETURN NIL))) - (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) - (SPADLET |e| - (|put| |index| '|value| - (CONS (|genSomeVariable|) - (CONS |indexmode| (CONS |e| NIL))) - |e|)) - (|markReduceStep| |it| - (CONS (CONS 'STEP - (CONS (|markStep| |index|) - (CONS |start| - (CONS |inc| |optFinal|)))) - (CONS |e| NIL)))))) - ((AND (PAIRP |it|) (EQ (QCAR |it|) 'WHILE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) - (SPADLET |LETTMP#1| - (OR (|comp| |p| |$Boolean| |e|) - (RETURN - (|stackMessage| - (CONS '|WHILE operand: | - (CONS |p| - (CONS '| is not Boolean valued| - NIL))))))) - (SPADLET |p'| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (|markReduceWhile| |it| - (CONS (CONS 'WHILE (CONS |p'| NIL)) (CONS |e| NIL)))) - ((AND (PAIRP |it|) (EQ (QCAR |it|) 'UNTIL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) - (|markReduceUntil| |it| - (PROGN - (SPADLET |$until| |p|) - (CONS '|$until| (CONS |e| NIL))))) - ((AND (PAIRP |it|) (EQ (QCAR |it|) '|\||) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) 'T)))) - (SPADLET |u| - (OR (|comp| |x| |$Boolean| |e|) - (RETURN - (|stackMessage| - (CONS '|SUCHTHAT operand: | - (CONS |x| - (CONS '| is not Boolean value| - NIL))))))) - (|markReduceSuchthat| |it| - (CONS (CONS '|\|| (CONS (CAR |u|) NIL)) - (CONS (CADDR |u|) NIL)))) - ('T NIL))))) - -;smallIntegerStep(it,index,start,inc,optFinal,e) == -; start := markKillAll start -; inc := markKillAll inc -; optFinal := markKillAll optFinal -; startNum := source2Number start -; incNum := source2Number inc -; mode := get(index,"mode",e) -;--fail if -;----> a) index has a mode that is not $SmallInteger -;----> b) one of start,inc, final won't comp as a $SmallInteger -; mode and mode ^= $SmallInteger => nil -; null (start':= comp(start,$SmallInteger,e)) => nil -; null (inc':= comp(inc,$SmallInteger,start'.env)) => nil -; if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then -;-- not (FIXP startNum and FIXP incNum) => return nil -;-- null FIXP startNum or ABSVAL startNum > 100 => return nil -; -----> assume that optFinal is $SmallInteger -; T := comp(final,$EmptyMode,inc'.env) or return nil -; final' := T -; maxSuperType(T.mode,e) ^= $Integer => return nil -; givenRange := T.mode -; indexmode:= $SmallInteger -; [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, -; (final' => final'.env; inc'.env)) or return nil -; range := -; FIXP startNum and FIXP incNum => -; startNum > 0 and incNum > 0 => $PositiveInteger -; startNum < 0 and incNum < 0 => $NegativeInteger -; incNum > 0 => $NonNegativeInteger --startNum = 0 -; $NonPositiveInteger -; givenRange => givenRange -; nil -; e:= put(index,"range",range,e) -; e:= put(index,"value",[genSomeVariable(),indexmode,e],e) -; noptFinal := -; final' => -; [final'.expr] -; nil -; [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] - -(DEFUN |smallIntegerStep| (|it| |index| |start| |inc| |optFinal| |e|) - (PROG (|startNum| |incNum| |mode| |start'| |inc'| |final| T$ |final'| - |givenRange| |indexmode| |LETTMP#1| |range| |noptFinal|) - (declare (special |$NonPositiveInteger| |$PositiveInteger| |$EmptyMode| - |$SmallInteger| |$Integer|)) - (RETURN - (PROGN - (SPADLET |start| (|markKillAll| |start|)) - (SPADLET |inc| (|markKillAll| |inc|)) - (SPADLET |optFinal| (|markKillAll| |optFinal|)) - (SPADLET |startNum| (|source2Number| |start|)) - (SPADLET |incNum| (|source2Number| |inc|)) - (SPADLET |mode| (|get| |index| '|mode| |e|)) - (COND - ((AND |mode| (NEQUAL |mode| |$SmallInteger|)) NIL) - ((NULL (SPADLET |start'| - (|comp| |start| |$SmallInteger| |e|))) - NIL) - ((NULL (SPADLET |inc'| - (|comp| |inc| |$SmallInteger| - (CADDR |start'|)))) - NIL) - ('T - (COND - ((AND (PAIRP |optFinal|) (EQ (QCDR |optFinal|) NIL) - (PROGN (SPADLET |final| (QCAR |optFinal|)) 'T) - (NULL (SPADLET |final'| - (|comp| |final| |$SmallInteger| - (CADDR |inc'|))))) - (SPADLET T$ - (OR (|comp| |final| |$EmptyMode| (CADDR |inc'|)) - (RETURN NIL))) - (SPADLET |final'| T$) - (COND - ((NEQUAL (|maxSuperType| (CADR T$) |e|) |$Integer|) - (RETURN NIL)) - ('T (SPADLET |givenRange| (CADR T$)))))) - (SPADLET |indexmode| |$SmallInteger|) - (SPADLET |LETTMP#1| - (OR (|compMakeDeclaration| - (CONS '|:| - (CONS |index| (CONS |indexmode| NIL))) - |$EmptyMode| - (COND - (|final'| (CADDR |final'|)) - ('T (CADDR |inc'|)))) - (RETURN NIL))) - (SPADLET |e| (CADDR |LETTMP#1|)) - (SPADLET |range| - (COND - ((AND (integerp |startNum|) (integerp |incNum|)) - (COND - ((AND (> |startNum| 0) (> |incNum| 0)) - |$PositiveInteger|) - ((AND (MINUSP |startNum|) (MINUSP |incNum|)) - |$NegativeInteger|) - ((> |incNum| 0) |$NonNegativeInteger|) - ('T |$NonPositiveInteger|))) - (|givenRange| |givenRange|) - ('T NIL))) - (SPADLET |e| (|put| |index| '|range| |range| |e|)) - (SPADLET |e| - (|put| |index| '|value| - (CONS (|genSomeVariable|) - (CONS |indexmode| (CONS |e| NIL))) - |e|)) - (SPADLET |noptFinal| - (COND - (|final'| (CONS (CAR |final'|) NIL)) - ('T NIL))) - (CONS (|markStepSI| |it| - (CONS 'ISTEP - (CONS |index| - (CONS (CAR |start'|) - (CONS (CAR |inc'|) |noptFinal|))))) - (CONS |e| NIL)))))))) - -;source2Number n == -; n := markKillAll n -; n = $Zero => 0 -; n = $One => 1 -; n - -(DEFUN |source2Number| (|n|) - (declare (special |$Zero| |$One|)) - (PROGN - (SPADLET |n| (|markKillAll| |n|)) - (COND - ((BOOT-EQUAL |n| |$Zero|) 0) - ((BOOT-EQUAL |n| |$One|) 1) - ('T |n|)))) - -;compRepeatOrCollect(form,m,e) == -; fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList -; ,e) where -; fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == -; $until: local -; [repeatOrCollect,:itl,body]:= form -; itl':= -; [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] -; itl'="failed" => nil -; targetMode:= first $exitModeStack -;-- pp '"---------" -;-- pp targetMode -; bodyMode:= -; repeatOrCollect="COLLECT" => -; targetMode = '$EmptyMode => '$EmptyMode -; (u:=modeIsAggregateOf('List,targetMode,e)) => -; CADR u -; (u:=modeIsAggregateOf('Vector,targetMode,e)) => -; repeatOrCollect:='COLLECTV -; CADR u -; stackMessage('"Invalid collect bodytype") -; return nil -; -- If we're doing a collect, and the type isn't conformable -; -- then we've boobed. JHD 26.July.1990 -; $NoValueMode -; [body',m',e']:= T := -; -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or -; compOrCroak(body,bodyMode,e) or return nil -; markRepeatBody(body, T) -; if $until then -; [untilCode,.,e']:= comp($until,$Boolean,e') -; itl':= substitute(["UNTIL",untilCode],'$until,itl') -; form':= [repeatOrCollect,:itl',body'] -; m'':= -; repeatOrCollect="COLLECT" => -; (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u -; ["List",m'] -; repeatOrCollect="COLLECTV" => -; (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u -; ["Vector",m'] -; m' -;--------> new <-------------- -; markImport m'' -;--------> new <-------------- -; markRepeat(form,coerceExit([form',m'',e'],targetMode)) - -(DEFUN |compRepeatOrCollect,fn| - (|form| |$exitModeStack| |$leaveLevelStack| |$formalArgList| - |e|) - (DECLARE (SPECIAL |$exitModeStack| |$leaveLevelStack| - |$formalArgList|)) - (PROG (|$until| |body| |itl| |x'| |targetMode| |repeatOrCollect| - |bodyMode| T$ |body'| |m'| |LETTMP#1| |untilCode| |e'| - |itl'| |form'| |u| |m''|) - (DECLARE (SPECIAL |$until| |$Boolean| |$NoValueMode|)) - (RETURN - (SEQ (SPADLET |$until| NIL) - (PROGN - (SPADLET |repeatOrCollect| (CAR |form|)) - (SPADLET |LETTMP#1| (REVERSE (CDR |form|))) - (SPADLET |body| (CAR |LETTMP#1|)) - (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) - |form|) - (SPADLET |itl'| - (PROG (G168618) - (SPADLET G168618 NIL) - (RETURN - (DO ((G168627 |itl| (CDR G168627)) - (|x| NIL)) - ((OR (ATOM G168627) - (PROGN - (SETQ |x| (CAR G168627)) - NIL)) - (NREVERSE0 G168618)) - (SEQ (EXIT (SETQ G168618 - (CONS - (SEQ - (PROGN - (SPADLET |LETTMP#1| - (OR (|compIterator| |x| |e|) - (RETURN '|failed|))) - (SPADLET |x'| - (CAR |LETTMP#1|)) - (SPADLET |e| - (CADR |LETTMP#1|)) - |LETTMP#1|) - (EXIT |x'|)) - G168618)))))))) - (IF (BOOT-EQUAL |itl'| '|failed|) (EXIT NIL)) - (SPADLET |targetMode| (CAR |$exitModeStack|)) - (SPADLET |bodyMode| - (SEQ (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECT) - (EXIT (SEQ - (IF - (BOOT-EQUAL |targetMode| - '|$EmptyMode|) - (EXIT '|$EmptyMode|)) - (IF - (SPADLET |u| - (|modeIsAggregateOf| '|List| - |targetMode| |e|)) - (EXIT (CADR |u|))) - (IF - (SPADLET |u| - (|modeIsAggregateOf| '|Vector| - |targetMode| |e|)) - (EXIT - (SEQ - (SPADLET |repeatOrCollect| - 'COLLECTV) - (EXIT (CADR |u|))))) - (|stackMessage| - "Invalid collect bodytype") - (EXIT (RETURN NIL))))) - (EXIT |$NoValueMode|))) - (PROGN - (SPADLET T$ - (OR (|compOrCroak| |body| |bodyMode| |e|) - (RETURN NIL))) - (SPADLET |body'| (CAR T$)) - (SPADLET |m'| (CADR T$)) - (SPADLET |e'| (CADDR T$)) - T$) - (|markRepeatBody| |body| T$) - (IF |$until| - (SEQ (PROGN - (SPADLET |LETTMP#1| - (|comp| |$until| |$Boolean| |e'|)) - (SPADLET |untilCode| (CAR |LETTMP#1|)) - (SPADLET |e'| (CADDR |LETTMP#1|)) - |LETTMP#1|) - (EXIT (SPADLET |itl'| - (MSUBST - (CONS 'UNTIL - (CONS |untilCode| NIL)) - '|$until| |itl'|)))) - NIL) - (SPADLET |form'| - (CONS |repeatOrCollect| - (APPEND |itl'| (CONS |body'| NIL)))) - (SPADLET |m''| - (SEQ (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECT) - (EXIT (SEQ - (IF - (SPADLET |u| - (|modeIsAggregateOf| '|List| - |targetMode| |e|)) - (EXIT (CAR |u|))) - (EXIT - (CONS '|List| (CONS |m'| NIL)))))) - (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECTV) - (EXIT (SEQ - (IF - (SPADLET |u| - (|modeIsAggregateOf| '|Vector| - |targetMode| |e|)) - (EXIT (CAR |u|))) - (EXIT - (CONS '|Vector| (CONS |m'| NIL)))))) - (EXIT |m'|))) - (|markImport| |m''|) - (EXIT (|markRepeat| |form| - (|coerceExit| - (CONS |form'| (CONS |m''| (CONS |e'| NIL))) - |targetMode|))))))) - -(DEFUN |compRepeatOrCollect| (|form| |m| |e|) - (declare (special |$exitModeStack| |$leaveLevelStack| |$formalArgList|)) - (|compRepeatOrCollect,fn| |form| (CONS |m| |$exitModeStack|) - (CONS (|#| |$exitModeStack|) |$leaveLevelStack|) |$formalArgList| - |e|)) - -;chaseInferences(origPred,$e) == -; pred := markKillAll origPred -; ----------------------------12/4/94 do this immediately -; foo hasToInfo pred where -; foo pred == -; knownInfo pred => nil -; $e:= actOnInfo(pred,$e) -; pred:= infoToHas pred -; for u in get("$Information","special",$e) repeat -; u is ["COND",:l] => -; for [ante,:conseq] in l repeat -; ante=pred => [foo w for w in conseq] -; ante is ["and",:ante'] and MEMBER(pred,ante') => -; ante':= DELETE(pred,ante') -; v':= -; LENGTH ante'=1 => first ante' -; ["and",:ante'] -; v':= ["COND",[v',:conseq]] -; MEMBER(v',get("$Information","special",$e)) => nil -; $e:= -; put("$Information","special",[v',: -; get("$Information","special",$e)],$e) -; nil -; $e - -(DEFUN |chaseInferences,foo| (|pred|) - (PROG (|l| |ante| |conseq| |ante'| |v'|) - (declare (special |$e| |$Information|)) - (RETURN - (SEQ (IF (|knownInfo| |pred|) (EXIT NIL)) - (SPADLET |$e| (|actOnInfo| |pred| |$e|)) - (SPADLET |pred| (|infoToHas| |pred|)) - (EXIT (DO ((G168688 - (|get| '|$Information| '|special| |$e|) - (CDR G168688)) - (|u| NIL)) - ((OR (ATOM G168688) - (PROGN (SETQ |u| (CAR G168688)) NIL)) - NIL) - (SEQ (EXIT (IF (AND (PAIRP |u|) - (EQ (QCAR |u|) 'COND) - (PROGN - (SPADLET |l| (QCDR |u|)) - 'T)) - (EXIT (DO - ((G168700 |l| - (CDR G168700)) - (G168673 NIL)) - ((OR (ATOM G168700) - (PROGN - (SETQ G168673 - (CAR G168700)) - NIL) - (PROGN - (PROGN - (SPADLET |ante| - (CAR G168673)) - (SPADLET |conseq| - (CDR G168673)) - G168673) - NIL)) - NIL) - (SEQ - (IF - (BOOT-EQUAL |ante| |pred|) - (EXIT - (PROG (G168711) - (SPADLET G168711 NIL) - (RETURN - (DO - ((G168716 |conseq| - (CDR G168716)) - (|w| NIL)) - ((OR (ATOM G168716) - (PROGN - (SETQ |w| - (CAR G168716)) - NIL)) - (NREVERSE0 - G168711)) - (SEQ - (EXIT - (SETQ G168711 - (CONS - (|chaseInferences,foo| - |w|) - G168711))))))))) - (IF - (AND - (AND (PAIRP |ante|) - (EQ (QCAR |ante|) '|and|) - (PROGN - (SPADLET |ante'| - (QCDR |ante|)) - 'T)) - (|member| |pred| |ante'|)) - (EXIT - (SEQ - (SPADLET |ante'| - (|delete| |pred| - |ante'|)) - (SPADLET |v'| - (SEQ - (IF - (EQL (LENGTH |ante'|) - 1) - (EXIT (CAR |ante'|))) - (EXIT - (CONS '|and| |ante'|)))) - (SPADLET |v'| - (CONS 'COND - (CONS - (CONS |v'| |conseq|) - NIL))) - (IF - (|member| |v'| - (|get| '|$Information| - '|special| |$e|)) - (EXIT NIL)) - (EXIT - (SPADLET |$e| - (|put| '|$Information| - '|special| - (CONS |v'| - (|get| - '|$Information| - '|special| |$e|)) - |$e|)))))) - (EXIT NIL))))))))))))) - -(DEFUN |chaseInferences| (|origPred| |$e|) - (DECLARE (SPECIAL |$e|)) - (PROG (|pred|) - (RETURN - (PROGN - (SPADLET |pred| (|markKillAll| |origPred|)) - (|chaseInferences,foo| (|hasToInfo| |pred|)) - |$e|)))) - -;--====================================================================== -;-- doit Code -;--====================================================================== -;doIt(item,$predl) == -; $GENNO: local:= 0 -; $coerceList: local := nil -; ---> -; if item is ['PART,.,a] then item := a -; ------------------------------------- -; item is ['SEQ,:.] => doItSeq item -; isDomainForm(item,$e) => doItDomain item -; item is ['LET,:.] => doItLet item -; item is [":",a,t] => [.,.,$e]:= -; markDeclaredImport markKillAll t -; compOrCroak(item,$EmptyMode,$e) -; item is ['import,:doms] => -; item := ['import,:(doms := markKillAll doms)] -; for dom in doms repeat -; sayBrightly ['" importing ",:formatUnabbreviated dom] -; [.,.,$e] := compOrCroak(item,$EmptyMode,$e) -; wiReplaceNode(item,'(PROGN),10) -; item is ["IF",:.] => doItIf(item,$predl,$e) -; item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) -; item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) -; item is ['DEF,:.] => doItDef item -; T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) -; true => cannotDo() - -(DEFUN |doIt| (|item| |$predl|) - (DECLARE (SPECIAL |$predl|)) - (PROG ($GENNO |$coerceList| |a| |ISTMP#2| |t| |doms| |ISTMP#1| |b| - |l| |LETTMP#1| T$) - (DECLARE (SPECIAL $GENNO |$coerceList| |$EmptyMode| |$e| |$coerceList|)) - (RETURN - (SEQ (PROGN - (SPADLET $GENNO 0) - (SPADLET |$coerceList| NIL) - (COND - ((AND (PAIRP |item|) (EQ (QCAR |item|) 'PART) - (PROGN - (SPADLET |ISTMP#1| (QCDR |item|)) - (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)))))) - (SPADLET |item| |a|))) - (COND - ((AND (PAIRP |item|) (EQ (QCAR |item|) 'SEQ)) - (|doItSeq| |item|)) - ((|isDomainForm| |item| |$e|) (|doItDomain| |item|)) - ((AND (PAIRP |item|) (EQ (QCAR |item|) 'LET)) - (|doItLet| |item|)) - ((AND (PAIRP |item|) (EQ (QCAR |item|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |item|)) - (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 |t| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |LETTMP#1| - (PROGN - (|markDeclaredImport| (|markKillAll| |t|)) - (|compOrCroak| |item| |$EmptyMode| |$e|))) - (SPADLET |$e| (CADDR |LETTMP#1|)) |LETTMP#1|) - ((AND (PAIRP |item|) (EQ (QCAR |item|) '|import|) - (PROGN (SPADLET |doms| (QCDR |item|)) 'T)) - (SPADLET |item| - (CONS '|import| - (SPADLET |doms| (|markKillAll| |doms|)))) - (DO ((G168798 |doms| (CDR G168798)) (|dom| NIL)) - ((OR (ATOM G168798) - (PROGN (SETQ |dom| (CAR G168798)) NIL)) - NIL) - (SEQ (EXIT (|sayBrightly| - (CONS " importing " - (|formatUnabbreviated| |dom|)))))) - (SPADLET |LETTMP#1| - (|compOrCroak| |item| |$EmptyMode| |$e|)) - (SPADLET |$e| (CADDR |LETTMP#1|)) - (|wiReplaceNode| |item| '(PROGN) 10)) - ((AND (PAIRP |item|) (EQ (QCAR |item|) 'IF)) - (|doItIf| |item| |$predl| |$e|)) - ((AND (PAIRP |item|) (EQ (QCAR |item|) '|where|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |item|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |l| (QCDR |ISTMP#1|)) - 'T)))) - (|compOrCroak| |item| |$EmptyMode| |$e|)) - ((AND (PAIRP |item|) (EQ (QCAR |item|) 'MDEF)) - (SPADLET |LETTMP#1| - (|compOrCroak| |item| |$EmptyMode| |$e|)) - (SPADLET |$e| (CADDR |LETTMP#1|)) |LETTMP#1|) - ((AND (PAIRP |item|) (EQ (QCAR |item|) 'DEF)) - (|doItDef| |item|)) - ((SPADLET T$ (|compOrCroak| |item| |$EmptyMode| |$e|)) - (|doItExpression| |item| T$)) - ('T (|cannotDo|)))))))) - -;holdIt item == item - -(DEFUN |holdIt| (|item|) |item|) - -;doItIf(item is [.,p,x,y],$predl,$e) == -; olde:= $e -; [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] -; oldFLP:=$functorLocalParameters -; if x^="noBranch" then -;--> new <----------------------- -; qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) -;---> new ----------- -; x':=localExtras(oldFLP) -; where localExtras(oldFLP) == -; EQ(oldFLP,$functorLocalParameters) => NIL -; flp1:=$functorLocalParameters -; oldFLP':=oldFLP -; n:=0 -; while oldFLP' repeat -; oldFLP':=CDR oldFLP' -; flp1:=CDR flp1 -; n:=n+1 -; -- Now we have to add code to compile all the elements -; -- of functorLocalParameters that were added during the -; -- conditional compilation -; nils:=ans:=[] -; for u in flp1 repeat -- is =u form always an ATOM? -; if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) -; then -; nils:=[u,:nils] -; else -; gv := GENSYM() -; ans:=[['LET,gv,u],:ans] -; nils:=[gv,:nils] -; n:=n+1 -; $functorLocalParameters:=[:oldFLP,:REVERSE nils] -; REVERSE ans -; oldFLP:=$functorLocalParameters -; if y^="noBranch" then -;--> new <----------------------- -; qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) -;--> ----------- -; y':=localExtras(oldFLP) -; wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) - -(DEFUN |doItIf,localExtras| (|oldFLP|) - (PROG (|oldFLP'| |flp1| |ISTMP#1| |gv| |ans| |nils| |n|) - (declare (special |$functorLocalParameters| |$getDomainCode|)) - (RETURN - (SEQ (IF (EQ |oldFLP| |$functorLocalParameters|) (EXIT NIL)) - (SPADLET |flp1| |$functorLocalParameters|) - (SPADLET |oldFLP'| |oldFLP|) (SPADLET |n| 0) - (DO () ((NULL |oldFLP'|) NIL) - (SEQ (SPADLET |oldFLP'| (CDR |oldFLP'|)) - (SPADLET |flp1| (CDR |flp1|)) - (EXIT (SPADLET |n| (PLUS |n| 1))))) - (SPADLET |nils| (SPADLET |ans| NIL)) - (DO ((G168862 |flp1| (CDR G168862)) (|u| NIL)) - ((OR (ATOM G168862) - (PROGN (SETQ |u| (CAR G168862)) NIL)) - NIL) - (SEQ (IF (OR (ATOM |u|) - (PROG (G168868) - (SPADLET G168868 NIL) - (RETURN - (DO ((G168876 NIL G168868) - (G168877 |$getDomainCode| - (CDR G168877)) - (|v| NIL)) - ((OR G168876 (ATOM G168877) - (PROGN - (SETQ |v| (CAR G168877)) - NIL)) - G168868) - (SEQ (EXIT - (SETQ G168868 - (OR G168868 - (AND (PAIRP |v|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |v|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) - |u|)))))))))))) - (SPADLET |nils| (CONS |u| |nils|)) - (SEQ (SPADLET |gv| (GENSYM)) - (SPADLET |ans| - (CONS - (CONS 'LET - (CONS |gv| (CONS |u| NIL))) - |ans|)) - (EXIT (SPADLET |nils| (CONS |gv| |nils|))))) - (EXIT (SPADLET |n| (PLUS |n| 1))))) - (SPADLET |$functorLocalParameters| - (APPEND |oldFLP| (REVERSE |nils|))) - (EXIT (REVERSE |ans|)))))) - -(DEFUN |doItIf| (|item| |$predl| |$e|) - (DECLARE (SPECIAL |$predl| |$e|)) - (PROG (|p| |x| |y| |olde| |LETTMP#1| |p'| |x'| |oldFLP| |y'|) - (declare (special |$functorLocalParameters| |$Boolean|)) - (RETURN - (PROGN - (SPADLET |p| (CADR |item|)) - (SPADLET |x| (CADDR |item|)) - (SPADLET |y| (CADDDR |item|)) - (SPADLET |olde| |$e|) - (SPADLET |LETTMP#1| - (OR (|qt| 19 (|comp| |p| |$Boolean| |$e|)) - (|userError| - (CONS "not a Boolean:" - (CONS |p| NIL))))) - (SPADLET |p'| (CAR |LETTMP#1|)) - (SPADLET |$e| (CADDR |LETTMP#1|)) - (SPADLET |oldFLP| |$functorLocalParameters|) - (COND - ((NEQUAL |x| '|noBranch|) - (|qe| 20 - (|compSingleCapsuleItem| |x| (CONS |p| |$predl|) - (|getSuccessEnvironment| (|markKillAll| |p|) |$e|))) - (SPADLET |x'| (|doItIf,localExtras| |oldFLP|)))) - (SPADLET |oldFLP| |$functorLocalParameters|) - (COND - ((NEQUAL |y| '|noBranch|) - (|qe| 21 - (|compSingleCapsuleItem| |y| - (CONS (CONS '|not| (CONS |p| NIL)) |$predl|) - (|getInverseEnvironment| (|markKillAll| |p|) - |olde|))) - (SPADLET |y'| (|doItIf,localExtras| |oldFLP|)))) - (|wiReplaceNode| |item| - (CONS 'COND - (CONS (CONS |p'| (CONS |x| |x'|)) - (CONS (CONS ''T (CONS |y| |y'|)) NIL))) - 12))))) - -;doItSeq item == -; ['SEQ,:l,['exit,1,x]] := item -; RPLACA(item,"PROGN") -; RPLACA(LASTNODE item,x) -; for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) - -(DEFUN |doItSeq| (|item|) - (PROG (|LETTMP#1| |x| |l|) - (declare (special |$e| |$predl|)) - (RETURN - (SEQ (PROGN - (SPADLET |LETTMP#1| (REVERSE (CDR |item|))) - (COND ((EQUAL (CADAR |LETTMP#1|) 1) (CADAR |LETTMP#1|))) - (SPADLET |x| (CADDAR |LETTMP#1|)) - (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) - (RPLACA |item| 'PROGN) - (RPLACA (LASTNODE |item|) |x|) - (DO ((G168945 (CDR |item|) (CDR G168945)) (|it1| NIL)) - ((OR (ATOM G168945) - (PROGN (SETQ |it1| (CAR G168945)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |$e| - (|compSingleCapsuleItem| |it1| - |$predl| |$e|)))))))))) - -;doItDomain item == -; -- convert naked top level domains to import -; u:= ['import, [first item,:rest item]] -; markImport CADR u -; stackWarning ["Use: import ", [first item,:rest item]] -;--wiReplaceNode(item, u, 14) -; RPLACA(item, first u) -; RPLACD(item, rest u) -; doIt(item,$predl) - -(DEFUN |doItDomain| (|item|) - (PROG (|u|) - (declare (special |$predl|)) - (RETURN - (PROGN - (SPADLET |u| - (CONS '|import| - (CONS (CONS (CAR |item|) (CDR |item|)) NIL))) - (|markImport| (CADR |u|)) - (|stackWarning| - (CONS '|Use: import | - (CONS (CONS (CAR |item|) (CDR |item|)) NIL))) - (RPLACA |item| (CAR |u|)) - (RPLACD |item| (CDR |u|)) - (|doIt| |item| |$predl|))))) - -;doItLet item == -; qe(3,$e) -; res := doItLet1 item -; qe(4,$e) -; res - -(DEFUN |doItLet| (|item|) - (PROG (|res|) - (declare (special |$e|)) - (RETURN - (PROGN - (|qe| 3 |$e|) - (SPADLET |res| (|doItLet1| |item|)) - (|qe| 4 |$e|) - |res|)))) - -;doItLet1 item == -; ['LET,lhs,rhs,:.] := item -; not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => -; stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) -; qe(5,$e) -; code := markKillAll code -; not (code is ['LET,lhs',rhs',:.] and atom lhs') => -; code is ["PROGN",:.] => -; stackSemanticError(["multiple assignment ",item," not allowed"],nil) -; wiReplaceNode(item, code, 24) -; lhs:= lhs' -; if not MEMBER(KAR rhs,$NonMentionableDomainNames) and -; not MEMQ(lhs, $functorLocalParameters) then -; $functorLocalParameters:= [:$functorLocalParameters,lhs] -; if (rhs' := rhsOfLetIsDomainForm code) then -; if isFunctor rhs' then -; $functorsUsed:= insert(opOf rhs',$functorsUsed) -; $packagesUsed:= insert([opOf rhs'],$packagesUsed) -; $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] -; if lhs="Rep" then -; $Representation:= (get("Rep",'value,$e)).(0) -; --$Representation bound by compDefineFunctor, used in compNoStacking -;--+ -; if $NRTopt = true -; then NRTgetLocalIndex $Representation -;--+ -; $LocalDomainAlist:= --see genDeltaEntry -; [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] -;--+ -; qe(6,$e) -; code is ['LET,:.] => -; rhsCode:= rhs' -; op := ($QuickCode => 'QSETREFV;'SETELT) -; wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) -; wiReplaceNode(item, code, 18) - -(DEFUN |doItLet1| (|item|) - (PROG (|rhs| |ISTMP#3| |code| |ISTMP#1| |lhs'| |ISTMP#2| |lhs| |rhs'| - |rhsCode| |op|) - (declare (special |$QuickCode| |$e| |$LocalDomainAlist| |$Representation| - |$NRTopt| |$globalImportDefAlist| |$packagesUsed| - |$functorsUsed| |$functorLocalParameters| |$EmptyMode| - |$NonMentionableDomainNames| )) - (RETURN - (PROGN - (SPADLET |lhs| (CADR |item|)) - (SPADLET |rhs| (CADDR |item|)) - (COND - ((NULL (PROGN - (SPADLET |ISTMP#1| - (|compOrCroak| |item| |$EmptyMode| |$e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |code| (QCAR |ISTMP#1|)) - (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 |$e| (QCAR |ISTMP#3|)) - 'T)))))))) - (|stackSemanticError| - (CONS '|cannot compile assigned value to| - (|bright| |lhs|)) - NIL)) - ('T (|qe| 5 |$e|) (SPADLET |code| (|markKillAll| |code|)) - (COND - ((NULL (AND (PAIRP |code|) (EQ (QCAR |code|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |code|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |lhs'| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |rhs'| - (QCAR |ISTMP#2|)) - 'T))))) - (ATOM |lhs'|))) - (COND - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'PROGN)) - (|stackSemanticError| - (CONS '|multiple assignment | - (CONS |item| (CONS '| not allowed| NIL))) - NIL)) - ('T (|wiReplaceNode| |item| |code| 24)))) - ('T (SPADLET |lhs| |lhs'|) - (COND - ((AND (NULL (|member| (KAR |rhs|) - |$NonMentionableDomainNames|)) - (NULL (MEMQ |lhs| |$functorLocalParameters|))) - (SPADLET |$functorLocalParameters| - (APPEND |$functorLocalParameters| - (CONS |lhs| NIL))))) - (COND - ((SPADLET |rhs'| (|rhsOfLetIsDomainForm| |code|)) - (COND - ((|isFunctor| |rhs'|) - (SPADLET |$functorsUsed| - (|insert| (|opOf| |rhs'|) |$functorsUsed|)) - (SPADLET |$packagesUsed| - (|insert| (CONS (|opOf| |rhs'|) NIL) - |$packagesUsed|)) - (SPADLET |$globalImportDefAlist| - (|pp| (CONS (CONS |lhs| |rhs'|) - |$globalImportDefAlist|))))) - (COND - ((BOOT-EQUAL |lhs| '|Rep|) - (SPADLET |$Representation| - (ELT (|get| '|Rep| '|value| |$e|) 0)) - (COND - ((BOOT-EQUAL |$NRTopt| 'T) - (|NRTgetLocalIndex| |$Representation|)) - ('T NIL)))) - (SPADLET |$LocalDomainAlist| - (CONS (CONS |lhs| - (SUBLIS |$LocalDomainAlist| - (ELT (|get| |lhs| '|value| |$e|) - 0))) - |$LocalDomainAlist|)))) - (|qe| 6 |$e|) - (COND - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'LET)) - (SPADLET |rhsCode| |rhs'|) - (SPADLET |op| - (COND (|$QuickCode| 'QSETREFV) ('T 'SETELT))) - (|wiReplaceNode| |item| - (CONS |op| - (CONS '$ - (CONS (|NRTgetLocalIndexClear| |lhs|) - (CONS |rhsCode| NIL)))) - 16)) - ('T (|wiReplaceNode| |item| |code| 18))))))))))) - -;rhsOfLetIsDomainForm code == -; code is ['LET,.,rhs',:.] => -; isDomainForm(rhs',$e) => rhs' -; isDomainForm(rhs' := markKillAll rhs',$e) => rhs' -; false -; false - -(DEFUN |rhsOfLetIsDomainForm| (|code|) - (PROG (|ISTMP#1| |ISTMP#2| |rhs'|) - (declare (special |$e|)) - (RETURN - (COND - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |code|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |rhs'| (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((|isDomainForm| |rhs'| |$e|) |rhs'|) - ((|isDomainForm| (SPADLET |rhs'| (|markKillAll| |rhs'|)) - |$e|) - |rhs'|) - ('T NIL))) - ('T NIL))))) - -;doItDef item == -; ['DEF,[op,:.],:.] := item -; body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) -; [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) -; chk(item,3) -; RPLACA(item,"CodeDefine") -; --Note that DescendCode, in CodeDefine, is looking for this -; RPLACD(CADR item,[$signatureOfForm]) -; chk(item,4) -; --This is how the signature is updated for buildFunctor to recognise -;--+ -; functionPart:= ['dispatchFunction,t.expr] -; wiReplaceNode(CDDR item,[functionPart], 20) -; chk(item, 30) - -(DEFUN |doItDef| (|item|) - (PROG (|op| |body| |t| |functionPart|) - (declare (special |$signatureOfForm| |$e|)) - (RETURN - (PROGN - (SPADLET |op| (CAADR |item|)) - (COND - ((SPADLET |body| (|isMacro| |item| |$e|)) - (SPADLET |$e| (|put| |op| '|macro| |body| |$e|))) - ('T (SPADLET |t| (|compOrCroak| |item| |$EmptyMode| |$e|)) - (SPADLET |$e| (CADDR |t|)) (|chk| |item| 3) - (RPLACA |item| '|CodeDefine|) - (RPLACD (CADR |item|) (CONS |$signatureOfForm| NIL)) - (|chk| |item| 4) - (SPADLET |functionPart| - (CONS '|dispatchFunction| (CONS (CAR |t|) NIL))) - (|wiReplaceNode| (CDDR |item|) (CONS |functionPart| NIL) 20) - (|chk| |item| 30))))))) - -;doItExpression(item,T) == -; SETQ($ITEM,COPY item) -; SETQ($T1,COPY T.expr) -; chk(T.expr, 304) -; u := markCapsuleExpression(item, T) -; [code,.,$e]:= u -; wiReplaceNode(item,code, 22) - -(DEFUN |doItExpression| (|item| T$) - (PROG (|u| |code|) - (declare (special |$e| $ITEM $T1)) - (RETURN - (PROGN - (SETQ $ITEM (COPY |item|)) - (SETQ $T1 (COPY (CAR T$))) - (|chk| (CAR T$) 304) - (SPADLET |u| (|markCapsuleExpression| |item| T$)) - (SPADLET |code| (CAR |u|)) - (SPADLET |$e| (CADDR |u|)) - (|wiReplaceNode| |item| |code| 22))))) - -;wiReplaceNode(node,ocode,key) == -; ncode := CONS(first ocode, rest ocode) -; code := replaceNodeInStructureBy(node,ncode) -; SETQ($NODE,COPY node) -; SETQ($NODE1, COPY first code) -; SETQ($NODE2, COPY rest code) -; RPLACA(node,first code) -; RPLACD(node,rest code) -; chk(code, key) -; chk(node, key + 1) - -(DEFUN |wiReplaceNode| (|node| |ocode| |key|) - (PROG (|ncode| |code|) - (declare (special $node $node1 $node2)) - (RETURN - (PROGN - (SPADLET |ncode| (CONS (CAR |ocode|) (CDR |ocode|))) - (SPADLET |code| (|replaceNodeInStructureBy| |node| |ncode|)) - (SETQ $NODE (COPY |node|)) - (SETQ $NODE1 (COPY (CAR |code|))) - (SETQ $NODE2 (COPY (CDR |code|))) - (RPLACA |node| (CAR |code|)) - (RPLACD |node| (CDR |code|)) - (|chk| |code| |key|) - (|chk| |node| (PLUS |key| 1)))))) - -;replaceNodeInStructureBy(node, x) == -; $nodeCopy: local := [CAR node,:CDR node] -; replaceNodeBy(node, x) -; node - -(DEFUN |replaceNodeInStructureBy| (|node| |x|) - (PROG (|$nodeCopy|) - (DECLARE (SPECIAL |$nodeCopy|)) - (RETURN - (PROGN - (SPADLET |$nodeCopy| (CONS (CAR |node|) (CDR |node|))) - (|replaceNodeBy| |node| |x|) - |node|)))) - -;replaceNodeBy(node, x) == -; atom x => nil -; for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) -; nil - -(DEFUN |replaceNodeBy| (|node| |x|) - (declare (special |$nodeCopy|)) - (SEQ (COND - ((ATOM |x|) NIL) - ('T - (DO ((|y| |x| (CDR |y|))) ((ATOM |y|) NIL) - (SEQ (EXIT (COND - ((EQCAR |x| |node|) - (RPLAC (CAR |x|) |$nodeCopy|)))))) - NIL)))) - -;chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == -; cnt > 10000 => -; sayBrightly ["--> ", key, " <---"] -; hahaha(key) -; atom x => cnt -; VECP x => systemError nil -; for y in x repeat cnt := fn(y, cnt + 1, key) -; cnt -; - -(DEFUN |chk,fn| (|x| |cnt| |key|) - (SEQ (IF (> |cnt| 10000) - (EXIT (SEQ (|sayBrightly| - (CONS "--> " - (CONS |key| - (CONS " <---" NIL)))) - (EXIT (|hahaha| |key|))))) - (IF (ATOM |x|) (EXIT |cnt|)) - (IF (VECP |x|) (EXIT (|systemError| NIL))) - (DO ((G169120 |x| (CDR G169120)) (|y| NIL)) - ((OR (ATOM G169120) - (PROGN (SETQ |y| (CAR G169120)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |cnt| (|chk,fn| |y| (PLUS |cnt| 1) |key|))))) - (EXIT |cnt|))) - -(DEFUN |chk| (|x| |key|) (|chk,fn| |x| 0 |key|)) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document}