diff --git a/changelog b/changelog index 2b2a93b..1e9f341 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +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 20100825 tpd src/axiom-website/patches.html 20100825.01.tpd.patch 20100825 tpd src/interp/Makefile remove ptrop.lisp 20100825 tpd books/bookvol5 merge ptrop diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index d4b8ae6..a4532b3 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3081,5 +3081,7 @@ src/axiom-website/download.html add opensuse for july2010
src/interp/varini.lisp removed, merged with bookvol5
20100825.01.tpd.patch src/interp/ptrop.lisp merged and removed
+20100826.01.tpd.patch +src/interp/wi1.lisp removed
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index d75c407..6f90422 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -236,8 +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} | <>= -TRANOBJS= ${AUTO}/wi1.${O} ${AUTO}/wi2.${O} ${AUTO}/pspad1.${O} \ +TRANOBJS= ${AUTO}/wi2.${O} ${AUTO}/pspad1.${O} \ ${AUTO}/pspad2.${O} ${AUTO}/mark.${O} ${AUTO}/nspadaux.${O} @ diff --git a/src/interp/wi1.lisp.pamphlet b/src/interp/wi1.lisp.pamphlet deleted file mode 100644 index 3b775b9..0000000 --- a/src/interp/wi1.lisp.pamphlet +++ /dev/null @@ -1,5628 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp wi1.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -<<*>>= -(IN-PACKAGE "BOOT" ) - -;-- !! do not delete the next function ! -;spad2AsTranslatorAutoloadOnceTrigger() == nil - -(DEFUN |spad2AsTranslatorAutoloadOnceTrigger| () NIL) - -;pairList(u,v) == [[x,:y] for x in u for y in v] - -;;; *** |pairList| REDEFINED - -(DEFUN |pairList| (|u| |v|) - (PROG () - (RETURN - (SEQ (PROG (G166065) - (SPADLET G166065 NIL) - (RETURN - (DO ((G166071 |u| (CDR G166071)) (|x| NIL) - (G166072 |v| (CDR G166072)) (|y| NIL)) - ((OR (ATOM G166071) - (PROGN (SETQ |x| (CAR G166071)) NIL) - (ATOM G166072) - (PROGN (SETQ |y| (CAR G166072)) NIL)) - (NREVERSE0 G166065)) - (SEQ (EXIT (SETQ G166065 - (CONS (CONS |x| |y|) G166065))))))))))) - -;--====================================================================== -;-- Temporary definitions---for tracing and debugging -;--====================================================================== -;tr fn == -; $convertingSpadFile : local := true -; $options: local := nil -; sfn := STRINGIMAGE fn -; newname := STRCONC(sfn,'".as") -; $outStream :local := MAKE_-OUTSTREAM newname -; markSay '"#pile" -; markSay('"#include _"axiom.as_"") -; markTerpri() -; CATCH("SPAD__READER",compiler [INTERN sfn]) -; SHUT $outStream - -;;; *** |tr| REDEFINED - -(DEFUN |tr| (|fn|) - (PROG (|$convertingSpadFile| |$options| |$outStream| |sfn| |newname|) - (DECLARE (SPECIAL |$convertingSpadFile| |$options| |$outStream|)) - (RETURN - (PROGN - (SPADLET |$convertingSpadFile| 'T) - (SPADLET |$options| NIL) - (SPADLET |sfn| (STRINGIMAGE |fn|)) - (SPADLET |newname| (STRCONC |sfn| ".as")) - (SPADLET |$outStream| (MAKE-OUTSTREAM |newname|)) - (|markSay| "#pile") - (|markSay| "#include \"axiom.as\"") - (|markTerpri|) - (CATCH 'SPAD_READER (|compiler| (CONS (INTERN |sfn|) NIL))) - (SHUT |$outStream|))))) - -;stackMessage msg == -;--if msg isnt ["cannot coerce: ",:.] then foobum msg -; $compErrorMessageStack:= [msg,:$compErrorMessageStack] -; nil - -;;; *** |stackMessage| REDEFINED - -(DEFUN |stackMessage| (|msg|) - (declare (special |$compErrorMessageStack|)) - (PROGN - (SPADLET |$compErrorMessageStack| - (CONS |msg| |$compErrorMessageStack|)) - NIL)) - -;ppFull x == -; _*PRINT_-LEVEL_* : local := nil -; _*PRINT_-DEPTH_* : local := nil -; _*PRINT_-LENGTH_* : local := nil -; pp x - -(DEFUN |ppFull| (|x|) - (PROG (*PRINT-LEVEL* *PRINT-DEPTH* *PRINT-LENGTH*) - (RETURN - (PROGN - (SPADLET *PRINT-LEVEL* NIL) - (SPADLET *PRINT-DEPTH* NIL) - (SPADLET *PRINT-LENGTH* NIL) - (|pp| |x|))))) - -;put(x,prop,val,e) == -;--if prop = 'mode and CONTAINED('PART,val) then foobar val -; $InteractiveMode and not EQ(e,$CategoryFrame) => -; putIntSymTab(x,prop,val,e) -; --e must never be $CapsuleModemapFrame -; null atom x => put(first x,prop,val,e) -; newProplist:= augProplistOf(x,prop,val,e) -; prop="modemap" and $insideCapsuleFunctionIfTrue=true => -; SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] -; $CapsuleModemapFrame:= -; addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), -; $CapsuleModemapFrame) -; e -; addBinding(x,newProplist,e) - -(DEFUN |put| (|x| |prop| |val| |e|) - (PROG (|newProplist|) - (declare (special |$InteractiveMode| |$CategoryFrame| - |$insideCapsuleFunctionIfTrue| |$CapsuleModemapFrame|)) - (RETURN - (COND - ((AND |$InteractiveMode| (NULL (EQ |e| |$CategoryFrame|))) - (|putIntSymTab| |x| |prop| |val| |e|)) - ((NULL (ATOM |x|)) (|put| (CAR |x|) |prop| |val| |e|)) - ('T - (SPADLET |newProplist| (|augProplistOf| |x| |prop| |val| |e|)) - (COND - ((AND (BOOT-EQUAL |prop| '|modemap|) - (BOOT-EQUAL |$insideCapsuleFunctionIfTrue| 'T)) - (SAY (CONS "**** modemap PUT on CapsuleModemapFrame: " - (CONS |val| NIL))) - (SPADLET |$CapsuleModemapFrame| - (|addBinding| |x| - (|augProplistOf| |x| '|modemap| |val| - |$CapsuleModemapFrame|) - |$CapsuleModemapFrame|)) - |e|) - ('T (|addBinding| |x| |newProplist| |e|)))))))) - -;--====================================================================== -;-- From define.boot -;--====================================================================== -;compJoin(["Join",:argl],m,e) == -; catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] -; catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) -; catList':= -; [extract for x in catList] where -; extract() == -; x := markKillAll x -; isCategoryForm(x,e) => -; parameters:= -; UNION("append"/[getParms(y,e) for y in rest x],parameters) -; where getParms(y,e) == -; atom y => -; isDomainForm(y,e) => LIST y -; nil -; y is ['LENGTH,y'] => [y,y'] -; LIST y -; x -; x is ["DomainSubstitutionMacro",pl,body] => -; (parameters:= UNION(pl,parameters); body) -; x is ["mkCategory",:.] => x -; atom x and getmode(x,e)=$Category => x -; stackSemanticError(["invalid argument to Join: ",x],nil) -; x -; T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] -; convert(T,m) - -(DEFUN |compJoin,getParms| (|y| |e|) - (PROG (|ISTMP#1| |y'|) - (RETURN - (SEQ (IF (ATOM |y|) - (EXIT (SEQ (IF (|isDomainForm| |y| |e|) - (EXIT (LIST |y|))) - (EXIT NIL)))) - (IF (AND (PAIRP |y|) (EQ (QCAR |y|) 'LENGTH) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |y'| (QCAR |ISTMP#1|)) 'T)))) - (EXIT (CONS |y| (CONS |y'| NIL)))) - (EXIT (LIST |y|)))))) - -(DEFUN |compJoin| (G166187 |m| |e|) - (PROG (|argl| |catList| |ISTMP#1| |pl| |ISTMP#2| |body| - |parameters| |catList'| T$) - (declare (special |$Category|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G166187) '|Join|) (CAR G166187))) - (SPADLET |argl| (CDR G166187)) - (SPADLET |catList| - (PROG (G166207) - (SPADLET G166207 NIL) - (RETURN - (DO ((G166212 |argl| (CDR G166212)) - (|x| NIL)) - ((OR (ATOM G166212) - (PROGN - (SETQ |x| (CAR G166212)) - NIL)) - (NREVERSE0 G166207)) - (SEQ (EXIT (SETQ G166207 - (CONS - (CAR - (OR - (|compForMode| |x| - |$Category| |e|) - (RETURN '|failed|))) - G166207)))))))) - (COND - ((BOOT-EQUAL |catList| '|failed|) - (|stackSemanticError| - (CONS '|cannot form Join of: | (CONS |argl| NIL)) - NIL)) - ('T - (SPADLET |catList'| - (PROG (G166231) - (SPADLET G166231 NIL) - (RETURN - (DO ((G166245 |catList| (CDR G166245)) - (|x| NIL)) - ((OR (ATOM G166245) - (PROGN - (SETQ |x| (CAR G166245)) - NIL)) - (NREVERSE0 G166231)) - (SEQ (EXIT - (SETQ G166231 - (CONS - (PROGN - (SPADLET |x| - (|markKillAll| |x|)) - (COND - ((|isCategoryForm| |x| |e|) - (SPADLET |parameters| - (|union| - (PROG (G166251) - (SPADLET G166251 NIL) - (RETURN - (DO - ((G166256 - (CDR |x|) - (CDR G166256)) - (|y| NIL)) - ((OR - (ATOM G166256) - (PROGN - (SETQ |y| - (CAR G166256)) - NIL)) - G166251) - (SEQ - (EXIT - (SETQ G166251 - (APPEND - G166251 - (|compJoin,getParms| - |y| |e|)))))))) - |parameters|)) - |x|) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) - '|DomainSubstitutionMacro|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pl| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |body| - (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |parameters| - (|union| |pl| - |parameters|)) - |body|) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) - '|mkCategory|)) - |x|) - ((AND (ATOM |x|) - (BOOT-EQUAL - (|getmode| |x| |e|) - |$Category|)) - |x|) - ('T - (|stackSemanticError| - (CONS - '|invalid argument to Join: | - (CONS |x| NIL)) - NIL) - |x|))) - G166231)))))))) - (SPADLET T$ - (CONS (|wrapDomainSub| |parameters| - (CONS '|Join| |catList'|)) - (CONS |$Category| (CONS |e| NIL)))) - (|convert| T$ |m|)))))))) - -;compDefineFunctor(dfOriginal,m,e,prefix,fal) == -; df := markInsertParts dfOriginal -; $domainShell: local -- holds the category of the object being compiled -; $profileCompiler: local := true -; $profileAlist: local := nil -; $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) -; compDefineFunctor1(df,m,e,prefix,fal) - -(DEFUN |compDefineFunctor| (|dfOriginal| |m| |e| |prefix| |fal|) - (PROG (|$domainShell| |$profileCompiler| |$profileAlist| |df|) - (DECLARE (SPECIAL |$domainShell| |$profileCompiler| - |$profileAlist|)) - (RETURN - (PROGN - (SPADLET |df| (|markInsertParts| |dfOriginal|)) - (SPADLET |$domainShell| NIL) - (SPADLET |$profileCompiler| 'T) - (SPADLET |$profileAlist| NIL) - (COND - ($LISPLIB - (|compDefineLisplib| |df| |m| |e| |prefix| |fal| - '|compDefineFunctor1|)) - ('T (|compDefineFunctor1| |df| |m| |e| |prefix| |fal|))))))) - -;compDefineLisplib(df,m,e,prefix,fal,fn) == -; ["DEF",[op,:.],:.] := df -; --fn= compDefineCategory OR compDefineFunctor -; sayMSG fillerSpaces(72,'"-") -; $LISPLIB: local := 'T -; $op: local := op -; $lisplibAttributes: local := NIL -; $lisplibPredicates: local := NIL -- set by makePredicateBitVector -; $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) -; $lisplibForm: local := NIL -; $lisplibKind: local := NIL -; $lisplibModemap: local := NIL -; $lisplibModemapAlist: local := NIL -; $lisplibSlot1 : local := NIL -- used by NRT mechanisms -; $lisplibOperationAlist: local := NIL -; $lisplibSuperDomain: local := NIL -; $libFile: local := NIL -; $lisplibVariableAlist: local := NIL -; $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc -; $lisplibCategory: local := nil -; --for categories, is rhs of definition; otherwise, is target of functor -; --will eventually become the "constructorCategory" property in lisplib -; --set in compDefineCategory if category, otherwise in finalizeLisplib -; libName := getConstructorAbbreviation op -; -- $incrementalLisplibFlag seems never to be set so next line not used -; -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) -; BOUNDP '$compileDocumentation and $compileDocumentation => -; compileDocumentation libName -; sayMSG ['" initializing ",$spadLibFT,:bright libName, -; '"for",:bright op] -; initializeLisplib libName -; sayMSG ['" compiling into ",$spadLibFT,:bright libName] -; res:= FUNCALL(fn,df,m,e,prefix,fal) -; sayMSG ['" finalizing ",$spadLibFT,:bright libName] -;--finalizeLisplib libName -; FRESH_-LINE $algebraOutputStream -; sayMSG fillerSpaces(72,'"-") -; unloadOneConstructor(op,libName) -; res - -(DEFUN |compDefineLisplib| (|df| |m| |e| |prefix| |fal| |fn|) - (PROG ($LISPLIB |$op| |$lisplibAttributes| |$lisplibPredicates| - |$lisplibCategoriesExtended| |$lisplibForm| |$lisplibKind| - |$lisplibModemap| |$lisplibModemapAlist| |$lisplibSlot1| - |$lisplibOperationAlist| |$lisplibSuperDomain| |$libFile| - |$lisplibVariableAlist| |$lisplibRelatedDomains| - |$lisplibCategory| |op| |libName| |res|) - (DECLARE (SPECIAL $LISPLIB |$op| |$lisplibAttributes| - |$lisplibPredicates| |$lisplibCategoriesExtended| - |$lisplibForm| |$lisplibKind| |$lisplibModemap| - |$lisplibModemapAlist| |$lisplibSlot1| - |$lisplibOperationAlist| |$lisplibSuperDomain| - |$libFile| |$lisplibVariableAlist| - |$compileDocumentation| - |$lisplibRelatedDomains| |$lisplibCategory|)) - (RETURN - (PROGN - (COND ((EQ (CAR |df|) 'DEF) (CAR |df|))) - (SPADLET |op| (CAADR |df|)) - (|sayMSG| (|fillerSpaces| 72 "-")) - (SPADLET $LISPLIB 'T) - (SPADLET |$op| |op|) - (SPADLET |$lisplibAttributes| NIL) - (SPADLET |$lisplibPredicates| NIL) - (SPADLET |$lisplibCategoriesExtended| NIL) - (SPADLET |$lisplibForm| NIL) - (SPADLET |$lisplibKind| NIL) - (SPADLET |$lisplibModemap| NIL) - (SPADLET |$lisplibModemapAlist| NIL) - (SPADLET |$lisplibSlot1| NIL) - (SPADLET |$lisplibOperationAlist| NIL) - (SPADLET |$lisplibSuperDomain| NIL) - (SPADLET |$libFile| NIL) - (SPADLET |$lisplibVariableAlist| NIL) - (SPADLET |$lisplibRelatedDomains| NIL) - (SPADLET |$lisplibCategory| NIL) - (SPADLET |libName| (|getConstructorAbbreviation| |op|)) - (COND - ((AND (BOUNDP '|$compileDocumentation|) - |$compileDocumentation|) - (|compileDocumentation| |libName|)) - ('T - (|sayMSG| - (CONS " initializing " - (CONS |$spadLibFT| - (APPEND (|bright| |libName|) - (CONS "for" - (|bright| |op|)))))) - (|initializeLisplib| |libName|) - (|sayMSG| - (CONS " compiling into " - (CONS |$spadLibFT| (|bright| |libName|)))) - (SPADLET |res| (FUNCALL |fn| |df| |m| |e| |prefix| |fal|)) - (|sayMSG| - (CONS " finalizing " - (CONS |$spadLibFT| (|bright| |libName|)))) - (FRESH-LINE |$algebraOutputStream|) - (|sayMSG| (|fillerSpaces| 72 "-")) - (|unloadOneConstructor| |op| |libName|) |res|)))))) - -;compTopLevel(x,m,e) == -;--+ signals that target is derived from lhs-- see NRTmakeSlot1Info -; $NRTderivedTargetIfTrue: local := false -; $killOptimizeIfTrue: local:= false -; $forceAdd: local:= false -; $compTimeSum: local := 0 -; $resolveTimeSum: local := 0 -; $packagesUsed: local := [] -; -- The next line allows the new compiler to be tested interactively. -; compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak -; if x is ["where",:.] then x := markWhereTran x -; def := -; x is ["where",a,:.] => a -; x -; $originalTarget : local := -; def is ["DEF",.,[target,:.],:.] => target -; 'sorry -; x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => -; ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) -; --keep old environment after top level function defs -; FUNCALL(compFun,x,m,e) - -(DEFUN |compTopLevel| (|x| |m| |e|) - (PROG (|$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| |$forceAdd| - |$compTimeSum| |$resolveTimeSum| |$packagesUsed| - |$originalTarget| |compFun| |a| |def| |ISTMP#3| |target| - |ISTMP#1| |ISTMP#2| |LETTMP#1| |val| |mode|) - (DECLARE (SPECIAL |$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| - |$forceAdd| |$compTimeSum| |$resolveTimeSum| - |$packagesUsed| |$originalTarget|)) - (RETURN - (PROGN - (SPADLET |$NRTderivedTargetIfTrue| NIL) - (SPADLET |$killOptimizeIfTrue| NIL) - (SPADLET |$forceAdd| NIL) - (SPADLET |$compTimeSum| 0) - (SPADLET |$resolveTimeSum| 0) - (SPADLET |$packagesUsed| NIL) - (SPADLET |compFun| - (COND - ((BOOT-EQUAL |$newCompAtTopLevel| 'T) '|newComp|) - ('T '|compOrCroak|))) - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|where|)) - (SPADLET |x| (|markWhereTran| |x|)))) - (SPADLET |def| - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|where|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - 'T)))) - |a|) - ('T |x|))) - (SPADLET |$originalTarget| - (COND - ((AND (PAIRP |def|) (EQ (QCAR |def|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |def|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |target| - (QCAR |ISTMP#3|)) - 'T)))))))) - |target|) - ('T '|sorry|))) - (COND - ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF)) - (AND (PAIRP |x|) (EQ (QCAR |x|) '|where|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) 'DEF))))))) - (SPADLET |LETTMP#1| (FUNCALL |compFun| |x| |m| |e|)) - (SPADLET |val| (CAR |LETTMP#1|)) - (SPADLET |mode| (CADR |LETTMP#1|)) - (CONS |val| (CONS |mode| (CONS |e| NIL)))) - ('T (FUNCALL |compFun| |x| |m| |e|))))))) - -;markWhereTran ["where",["DEF",form,sig,clist,body],:tail] == -; items := -; tail is [['SEQ,:l,['exit,n,x]]] => [:l,x] -; [first tail] -; [op,:argl] := form -; [target,:atypeList] := sig -; decls := [[":",a,b] for a in argl for b in atypeList | b] -;-- not (and/[null x for x in atypeList]) => -;-- systemError ['"unexpected WHERE argument list: ",:atypeList] -; for x in items repeat -; x is [":",a,b] => -; a is ['LISTOF,:r] => -; for y in r repeat decls := [[":",y,b],:decls] -; decls := [x,:decls] -; x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) => -; fn = target or fn is [=target] => ttype := bd -; fn = body or fn is [=body] => body := bd -; macros := [x,:macros] -; systemError ['"unexpected WHERE item: ",x] -; nargtypes := [p for arg in argl | -; p := or/[t for d in decls | d is [.,=arg,t]] or -; systemError ['"Missing WHERE declaration for :", arg]] -; nform := form -; ntarget := ttype or target -; ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body] -; result := -; REVERSE macros is [:m,e] => -; mpart := -; m => ['SEQ,:m,['exit,1,e]] -; e -; ['where,ndef,mpart] -; ndef -; result - -(DEFUN |markWhereTran| (G166613) - (PROG (|form| |sig| |clist| |tail| |ISTMP#5| |n| |ISTMP#6| |x| |l| - |items| |op| |argl| |target| |atypeList| |a| |b| |r| - |decls| |key| |fn| |ISTMP#3| |q| |ISTMP#4| |bd| |ttype| - |body| |macros| |t| |p| |nargtypes| |nform| |ntarget| - |ndef| |ISTMP#1| |ISTMP#2| |e| |m| |mpart| |result|) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G166613) '|where|) (CAR G166613))) - (COND ((EQ (CAADR G166613) 'DEF) (CAADR G166613))) - (SPADLET |form| (CADADR G166613)) - (SPADLET |sig| (CAR (CDDADR G166613))) - (SPADLET |clist| (CADR (CDDADR G166613))) - (SPADLET |body| (CADDR (CDDADR G166613))) - (SPADLET |tail| (CDDR G166613)) - (SPADLET |items| - (COND - ((AND (PAIRP |tail|) (EQ (QCDR |tail|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |tail|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) 'SEQ) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (REVERSE |ISTMP#2|)) - 'T) - (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCAR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCAR |ISTMP#4|) - '|exit|) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (PROGN - (SPADLET |n| - (QCAR |ISTMP#5|)) - (SPADLET |ISTMP#6| - (QCDR |ISTMP#5|)) - (AND (PAIRP |ISTMP#6|) - (EQ (QCDR |ISTMP#6|) - NIL) - (PROGN - (SPADLET |x| - (QCAR |ISTMP#6|)) - 'T))))))) - (PROGN - (SPADLET |l| - (QCDR |ISTMP#3|)) - 'T) - (PROGN - (SPADLET |l| (NREVERSE |l|)) - 'T)))))) - (APPEND |l| (CONS |x| NIL))) - ('T (CONS (CAR |tail|) NIL)))) - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |target| (CAR |sig|)) - (SPADLET |atypeList| (CDR |sig|)) - (SPADLET |decls| - (PROG (G166701) - (SPADLET G166701 NIL) - (RETURN - (DO ((G166708 |argl| (CDR G166708)) - (|a| NIL) - (G166709 |atypeList| (CDR G166709)) - (|b| NIL)) - ((OR (ATOM G166708) - (PROGN - (SETQ |a| (CAR G166708)) - NIL) - (ATOM G166709) - (PROGN - (SETQ |b| (CAR G166709)) - NIL)) - (NREVERSE0 G166701)) - (SEQ (EXIT (COND - (|b| - (SETQ G166701 - (CONS - (CONS '|:| - (CONS |a| (CONS |b| NIL))) - G166701)))))))))) - (DO ((G166744 |items| (CDR G166744)) (|x| NIL)) - ((OR (ATOM G166744) - (PROGN (SETQ |x| (CAR G166744)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((AND (PAIRP |a|) - (EQ (QCAR |a|) 'LISTOF) - (PROGN - (SPADLET |r| (QCDR |a|)) - 'T)) - (DO ((G166753 |r| (CDR G166753)) - (|y| NIL)) - ((OR (ATOM G166753) - (PROGN - (SETQ |y| (CAR G166753)) - NIL)) - NIL) - (SEQ (EXIT - (SPADLET |decls| - (CONS - (CONS '|:| - (CONS |y| (CONS |b| NIL))) - |decls|)))))) - ('T - (SPADLET |decls| (CONS |x| |decls|))))) - ((AND (PAIRP |x|) - (PROGN - (SPADLET |key| (QCAR |x|)) - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |fn| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |p| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |q| - (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |bd| - (QCAR |ISTMP#4|)) - 'T))))))))) - (MEMQ |key| '(DEF MDEF)) - (BOOT-EQUAL |p| '(NIL)) - (BOOT-EQUAL |q| '(NIL))) - (COND - ((OR (BOOT-EQUAL |fn| |target|) - (AND (PAIRP |fn|) - (EQ (QCDR |fn|) NIL) - (EQUAL (QCAR |fn|) |target|))) - (SPADLET |ttype| |bd|)) - ((OR (BOOT-EQUAL |fn| |body|) - (AND (PAIRP |fn|) - (EQ (QCDR |fn|) NIL) - (EQUAL (QCAR |fn|) |body|))) - (SPADLET |body| |bd|)) - ('T - (SPADLET |macros| (CONS |x| |macros|))))) - ('T - (|systemError| - (CONS "unexpected WHERE item: " - (CONS |x| NIL)))))))) - (SPADLET |nargtypes| - (PROG (G166764) - (SPADLET G166764 NIL) - (RETURN - (DO ((G166770 |argl| (CDR G166770)) - (|arg| NIL)) - ((OR (ATOM G166770) - (PROGN - (SETQ |arg| (CAR G166770)) - NIL)) - (NREVERSE0 G166764)) - (SEQ (EXIT (COND - ((SPADLET |p| - (OR - (PROG (G166776) - (SPADLET G166776 NIL) - (RETURN - (DO - ((G166783 NIL - G166776) - (G166784 |decls| - (CDR G166784)) - (|d| NIL)) - ((OR G166783 - (ATOM G166784) - (PROGN - (SETQ |d| - (CAR G166784)) - NIL)) - G166776) - (SEQ - (EXIT - (COND - ((AND (PAIRP |d|) - (PROGN - (SPADLET - |ISTMP#1| - (QCDR |d|)) - (AND - (PAIRP - |ISTMP#1|) - (EQUAL - (QCAR - |ISTMP#1|) - |arg|) - (PROGN - (SPADLET - |ISTMP#2| - (QCDR - |ISTMP#1|)) - (AND - (PAIRP - |ISTMP#2|) - (EQ - (QCDR - |ISTMP#2|) - NIL) - (PROGN - (SPADLET - |t| - (QCAR - |ISTMP#2|)) - 'T)))))) - (SETQ G166776 - (OR G166776 - |t|))))))))) - (|systemError| - (CONS - "Missing WHERE declaration for :" - (CONS |arg| NIL))))) - (SETQ G166764 - (CONS |p| G166764)))))))))) - (SPADLET |nform| |form|) - (SPADLET |ntarget| (OR |ttype| |target|)) - (SPADLET |ndef| - (CONS 'DEF - (CONS |nform| - (CONS (CONS |ntarget| |nargtypes|) - (CONS |clist| - (CONS |body| NIL)))))) - (SPADLET |result| - (COND - ((PROGN - (SPADLET |ISTMP#1| (REVERSE |macros|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |e| (QCAR |ISTMP#2|)) - (SPADLET |m| (QCDR |ISTMP#2|)) - 'T) - (PROGN - (SPADLET |m| (NREVERSE |m|)) - 'T))) - (SPADLET |mpart| - (COND - (|m| - (CONS 'SEQ - (APPEND |m| - (CONS - (CONS '|exit| - (CONS 1 (CONS |e| NIL))) - NIL)))) - ('T |e|))) - (CONS '|where| - (CONS |ndef| (CONS |mpart| NIL)))) - ('T |ndef|))) - |result|))))) - -;compPART(u,m,e) == -;--------new------------------------------------------94/10/11 -; ['PART,.,x] := u -; T := comp(x,m,e) => markAny('compPART,u, T) -; nil - -(DEFUN |compPART| (|u| |m| |e|) - (PROG (|x| T$) - (RETURN - (PROGN - (SPADLET |x| (CADDR |u|)) - (COND - ((SPADLET T$ (|comp| |x| |m| |e|)) - (|markAny| '|compPART| |u| T$)) - ('T NIL)))))) - -;xxxxx x == x - -(DEFUN |xxxxx| (|x|) |x|) - -;qt(n,T) == -; null T => nil -; if null getProplist('R,T.env) then xxxxx n -; T - -(DEFUN |qt| (|n| T$) - (COND - ((NULL T$) NIL) - ('T (COND ((NULL (|getProplist| 'R (CADDR T$))) (|xxxxx| |n|))) T$))) - -;qe(n,e) == -; if null getProplist('R,e) then xxxxx n -; e - -(DEFUN |qe| (|n| |e|) - (PROGN (COND ((NULL (|getProplist| 'R |e|)) (|xxxxx| |n|))) |e|)) - -;comp(x,m,e) == -; qe(7,e) -; T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T)) -;--T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m) -; --------------------------------------------------------94/11/10 -; nil - -(DEFUN |comp| (|x| |m| |e|) - (PROG (T$) - (RETURN - (PROGN - (|qe| 7 |e|) - (COND - ((SPADLET T$ (|qt| 8 (|comp0| |x| |m| |e|))) - (|qt| 9 (|markComp| |x| T$))) - ('T NIL)))))) - -;comp0(x,m,e) == -; qe(8,e) -;--version of comp which skips the marking (see compReduce1) -; T:= compNoStacking(x,m,e) => -; $compStack:= nil -; qt(10,T) -; $compStack:= [[x,m,e,$exitModeStack],:$compStack] -; nil - -(DEFUN |comp0| (|x| |m| |e|) - (PROG (T$) - (declare (special |$compStack| |$exitModeStack|)) - (RETURN - (PROGN - (|qe| 8 |e|) - (COND - ((SPADLET T$ (|compNoStacking| |x| |m| |e|)) - (SPADLET |$compStack| NIL) (|qt| 10 T$)) - ('T - (SPADLET |$compStack| - (CONS (CONS |x| - (CONS |m| - (CONS |e| - (CONS |$exitModeStack| NIL)))) - |$compStack|)) - NIL)))))) - -;compNoStacking(xOrig,m,e) == -; $partExpression: local := nil -; xOrig := markKillAllRecursive xOrig -;-->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e) -;----------------------------------------------------------94/10/11 -; qt(11,compNoStacking0(xOrig,m,e)) - -(DEFUN |compNoStacking| (|xOrig| |m| |e|) - (PROG (|$partExpression|) - (DECLARE (SPECIAL |$partExpression|)) - (RETURN - (PROGN - (SPADLET |$partExpression| NIL) - (SPADLET |xOrig| (|markKillAllRecursive| |xOrig|)) - (|qt| 11 (|compNoStacking0| |xOrig| |m| |e|)))))) - -;markKillAllRecursive x == -; x is [op,:r] => -;--->op = 'PART => markKillAllRecursive CADR r -; op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r] -;----------------------------------------------------------94/10/11 -; constructor? op => markKillAll x -; op = 'elt and constructor? opOf CAR r => -; ['elt,markKillAllRecursive CAR r,CADR r] -; x -; x - -(DEFUN |markKillAllRecursive| (|x|) - (PROG (|op| |r|) - (RETURN - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |r| (QCDR |x|)) - 'T)) - (COND - ((BOOT-EQUAL |op| 'PART) - (CONS 'PART - (CONS (CAR |r|) - (CONS (|markKillAllRecursive| (CADR |r|)) NIL)))) - ((|constructor?| |op|) (|markKillAll| |x|)) - ((AND (BOOT-EQUAL |op| '|elt|) - (|constructor?| (|opOf| (CAR |r|)))) - (CONS '|elt| - (CONS (|markKillAllRecursive| (CAR |r|)) - (CONS (CADR |r|) NIL)))) - ('T |x|))) - ('T |x|))))) - -;compNoStackingAux($partExpression,m,e) == -;-----------------not used---------------------94/10/11 -; x := CADDR $partExpression -; T := compNoStacking0(x,m,e) or return nil -; markParts($partExpression,T) - -(DEFUN |compNoStackingAux| (|$partExpression| |m| |e|) - (DECLARE (SPECIAL |$partExpression|)) - (PROG (|x| T$) - (RETURN - (PROGN - (SPADLET |x| (CADDR |$partExpression|)) - (SPADLET T$ (OR (|compNoStacking0| |x| |m| |e|) (RETURN NIL))) - (|markParts| |$partExpression| T$))))) - -;compNoStacking0(x,m,e) == -; qe(1,e) -; T := compNoStacking01(x,m,qe(51,e)) -; qt(52,T) - -(DEFUN |compNoStacking0| (|x| |m| |e|) - (PROG (T$) - (RETURN - (PROGN - (|qe| 1 |e|) - (SPADLET T$ (|compNoStacking01| |x| |m| (|qe| 51 |e|))) - (|qt| 52 T$))))) - -;compNoStacking01(x,m,e) == -;--compNoStacking0(x,m,e) == -; if CONTAINED('MI,m) then m := markKillAll(m) -; T:= comp2(x,m,e) => -; (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) => -; [T.expr,"Rep",T.env]; qt(12,T)) -; --$Representation is bound in compDefineFunctor, set by doIt -; --this hack says that when something is undeclared, $ is -; --preferred to the underlying representation -- RDJ 9/12/83 -; T := compNoStacking1(x,m,e,$compStack) -; qt(13,T) - -(DEFUN |compNoStacking01| (|x| |m| |e|) - (PROG (T$) - (declare (special |$compStack|)) - (RETURN - (PROGN - (COND ((CONTAINED 'MI |m|) (SPADLET |m| (|markKillAll| |m|)))) - (COND - ((SPADLET T$ (|comp2| |x| |m| |e|)) - (COND - ((AND (BOOT-EQUAL |m| |$EmptyMode|) - (BOOT-EQUAL (CADR T$) - (IFCAR (|get| '|Rep| '|value| |e|)))) - (CONS (CAR T$) (CONS '|Rep| (CONS (CADDR T$) NIL)))) - ('T (|qt| 12 T$)))) - ('T (SPADLET T$ (|compNoStacking1| |x| |m| |e| |$compStack|)) - (|qt| 13 T$))))))) - -;compNoStacking1(x,m,e,$compStack) == -; u:= get(if m="$" then "Rep" else m,"value",e) => -; m1 := markKillAll u.expr -;--------------------> new <------------------------- -; T:= comp2(x,m1,e) => coerce(T,m) -; nil -;--------------------> new <------------------------- -; nil - -(DEFUN |compNoStacking1| (|x| |m| |e| |$compStack|) - (DECLARE (SPECIAL |$compStack|)) - (PROG (|u| |m1| T$) - (RETURN - (COND - ((SPADLET |u| - (|get| (COND ((BOOT-EQUAL |m| '$) '|Rep|) ('T |m|)) - '|value| |e|)) - (SPADLET |m1| (|markKillAll| (CAR |u|))) - (COND - ((SPADLET T$ (|comp2| |x| |m1| |e|)) (|coerce| T$ |m|)) - ('T NIL))) - ('T NIL))))) - -;compWithMappingMode(x,m,oldE) == -; ["Mapping",m',:sl] := m -; $killOptimizeIfTrue: local:= true -; e:= oldE -; x := markKillAll x -; ------------------ -; m := markKillAll m -; ------------------ -;--if x is ['PART,.,y] then x := y -;--------------------------------- -; isFunctor x => -; if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and -; (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] -; ) and extendsCategoryForm("$",target,m') then return [x,m,e] -; if STRINGP x then x:= INTERN x -; for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat -; [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) -; not null vl and not hasFormalMapVariable(x, vl) => return -; [u,.,.] := comp([x,:vl],m',e) or return nil -; extractCodeAndConstructTriple(u, m, oldE) -; null vl and (t := comp([x], m', e)) => return -; [u,.,.] := t -; extractCodeAndConstructTriple(u, m, oldE) -; [u,.,.]:= comp(x,m',e) or return nil -; originalFun := u -; if originalFun is ['WI,a,b] then u := b -; uu := ['LAMBDA,vl,u] -; --------------------------> 11/28 drop COMP-TRAN, optimizations -; T := [uu,m,oldE] -; originalFun is ['WI,a,b] => markLambda(vl,a,m,T) -; markLambda(vl,originalFun,m,T) - -(DEFUN |compWithMappingMode| (|x| |m| |oldE|) - (PROG (|$killOptimizeIfTrue| |m'| |sl| |ISTMP#3| |ISTMP#4| |target| - |argModeList| |ISTMP#5| |vl| |e| |t| |LETTMP#1| - |originalFun| |u| |uu| T$ |ISTMP#1| |a| |ISTMP#2| |b|) - (DECLARE (SPECIAL |$killOptimizeIfTrue|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |m|) '|Mapping|) (CAR |m|))) - (SPADLET |m'| (CADR |m|)) - (SPADLET |sl| (CDDR |m|)) - (SPADLET |$killOptimizeIfTrue| 'T) - (SPADLET |e| |oldE|) - (SPADLET |x| (|markKillAll| |x|)) - (SPADLET |m| (|markKillAll| |m|)) - (COND - ((|isFunctor| |x|) - (COND - ((AND (PROGN - (SPADLET |ISTMP#1| - (|get| |x| '|modemap| - |$CategoryFrame|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |target| - (QCAR |ISTMP#4|)) - (SPADLET |argModeList| - (QCDR |ISTMP#4|)) - 'T))))) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL))))))) - (PROG (G167028) - (SPADLET G167028 'T) - (RETURN - (DO ((G167035 NIL (NULL G167028)) - (G167036 |argModeList| - (CDR G167036)) - (|mode| NIL) - (G167037 |sl| (CDR G167037)) - (|s| NIL)) - ((OR G167035 (ATOM G167036) - (PROGN - (SETQ |mode| (CAR G167036)) - NIL) - (ATOM G167037) - (PROGN - (SETQ |s| (CAR G167037)) - NIL)) - G167028) - (SEQ (EXIT - (SETQ G167028 - (AND G167028 - (|extendsCategoryForm| '$ |s| - |mode|)))))))) - (|extendsCategoryForm| '$ |target| |m'|)) - (RETURN (CONS |x| (CONS |m| (CONS |e| NIL))))) - ('T NIL))) - ('T (COND ((STRINGP |x|) (SPADLET |x| (INTERN |x|)))) - (DO ((G167054 |sl| (CDR G167054)) (|m| NIL) - (G167055 - (SPADLET |vl| - (TAKE (|#| |sl|) - |$FormalMapVariableList|)) - (CDR G167055)) - (|v| NIL)) - ((OR (ATOM G167054) - (PROGN (SETQ |m| (CAR G167054)) NIL) - (ATOM G167055) - (PROGN (SETQ |v| (CAR G167055)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |LETTMP#1| - (|compMakeDeclaration| - (CONS '|:| - (CONS |v| (CONS |m| NIL))) - |$EmptyMode| |e|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - |LETTMP#1|)))) - (COND - ((AND (NULL (NULL |vl|)) - (NULL (|hasFormalMapVariable| |x| |vl|))) - (RETURN - (PROGN - (SPADLET |LETTMP#1| - (OR (|comp| (CONS |x| |vl|) |m'| |e|) - (RETURN NIL))) - (SPADLET |u| (CAR |LETTMP#1|)) - (|extractCodeAndConstructTriple| |u| |m| |oldE|)))) - ((AND (NULL |vl|) - (SPADLET |t| (|comp| (CONS |x| NIL) |m'| |e|))) - (RETURN - (PROGN - (SPADLET |u| (CAR |t|)) - (|extractCodeAndConstructTriple| |u| |m| |oldE|)))) - ('T - (SPADLET |LETTMP#1| - (OR (|comp| |x| |m'| |e|) (RETURN NIL))) - (SPADLET |u| (CAR |LETTMP#1|)) - (SPADLET |originalFun| |u|) - (COND - ((AND (PAIRP |originalFun|) - (EQ (QCAR |originalFun|) 'WI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |originalFun|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |u| |b|))) - (SPADLET |uu| - (CONS 'LAMBDA (CONS |vl| (CONS |u| NIL)))) - (SPADLET T$ - (CONS |uu| (CONS |m| (CONS |oldE| NIL)))) - (COND - ((AND (PAIRP |originalFun|) - (EQ (QCAR |originalFun|) 'WI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |originalFun|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (|markLambda| |vl| |a| |m| T$)) - ('T (|markLambda| |vl| |originalFun| |m| T$)))))))))))) - -;compAtom(x,m,e) == -; T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T) -; x="nil" => -; T:= -; modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) -; modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) -; T => convert(T,m) -;--> -; FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e] -;-- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T') -; t:= -; isSymbol x => -; compSymbol(x,m,e) or return nil -; m = $Expression and primitiveType x => [x,m,e] -; STRINGP x => -; x ^= '"failed" and (MEMBER('(Symbol), $localImportStack) or -; MEMBER('(Symbol), $globalImportStack)) => markAt [x, '(String), e] -; [x, x, e] -; [x,primitiveType x or return nil,e] -; convert(t,m) - -(DEFUN |compAtom| (|x| |m| |e|) - (PROG (|ISTMP#1| |ISTMP#2| R T$ |t|) - (declare (special |$Expression| |$localImportStack| |$globalImportStack|)) - (RETURN - (COND - ((SPADLET T$ - (|compAtomWithModemap| |x| |m| |e| - (|get| |x| '|modemap| |e|))) - (|markCompAtom| |x| T$)) - ((BOOT-EQUAL |x| '|nil|) - (SPADLET T$ - (COND - ((PROGN - (SPADLET |ISTMP#1| - (|modeIsAggregateOf| '|List| |m| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET R (QCAR |ISTMP#2|)) - 'T))))) - (|compList| |x| (CONS '|List| (CONS R NIL)) |e|)) - ((PROGN - (SPADLET |ISTMP#1| - (|modeIsAggregateOf| '|Vector| |m| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET R (QCAR |ISTMP#2|)) - 'T))))) - (|compVector| |x| (CONS '|Vector| (CONS R NIL)) - |e|)))) - (COND (T$ (|convert| T$ |m|)))) - ((AND (integerp |x|) - (MEMQ (|opOf| |m|) - '(|Integer| |NonNegativeInteger| |PositiveInteger| - |SmallInteger|))) - (|markAt| (CONS |x| (CONS |m| (CONS |e| NIL))))) - ('T - (SPADLET |t| - (COND - ((|isSymbol| |x|) - (OR (|compSymbol| |x| |m| |e|) (RETURN NIL))) - ((AND (BOOT-EQUAL |m| |$Expression|) - (|primitiveType| |x|)) - (CONS |x| (CONS |m| (CONS |e| NIL)))) - ((STRINGP |x|) - (COND - ((AND (NEQUAL |x| "failed") - (OR (|member| '(|Symbol|) - |$localImportStack|) - (|member| '(|Symbol|) - |$globalImportStack|))) - (|markAt| - (CONS |x| - (CONS '(|String|) (CONS |e| NIL))))) - ('T (CONS |x| (CONS |x| (CONS |e| NIL)))))) - ('T - (CONS |x| - (CONS (OR (|primitiveType| |x|) - (RETURN NIL)) - (CONS |e| NIL)))))) - (|convert| |t| |m|)))))) - -;extractCodeAndConstructTriple(u, m, oldE) == -; u := markKillAll u -; u is ["call",fn,:.] => -; if fn is ["applyFun",a] then fn := a -; [fn,m,oldE] -; [op,:.,env] := u -; [["CONS",["function",op],env],m,oldE] - -(DEFUN |extractCodeAndConstructTriple| (|u| |m| |oldE|) - (PROG (|ISTMP#1| |a| |fn| |op| |LETTMP#1| |env|) - (RETURN - (PROGN - (SPADLET |u| (|markKillAll| |u|)) - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|call|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |fn| (QCAR |ISTMP#1|)) 'T)))) - (COND - ((AND (PAIRP |fn|) (EQ (QCAR |fn|) '|applyFun|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |fn|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) - (SPADLET |fn| |a|))) - (CONS |fn| (CONS |m| (CONS |oldE| NIL)))) - ('T (SPADLET |op| (CAR |u|)) - (SPADLET |LETTMP#1| (REVERSE (CDR |u|))) - (SPADLET |env| (CAR |LETTMP#1|)) - (CONS (CONS 'CONS - (CONS (CONS '|function| (CONS |op| NIL)) - (CONS |env| NIL))) - (CONS |m| (CONS |oldE| NIL))))))))) - -;compSymbol(s,m,e) == -; s="$NoValue" => ["$NoValue",$NoValueMode,e] -; isFluid s => [s,getmode(s,e) or return nil,e] -; s="true" => ['(QUOTE T),$Boolean,e] -; s="false" => [false,$Boolean,e] -; s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] -; v:= get(s,"value",e) => -;--+ -; MEMQ(s,$functorLocalParameters) => -; NRTgetLocalIndex s -; [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile -; [s,v.mode,e] --s has been SETQd -; m':= getmode(s,e) => -; if not MEMBER(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and -; not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s -; [s,m',e] --s is a declared argument -; MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] -;---> -; m = $Symbol or m = $Expression => [['QUOTE,s],m,e] -; ---> was ['QUOTE, s] -; not isFunction(s,e) => errorRef s - -(DEFUN |compSymbol| (|s| |m| |e|) - (PROG (|v| |m'|) - (declare (special |$NoValue| |$NoValueMode| |$Boolean| |$formalArgList| - |$functorLocalParameters| |$FormalMapVariableList| - |$compForModeIfTrue| |$Symbol| |$Expression|)) - (RETURN - (COND - ((BOOT-EQUAL |s| '|$NoValue|) - (CONS '|$NoValue| (CONS |$NoValueMode| (CONS |e| NIL)))) - ((|isFluid| |s|) - (CONS |s| - (CONS (OR (|getmode| |s| |e|) (RETURN NIL)) - (CONS |e| NIL)))) - ((BOOT-EQUAL |s| '|true|) - (CONS ''T (CONS |$Boolean| (CONS |e| NIL)))) - ((BOOT-EQUAL |s| '|false|) - (CONS NIL (CONS |$Boolean| (CONS |e| NIL)))) - ((OR (BOOT-EQUAL |s| |m|) (|get| |s| '|isLiteral| |e|)) - (CONS (CONS 'QUOTE (CONS |s| NIL)) (CONS |s| (CONS |e| NIL)))) - ((SPADLET |v| (|get| |s| '|value| |e|)) - (COND - ((MEMQ |s| |$functorLocalParameters|) - (|NRTgetLocalIndex| |s|) - (CONS |s| (CONS (CADR |v|) (CONS |e| NIL)))) - ('T (CONS |s| (CONS (CADR |v|) (CONS |e| NIL)))))) - ((SPADLET |m'| (|getmode| |s| |e|)) - (COND - ((AND (NULL (|member| |s| |$formalArgList|)) - (NULL (MEMQ |s| |$FormalMapVariableList|)) - (NULL (|isFunction| |s| |e|)) - (NULL (BOOT-EQUAL |$compForModeIfTrue| 'T))) - (|errorRef| |s|))) - (CONS |s| (CONS |m'| (CONS |e| NIL)))) - ((MEMQ |s| |$FormalMapVariableList|) - (|stackMessage| (CONS '|no mode found for| (CONS |s| NIL)))) - ((OR (BOOT-EQUAL |m| |$Symbol|) (BOOT-EQUAL |m| |$Expression|)) - (CONS (CONS 'QUOTE (CONS |s| NIL)) (CONS |m| (CONS |e| NIL)))) - ((NULL (|isFunction| |s| |e|)) (|errorRef| |s|)))))) - -;compForm(form,m,e) == -; if form is [['PART,.,op],:r] then form := [op,:r] -; ----------------------------------------------------- 94/10/16 -; T:= -; compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return -; stackMessageIfNone ["cannot compile","%b",form,"%d"] -; T - -(DEFUN |compForm| (|form| |m| |e|) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |op| |r| T$) - (RETURN - (PROGN - (COND - ((AND (PAIRP |form|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |form|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) 'PART) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |op| (QCAR |ISTMP#3|)) - 'T))))))) - (PROGN (SPADLET |r| (QCDR |form|)) 'T)) - (SPADLET |form| (CONS |op| |r|)))) - (SPADLET T$ - (OR (|compForm1| |form| |m| |e|) - (|compArgumentsAndTryAgain| |form| |m| |e|) - (RETURN - (|stackMessageIfNone| - (CONS '|cannot compile| - (CONS '|%b| - (CONS |form| (CONS '|%d| NIL)))))))) - T$)))) - -;compForm1(form,m,e) == -; [op,:argl] := form -; $NumberOfArgsIfInteger: local:= #argl --see compElt -; op="error" => -; [[op,:[([.,.,e]:=outputComp(x,e)).expr -; for x in argl]],m,e] -; op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e) -; op is ["elt",domain,op'] => -; domain := markKillAll domain -; domain="Lisp" => -; --op'='QUOTE and null rest argl => [first argl,m,e] -; val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]] -; markLisp([val,m,e],m) -;-------> new <------------- -;-- foobar domain -;-- markImport(domain,true) -;-------> new <------------- -; domain=$Expression and op'="construct" => compExpressionList(argl,m,e) -; (op'="COLLECT") and coerceable(domain,m,e) => -; (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) -;-------> new <------------- -; domain= 'Rep and -; (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e), -; [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e) -; | x is [[ =domain,:.],:.]])) => ans -;-------> new <------------- -; ans := compForm2([op',:argl],m,e:= addDomain(domain,e), -; [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans -; (op'="construct") and coerceable(domain,m,e) => -; (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) -; nil -; e:= addDomain(m,e) --???unneccessary because of comp2's call??? -; (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T -; compToApply(op,argl,m,e) - -(DEFUN |compForm1| (|form| |m| |e|) - (PROG (|$NumberOfArgsIfInteger| |op| |argl| |a| |b| |ISTMP#2| |op'| - |domain| |LETTMP#1| |val| |ISTMP#1| |ans| |mmList| T$) - (DECLARE (SPECIAL |$NumberOfArgsIfInteger|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |$NumberOfArgsIfInteger| (|#| |argl|)) - (COND - ((BOOT-EQUAL |op| '|error|) - (CONS (CONS |op| - (PROG (G167267) - (SPADLET G167267 NIL) - (RETURN - (DO ((G167275 |argl| (CDR G167275)) - (|x| NIL)) - ((OR (ATOM G167275) - (PROGN - (SETQ |x| (CAR G167275)) - NIL)) - (NREVERSE0 G167267)) - (SEQ (EXIT - (SETQ G167267 - (CONS - (CAR - (PROGN - (SPADLET |LETTMP#1| - (|outputComp| |x| |e|)) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|)) - G167267)))))))) - (CONS |m| (CONS |e| NIL)))) - ((AND (PAIRP |op|) (EQ (QCAR |op|) 'MI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (|compForm1| (CONS (|markKillExpr| |b|) |argl|) |m| - |e|)) - ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |domain| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |op'| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |domain| (|markKillAll| |domain|)) - (COND - ((BOOT-EQUAL |domain| '|Lisp|) - (SPADLET |val| - (CONS |op'| - (PROG (G167288) - (SPADLET G167288 NIL) - (RETURN - (DO - ((G167296 |argl| - (CDR G167296)) - (|x| NIL)) - ((OR (ATOM G167296) - (PROGN - (SETQ |x| (CAR G167296)) - NIL)) - (NREVERSE0 G167288)) - (SEQ - (EXIT - (SETQ G167288 - (CONS - (CAR - (PROGN - (SPADLET |LETTMP#1| - (|compOrCroak| |x| - |$EmptyMode| |e|)) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|)) - G167288))))))))) - (|markLisp| (CONS |val| (CONS |m| (CONS |e| NIL))) - |m|)) - ((AND (BOOT-EQUAL |domain| |$Expression|) - (BOOT-EQUAL |op'| '|construct|)) - (|compExpressionList| |argl| |m| |e|)) - ((AND (BOOT-EQUAL |op'| 'COLLECT) - (|coerceable| |domain| |m| |e|)) - (SPADLET T$ - (OR (|comp| (CONS |op'| |argl|) |domain| - |e|) - (RETURN NIL))) - (|coerce| T$ |m|)) - ((AND (BOOT-EQUAL |domain| '|Rep|) - (SPADLET |ans| - (|compForm2| (CONS |op'| |argl|) - (MSUBST '|Rep| '$ |m|) - (SPADLET |e| - (|addDomain| |domain| |e|)) - (PROG (G167307) - (SPADLET G167307 NIL) - (RETURN - (DO - ((G167313 - (|getFormModemaps| - (CONS |op'| |argl|) |e|) - (CDR G167313)) - (|x| NIL)) - ((OR (ATOM G167313) - (PROGN - (SETQ |x| - (CAR G167313)) - NIL)) - (NREVERSE0 G167307)) - (SEQ - (EXIT - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| - (QCAR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQUAL - (QCAR |ISTMP#1|) - |domain|)))) - (SETQ G167307 - (CONS - (MSUBST '|Rep| '$ - |x|) - G167307)))))))))))) - |ans|) - ((SPADLET |ans| - (|compForm2| (CONS |op'| |argl|) |m| - (SPADLET |e| - (|addDomain| |domain| |e|)) - (PROG (G167324) - (SPADLET G167324 NIL) - (RETURN - (DO - ((G167330 - (|getFormModemaps| - (CONS |op'| |argl|) |e|) - (CDR G167330)) - (|x| NIL)) - ((OR (ATOM G167330) - (PROGN - (SETQ |x| (CAR G167330)) - NIL)) - (NREVERSE0 G167324)) - (SEQ - (EXIT - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| - (QCAR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) - |domain|)))) - (SETQ G167324 - (CONS |x| G167324))))))))))) - |ans|) - ((AND (BOOT-EQUAL |op'| '|construct|) - (|coerceable| |domain| |m| |e|)) - (SPADLET T$ - (OR (|comp| (CONS |op'| |argl|) |domain| - |e|) - (RETURN NIL))) - (|coerce| T$ |m|)) - ('T NIL))) - ('T (SPADLET |e| (|addDomain| |m| |e|)) - (COND - ((AND (SPADLET |mmList| - (|getFormModemaps| |form| |e|)) - (SPADLET T$ - (|compForm2| |form| |m| |e| |mmList|))) - T$) - ('T (|compToApply| |op| |argl| |m| |e|)))))))))) - -;--% WI and MI -;compForm3(form is [op,:argl],m,e,modemapList) == -;--order modemaps so that ones from Rep are moved to the front -; modemapList := compFormOrderModemaps(modemapList,m = "$") -; qe(22,e) -; T:= -; or/ -; [compFormWithModemap(form,m,e,first (mml:= ml)) -; for ml in tails modemapList] or return nil -; qt(14,T) -; result := -; $compUniquelyIfTrue => -; or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => -; THROW("compUniquely",nil) -; qt(15,T) -; qt(16,T) -; qt(17,markAny('compForm3,form,result)) - -(DEFUN |compForm3| (|form| |m| |e| |modemapList|) - (PROG (|op| |argl| |mml| T$ |result|) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |modemapList| - (|compFormOrderModemaps| |modemapList| - (BOOT-EQUAL |m| '$))) - (|qe| 22 |e|) - (SPADLET T$ - (OR (PROG (G167384) - (SPADLET G167384 NIL) - (RETURN - (DO ((G167390 NIL G167384) - (|ml| |modemapList| (CDR |ml|))) - ((OR G167390 (ATOM |ml|)) - G167384) - (SEQ (EXIT - (SETQ G167384 - (OR G167384 - (|compFormWithModemap| |form| - |m| |e| - (CAR (SPADLET |mml| |ml|)))))))))) - (RETURN NIL))) - (|qt| 14 T$) - (SPADLET |result| - (COND - (|$compUniquelyIfTrue| - (COND - ((PROG (G167395) - (SPADLET G167395 NIL) - (RETURN - (DO - ((G167401 NIL G167395) - (G167402 (CDR |mml|) - (CDR G167402)) - (|mm| NIL)) - ((OR G167401 (ATOM G167402) - (PROGN - (SETQ |mm| (CAR G167402)) - NIL)) - G167395) - (SEQ - (EXIT - (SETQ G167395 - (OR G167395 - (|compFormWithModemap| |form| - |m| |e| |mm|)))))))) - (THROW '|compUniquely| NIL)) - ('T (|qt| 15 T$)))) - ('T (|qt| 16 T$)))) - (|qt| 17 (|markAny| '|compForm3| |form| |result|))))))) - -;compFormOrderModemaps(mml,targetIsDollar?) == -;--order modemaps so that ones from Rep are moved to the front -;--exceptions: if $ is the target and there are 2 modemaps with -;-- identical signatures, move the $ one ahead -; repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep] -; if repMms and targetIsDollar? then -; dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$" -; and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]] -; repMms := [:dollarMms, :repMms] -; null repMms => mml -; [:repMms,:SETDIFFERENCE(mml,repMms)] - -(DEFUN |compFormOrderModemaps| (|mml| |targetIsDollar?|) - (PROG (|dc| |sig| |dc1| |sig1| |dollarMms| |repMms|) - (RETURN - (SEQ (PROGN - (SPADLET |repMms| - (PROG (G167436) - (SPADLET G167436 NIL) - (RETURN - (DO ((G167443 |mml| (CDR G167443)) - (|mm| NIL)) - ((OR (ATOM G167443) - (PROGN - (SETQ |mm| (CAR G167443)) - NIL) - (PROGN - (PROGN - (SPADLET |dc| (CAAR |mm|)) - |mm|) - NIL)) - (NREVERSE0 G167436)) - (SEQ (EXIT (COND - ((BOOT-EQUAL |dc| '|Rep|) - (SETQ G167436 - (CONS |mm| G167436)))))))))) - (COND - ((AND |repMms| |targetIsDollar?|) - (SPADLET |dollarMms| - (PROG (G167456) - (SPADLET G167456 NIL) - (RETURN - (DO ((G167463 |mml| (CDR G167463)) - (|mm| NIL)) - ((OR (ATOM G167463) - (PROGN - (SETQ |mm| (CAR G167463)) - NIL) - (PROGN - (PROGN - (SPADLET |dc| (CAAR |mm|)) - (SPADLET |sig| (CDAR |mm|)) - |mm|) - NIL)) - (NREVERSE0 G167456)) - (SEQ (EXIT - (COND - ((AND (BOOT-EQUAL |dc| '$) - (PROG (G167470) - (SPADLET G167470 NIL) - (RETURN - (DO - ((G167478 NIL - G167470) - (G167479 |repMms| - (CDR G167479)) - (|mm1| NIL)) - ((OR G167478 - (ATOM G167479) - (PROGN - (SETQ |mm1| - (CAR G167479)) - NIL) - (PROGN - (PROGN - (SPADLET |dc1| - (CAAR |mm1|)) - (SPADLET |sig1| - (CDAR |mm1|)) - |mm1|) - NIL)) - G167470) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |sig1| - |sig|) - (SETQ G167470 - (OR G167470 - |mm1|)))))))))) - (SETQ G167456 - (CONS |mm| G167456)))))))))) - (SPADLET |repMms| (APPEND |dollarMms| |repMms|)))) - (COND - ((NULL |repMms|) |mml|) - ('T (APPEND |repMms| (SETDIFFERENCE |mml| |repMms|))))))))) - -;compWI(["WI",a,b],m,E) == -; u := comp(b,m,E) -; pp (u => "====> ok"; 'NO) -; u - -(DEFUN |compWI| (G167503 |m| E) - (PROG (|a| |b| |u|) - (RETURN - (PROGN - (COND ((EQ (CAR G167503) 'WI) (CAR G167503))) - (SPADLET |a| (CADR G167503)) - (SPADLET |b| (CADDR G167503)) - (SPADLET |u| (|comp| |b| |m| E)) - (|pp| (COND (|u| '|====> ok|) ('T 'NO))) - |u|)))) - -;compMI(["MI",a,b],m,E) == -; u := comp(b,m,E) -; pp (u => "====> ok"; 'NO) -; u - -(DEFUN |compMI| (G167522 |m| E) - (PROG (|a| |b| |u|) - (RETURN - (PROGN - (COND ((EQ (CAR G167522) 'MI) (CAR G167522))) - (SPADLET |a| (CADR G167522)) - (SPADLET |b| (CADDR G167522)) - (SPADLET |u| (|comp| |b| |m| E)) - (|pp| (COND (|u| '|====> ok|) ('T 'NO))) - |u|)))) - -;compWhere([.,form,:exprList],m,eInit) == -; $insideExpressionIfTrue: local:= false -; $insideWhereIfTrue: local:= true -;-- if not $insideFunctorIfTrue then -;-- $originalTarget := -;-- form is ['DEF,a,osig,:.] and osig is [otarget,:.] => -;-- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and -;-- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and -;-- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) => -;-- [ntarget,:rest osig] -;-- osig -;-- nil -;-- foobum exprList -; e:= eInit -; u:= -; for item in exprList repeat -; [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" -; u="failed" => return nil -; $insideWhereIfTrue:= false -; [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil -; eFinal:= -; del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) -; eInit -; [x,m,eFinal] - -(DEFUN |compWhere| (G167555 |m| |eInit|) - (PROG (|$insideExpressionIfTrue| |$insideWhereIfTrue| |form| - |exprList| |e| |u| |eBefore| |LETTMP#1| |x| |eAfter| |del| - |eFinal|) - (DECLARE (SPECIAL |$insideExpressionIfTrue| |$insideWhereIfTrue|)) - (RETURN - (SEQ (PROGN - (SPADLET |form| (CADR G167555)) - (SPADLET |exprList| (CDDR G167555)) - (SPADLET |$insideExpressionIfTrue| NIL) - (SPADLET |$insideWhereIfTrue| 'T) - (SPADLET |e| |eInit|) - (SPADLET |u| - (DO ((G167578 |exprList| (CDR G167578)) - (|item| NIL)) - ((OR (ATOM G167578) - (PROGN - (SETQ |item| (CAR G167578)) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |LETTMP#1| - (OR - (|comp| |item| |$EmptyMode| |e|) - (RETURN '|failed|))) - (SPADLET |e| (CADDR |LETTMP#1|)) - |LETTMP#1|))))) - (COND - ((BOOT-EQUAL |u| '|failed|) (RETURN NIL)) - ('T (SPADLET |$insideWhereIfTrue| NIL) - (SPADLET |LETTMP#1| - (OR (|comp| (|macroExpand| |form| - (SPADLET |eBefore| |e|)) - |m| |e|) - (RETURN NIL))) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET |eAfter| (CADDR |LETTMP#1|)) - (SPADLET |eFinal| - (COND - ((SPADLET |del| - (|deltaContour| |eAfter| - |eBefore|)) - (|addContour| |del| |eInit|)) - ('T |eInit|))) - (CONS |x| (CONS |m| (CONS |eFinal| NIL)))))))))) - -;compMacro(form,m,e) == -; $macroIfTrue: local:= true -; ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form -; firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs] -; markMacro(first lhs,rhs) -; rhs := -; rhs is ['CATEGORY,:.] => ['"-- the constructor category"] -; rhs is ['Join,:.] => ['"-- the constructor category"] -; rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] -; rhs is ['add,:.] => ['"-- the constructor capsule"] -; formatUnabbreviated rhs -; sayBrightly ['" processing macro definition",'%b, -; :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] -; ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) -; m=$EmptyMode or m=$NoValueMode => -; ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - -(DEFUN |compMacro| (|form| |m| |e|) - (PROG (|$macroIfTrue| |firstForm| |lhs| |signature| |specialCases| - |rhs|) - (DECLARE (SPECIAL |$macroIfTrue|)) - (RETURN - (PROGN - (SPADLET |$macroIfTrue| 'T) - (SPADLET |form| (|markKillAll| |form|)) - (COND ((EQ (CAR |form|) 'MDEF) (CAR |form|))) - (SPADLET |lhs| (CADR |form|)) - (SPADLET |signature| (CADDR |form|)) - (SPADLET |specialCases| (CADDDR |form|)) - (SPADLET |rhs| (CAR (CDDDDR |form|))) - (SPADLET |firstForm| - (CONS 'MDEF - (CONS (CAR |lhs|) - (CONS '(NIL) - (CONS '(NIL) (CONS |rhs| NIL)))))) - (|markMacro| (CAR |lhs|) |rhs|) - (SPADLET |rhs| - (COND - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CATEGORY)) - (CONS "-- the constructor category" - NIL)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Join|)) - (CONS "-- the constructor category" - NIL)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CAPSULE)) - (CONS "-- the constructor capsule" - NIL)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|add|)) - (CONS "-- the constructor capsule" - NIL)) - ('T (|formatUnabbreviated| |rhs|)))) - (|sayBrightly| - (CONS " processing macro definition" - (CONS '|%b| - (APPEND (|formatUnabbreviated| |lhs|) - (CONS " ==> " - (APPEND |rhs| (CONS '|%d| NIL))))))) - (SPADLET |form| (|macroExpand| |form| |e|)) - (COND ((EQ (CAR |form|) 'MDEF) (CAR |form|))) - (SPADLET |lhs| (CADR |form|)) - (SPADLET |signature| (CADDR |form|)) - (SPADLET |specialCases| (CADDDR |form|)) - (SPADLET |rhs| (CAR (CDDDDR |form|))) - (COND - ((OR (BOOT-EQUAL |m| |$EmptyMode|) - (BOOT-EQUAL |m| |$NoValueMode|)) - (CONS '|/throwAway| - (CONS |$NoValueMode| - (CONS (|put| (CAR |lhs|) '|macro| |rhs| |e|) - NIL))))))))) - -;--compMacro(form,m,e) == -;-- $macroIfTrue: local:= true -;-- ["MDEF",lhs,signature,specialCases,rhs]:= form -;-- rhs := -;-- rhs is ['CATEGORY,:.] => ['"-- the constructor category"] -;-- rhs is ['Join,:.] => ['"-- the constructor category"] -;-- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] -;-- rhs is ['add,:.] => ['"-- the constructor capsule"] -;-- formatUnabbreviated rhs -;-- sayBrightly ['" processing macro definition",'%b, -;-- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] -;-- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) -;-- m=$EmptyMode or m=$NoValueMode => -;-- rhs := markMacro(lhs,rhs) -;-- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] -;compSetq(oform,m,E) == -; ["LET",form,val] := oform -; T := compSetq1(form,val,m,E) => markSetq(oform,T) -; nil - -(DEFUN |compSetq| (|oform| |m| E) - (PROG (|form| |val| T$) - (RETURN - (PROGN - (COND ((EQ (CAR |oform|) 'LET) (CAR |oform|))) - (SPADLET |form| (CADR |oform|)) - (SPADLET |val| (CADDR |oform|)) - (COND - ((SPADLET T$ (|compSetq1| |form| |val| |m| E)) - (|markSetq| |oform| T$)) - ('T NIL)))))) - -;compSetq1(oform,val,m,E) == -; form := markKillAll oform -; IDENTP form => setqSingle(form,val,m,E) -; form is [":",x,y] => -; [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) -; compSetq(["LET",x,val],m,E') -; form is [op,:l] => -; op="CONS" => setqMultiple(uncons form,val,m,E) -; op="Tuple" => setqMultiple(l,val,m,E) -; setqSetelt(oform,form,val,m,E) - -(DEFUN |compSetq1| (|oform| |val| |m| E) - (PROG (|form| |ISTMP#1| |x| |ISTMP#2| |y| |LETTMP#1| |E'| |op| |l|) - (RETURN - (PROGN - (SPADLET |form| (|markKillAll| |oform|)) - (COND - ((IDENTP |form|) (|setqSingle| |form| |val| |m| E)) - ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |LETTMP#1| - (|compMakeDeclaration| |form| |$EmptyMode| E)) - (SPADLET |E'| (CADDR |LETTMP#1|)) - (|compSetq| (CONS 'LET (CONS |x| (CONS |val| NIL))) |m| - |E'|)) - ((AND (PAIRP |form|) - (PROGN - (SPADLET |op| (QCAR |form|)) - (SPADLET |l| (QCDR |form|)) - 'T)) - (COND - ((BOOT-EQUAL |op| 'CONS) - (|setqMultiple| (|uncons| |form|) |val| |m| E)) - ((BOOT-EQUAL |op| '|Tuple|) - (|setqMultiple| |l| |val| |m| E)) - ('T (|setqSetelt| |oform| |form| |val| |m| E))))))))) - -;setqSetelt(oform,[v,:s],val,m,E) == -; T:= comp0(["setelt",:oform,val],m,E) or return nil -;---> ------- -; markComp(oform,T) - -(DEFUN |setqSetelt| (|oform| G167704 |val| |m| E) - (PROG (|v| |s| T$) - (RETURN - (PROGN - (SPADLET |v| (CAR G167704)) - (SPADLET |s| (CDR G167704)) - (SPADLET T$ - (OR (|comp0| (CONS '|setelt| - (APPEND |oform| (CONS |val| NIL))) - |m| E) - (RETURN NIL))) - (|markComp| |oform| T$))))) - -;setqSingle(id,val,m,E) == -; $insideSetqSingleIfTrue: local:= true -; --used for comping domain forms within functions -; currentProplist:= getProplist(id,E) -; m'':= get(id,'mode,E) or getmode(id,E) or -; (if m=$NoValueMode then $EmptyMode else m) -;-----------------------> new <------------------------- -; trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E) -;-----------------------> new <------------------------- -; T:= -; (trialT and coerce(trialT,m'')) or eval or return nil where -; eval() == -; T:= comp(val,m'',E) => T -; not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and -; (T:=comp(val,maxm'',E)) => T -; (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => -; assignError(val,T.mode,id,m'') -; T':= [x,m',e']:= convert(T,m) or return nil -; if $profileCompiler = true then -; null IDENTP id => nil -; key := -; MEMQ(id,rest $form) => 'arguments -; 'locals -; profileRecord(key,id,T.mode) -; newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T) -; e':= (PAIRP id => e'; addBinding(id,newProplist,e')) -; x1 := markKillAll x -; if isDomainForm(x1,e') then -; if isDomainInScope(id,e') then -; stackWarning ["domain valued variable","%b",id,"%d", -; "has been reassigned within its scope"] -; e':= augModemapsFromDomain1(id,x1,e') -; --all we do now is to allocate a slot number for lhs -; --e.g. the LET form below will be changed by putInLocalDomainReferences -;--+ -; if (k:=NRTassocIndex(id)) -; then -; $markFreeStack := [id,:$markFreeStack] -; form:=['SETELT,"$",k,x] -; else form:= -; $QuickLet => ["LET",id,x] -; ["LET",id,x, -; (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] -; [form,m',e'] - -(DEFUN |setqSingle| (|id| |val| |m| E) - (PROG (|$insideSetqSingleIfTrue| |currentProplist| |m''| |trialT| - |maxm''| T$ |LETTMP#1| |x| |m'| |T'| |key| |newProplist| - |x1| |e'| |k| |form|) - (DECLARE (SPECIAL |$insideSetqSingleIfTrue| |$NoValueMode| |$EmptyMode| - |$profileCompiler| |$form| |$markFreeStack| - |$QuickLet|)) - (RETURN - (PROGN - (SPADLET |$insideSetqSingleIfTrue| 'T) - (SPADLET |currentProplist| (|getProplist| |id| E)) - (SPADLET |m''| - (OR (|get| |id| '|mode| E) (|getmode| |id| E) - (COND - ((BOOT-EQUAL |m| |$NoValueMode|) |$EmptyMode|) - ('T |m|)))) - (SPADLET |trialT| - (AND (BOOT-EQUAL |m''| '$) (|get| '|Rep| '|value| E) - (|comp| |val| '|Rep| E))) - (SPADLET T$ - (OR (AND |trialT| (|coerce| |trialT| |m''|)) - (COND - ((SPADLET T$ (|comp| |val| |m''| E)) T$) - ((AND (NULL (|get| |id| '|mode| E)) - (NEQUAL |m''| - (SPADLET |maxm''| - (|maxSuperType| |m''| E))) - (SPADLET T$ (|comp| |val| |maxm''| E))) - T$) - ((AND (SPADLET T$ (|comp| |val| |$EmptyMode| E)) - (|getmode| (CADR T$) E)) - (|assignError| |val| (CADR T$) |id| |m''|))) - (RETURN NIL))) - (SPADLET |T'| - (PROGN - (SPADLET |LETTMP#1| - (OR (|convert| T$ |m|) (RETURN NIL))) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |m'| (CADR |LETTMP#1|)) - (SPADLET |e'| (CADDR |LETTMP#1|)) - |LETTMP#1|)) - (COND - ((BOOT-EQUAL |$profileCompiler| 'T) - (COND - ((NULL (IDENTP |id|)) NIL) - ('T - (SPADLET |key| - (COND - ((MEMQ |id| (CDR |$form|)) '|arguments|) - ('T '|locals|))) - (|profileRecord| |key| |id| (CADR T$)))))) - (SPADLET |newProplist| - (|consProplistOf| |id| |currentProplist| '|value| - (|markKillAll| (|removeEnv| T$)))) - (SPADLET |e'| - (COND - ((PAIRP |id|) |e'|) - ('T (|addBinding| |id| |newProplist| |e'|)))) - (SPADLET |x1| (|markKillAll| |x|)) - (COND - ((|isDomainForm| |x1| |e'|) - (COND - ((|isDomainInScope| |id| |e'|) - (|stackWarning| - (CONS '|domain valued variable| - (CONS '|%b| - (CONS |id| - (CONS '|%d| - (CONS - '|has been reassigned within its scope| - NIL)))))))) - (SPADLET |e'| (|augModemapsFromDomain1| |id| |x1| |e'|)))) - (COND - ((SPADLET |k| (|NRTassocIndex| |id|)) - (SPADLET |$markFreeStack| (CONS |id| |$markFreeStack|)) - (SPADLET |form| - (CONS 'SETELT (CONS '$ (CONS |k| (CONS |x| NIL)))))) - ('T - (SPADLET |form| - (COND - (|$QuickLet| - (CONS 'LET (CONS |id| (CONS |x| NIL)))) - ('T - (CONS 'LET - (CONS |id| - (CONS |x| - (CONS - (COND - ((|isDomainForm| |x| |e'|) - (CONS 'ELT - (CONS |id| (CONS 0 NIL)))) - ('T - (CAR (|outputComp| |id| |e'|)))) - NIL))))))))) - (CONS |form| (CONS |m'| (CONS |e'| NIL))))))) - -;setqMultiple(nameList,val,m,e) == -; val is ["CONS",:.] and m=$NoValueMode => -; setqMultipleExplicit(nameList,uncons val,m,e) -; val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) -; --1. create a gensym, %add to local environment, compile and assign rhs -; g:= genVariable() -; e:= addBinding(g,nil,e) -; T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil -; e:= put(g,"mode",m1,e) -; [x,m',e]:= convert(T,m) or return nil -; --1.1 exit if result is a list -; m1 is ["List",D] => -; for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) -; convert([["PROGN",x,["LET",nameList,g],g],m',e],m) -; --2. verify that the #nameList = number of parts of right-hand-side -; selectorModePairs:= -; --list of modes -; decompose(m1,#nameList,e) or return nil where -; decompose(t,length,e) == -; t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] -; comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => -; [[name,:mode] for [":",name,mode] in l] -; stackMessage ["no multiple assigns to mode: ",t] -; #nameList^=#selectorModePairs => -; stackMessage [val," must decompose into ",#nameList," components"] -; -- 3.generate code; return -; assignList:= -; [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr -; for x in nameList for [y,:z] in selectorModePairs] -; if assignList="failed" then NIL -; else [MKPROGN [x,:assignList,g],m',e] - -(DEFUN |setqMultiple,decompose| (|t| |length| |e|) - (declare (ignore |length|)) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |l| |ISTMP#4| |name| |mode|) - (declare (special |$EmptyMode|)) - (RETURN - (SEQ (IF (AND (PAIRP |t|) (EQ (QCAR |t|) '|Record|) - (PROGN (SPADLET |l| (QCDR |t|)) 'T)) - (EXIT (PROG (G167823) - (SPADLET G167823 NIL) - (RETURN - (DO ((G167829 |l| (CDR G167829)) - (G167785 NIL)) - ((OR (ATOM G167829) - (PROGN - (SETQ G167785 (CAR G167829)) - NIL) - (PROGN - (PROGN - (SPADLET |name| (CADR G167785)) - (SPADLET |mode| - (CADDR G167785)) - G167785) - NIL)) - (NREVERSE0 G167823)) - (SEQ (EXIT (SETQ G167823 - (CONS (CONS |name| |mode|) - G167823))))))))) - (IF (PROGN - (SPADLET |ISTMP#1| (|comp| |t| |$EmptyMode| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) - '|RecordCategory|) - (PROGN - (SPADLET |l| (QCDR |ISTMP#3|)) - 'T))) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL))))))) - (EXIT (PROG (G167841) - (SPADLET G167841 NIL) - (RETURN - (DO ((G167847 |l| (CDR G167847)) - (G167813 NIL)) - ((OR (ATOM G167847) - (PROGN - (SETQ G167813 (CAR G167847)) - NIL) - (PROGN - (PROGN - (SPADLET |name| (CADR G167813)) - (SPADLET |mode| - (CADDR G167813)) - G167813) - NIL)) - (NREVERSE0 G167841)) - (SEQ (EXIT (SETQ G167841 - (CONS (CONS |name| |mode|) - G167841))))))))) - (EXIT (|stackMessage| - (CONS '|no multiple assigns to mode: | - (CONS |t| NIL)))))))) - -(DEFUN |setqMultiple| (|nameList| |val| |m| |e|) - (PROG (|l| |g| |m1| T$ |x| |m'| |ISTMP#1| D |selectorModePairs| |y| - |z| |LETTMP#1| |assignList|) - (RETURN - (SEQ (COND - ((AND (PAIRP |val|) (EQ (QCAR |val|) 'CONS) - (BOOT-EQUAL |m| |$NoValueMode|)) - (|setqMultipleExplicit| |nameList| (|uncons| |val|) |m| - |e|)) - ((AND (PAIRP |val|) (EQ (QCAR |val|) '|Tuple|) - (PROGN (SPADLET |l| (QCDR |val|)) 'T) - (BOOT-EQUAL |m| |$NoValueMode|)) - (|setqMultipleExplicit| |nameList| |l| |m| |e|)) - ('T (SPADLET |g| (|genVariable|)) - (SPADLET |e| (|addBinding| |g| NIL |e|)) - (SPADLET T$ - (PROGN - (SPADLET |LETTMP#1| - (OR (|compSetq1| |g| |val| - |$EmptyMode| |e|) - (RETURN NIL))) - (SPADLET |m1| (CADR |LETTMP#1|)) - |LETTMP#1|)) - (SPADLET |e| (|put| |g| '|mode| |m1| |e|)) - (SPADLET |LETTMP#1| (OR (|convert| T$ |m|) (RETURN NIL))) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |m'| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((AND (PAIRP |m1|) (EQ (QCAR |m1|) '|List|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m1|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) - (DO ((G167883 |nameList| (CDR G167883)) (|y| NIL)) - ((OR (ATOM G167883) - (PROGN (SETQ |y| (CAR G167883)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |e| - (|put| |y| '|value| - (CONS (|genSomeVariable|) - (CONS D (CONS |$noEnv| NIL))) - |e|))))) - (|convert| - (CONS (CONS 'PROGN - (CONS |x| - (CONS - (CONS 'LET - (CONS |nameList| - (CONS |g| NIL))) - (CONS |g| NIL)))) - (CONS |m'| (CONS |e| NIL))) - |m|)) - ('T - (SPADLET |selectorModePairs| - (OR (|setqMultiple,decompose| |m1| - (|#| |nameList|) |e|) - (RETURN NIL))) - (COND - ((NEQUAL (|#| |nameList|) (|#| |selectorModePairs|)) - (|stackMessage| - (CONS |val| - (CONS '| must decompose into | - (CONS (|#| |nameList|) - (CONS '| components| NIL)))))) - ('T - (SPADLET |assignList| - (PROG (G167898) - (SPADLET G167898 NIL) - (RETURN - (DO ((G167908 |nameList| - (CDR G167908)) - (|x| NIL) - (G167909 |selectorModePairs| - (CDR G167909)) - (G167875 NIL)) - ((OR (ATOM G167908) - (PROGN - (SETQ |x| (CAR G167908)) - NIL) - (ATOM G167909) - (PROGN - (SETQ G167875 - (CAR G167909)) - NIL) - (PROGN - (PROGN - (SPADLET |y| - (CAR G167875)) - (SPADLET |z| - (CDR G167875)) - G167875) - NIL)) - (NREVERSE0 G167898)) - (SEQ - (EXIT - (SETQ G167898 - (CONS - (CAR - (PROGN - (SPADLET |LETTMP#1| - (OR - (|compSetq1| |x| - (CONS '|elt| - (CONS |g| (CONS |y| NIL))) - |z| |e|) - (RETURN '|failed|))) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|)) - G167898)))))))) - (COND - ((BOOT-EQUAL |assignList| '|failed|) NIL) - ('T - (CONS (MKPROGN (CONS |x| - (APPEND |assignList| - (CONS |g| NIL)))) - (CONS |m'| (CONS |e| NIL))))))))))))))) - -;setqMultipleExplicit(nameList,valList,m,e) == -; #nameList^=#valList => -; stackMessage ["Multiple assignment error; # of items in: ",nameList, -; "must = # in: ",valList] -; gensymList:= [genVariable() for name in nameList] -; for g in gensymList for name in nameList repeat -; e := put(g,"mode",get(name,"mode",e),e) -; assignList:= -; --should be fixed to declare genVar when possible -; [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" -; for g in gensymList for val in valList for name in nameList] -; assignList="failed" => nil -; reAssignList:= -; [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" -; for g in gensymList for name in nameList] -; reAssignList="failed" => nil -; T := [["PROGN",:[T.expr for T in assignList], -; :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env] -; markMultipleExplicit(nameList,valList,T) - -(DEFUN |setqMultipleExplicit| (|nameList| |valList| |m| |e|) - (declare (ignore |m|)) - (PROG (|gensymList| |assignList| |LETTMP#1| |reAssignList| T$) - (declare (special |$EmptyMode| |$NoValueMode|)) - (RETURN - (SEQ (COND - ((NEQUAL (|#| |nameList|) (|#| |valList|)) - (|stackMessage| - (CONS '|Multiple assignment error; # of items in: | - (CONS |nameList| - (CONS '|must = # in: | - (CONS |valList| NIL)))))) - ('T - (SPADLET |gensymList| - (PROG (G167958) - (SPADLET G167958 NIL) - (RETURN - (DO ((G167963 |nameList| (CDR G167963)) - (|name| NIL)) - ((OR (ATOM G167963) - (PROGN - (SETQ |name| (CAR G167963)) - NIL)) - (NREVERSE0 G167958)) - (SEQ (EXIT (SETQ G167958 - (CONS (|genVariable|) - G167958)))))))) - (DO ((G167973 |gensymList| (CDR G167973)) (|g| NIL) - (G167974 |nameList| (CDR G167974)) (|name| NIL)) - ((OR (ATOM G167973) - (PROGN (SETQ |g| (CAR G167973)) NIL) - (ATOM G167974) - (PROGN (SETQ |name| (CAR G167974)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |e| - (|put| |g| '|mode| - (|get| |name| '|mode| |e|) |e|))))) - (SPADLET |assignList| - (PROG (G167992) - (SPADLET G167992 NIL) - (RETURN - (DO ((G168002 |gensymList| - (CDR G168002)) - (|g| NIL) - (G168003 |valList| (CDR G168003)) - (|val| NIL) - (G168004 |nameList| (CDR G168004)) - (|name| NIL)) - ((OR (ATOM G168002) - (PROGN - (SETQ |g| (CAR G168002)) - NIL) - (ATOM G168003) - (PROGN - (SETQ |val| (CAR G168003)) - NIL) - (ATOM G168004) - (PROGN - (SETQ |name| (CAR G168004)) - NIL)) - (NREVERSE0 G167992)) - (SEQ (EXIT (SETQ G167992 - (CONS - (PROGN - (SPADLET |LETTMP#1| - (OR - (|compSetq1| |g| |val| - |$EmptyMode| |e|) - (RETURN '|failed|))) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|) - G167992)))))))) - (COND - ((BOOT-EQUAL |assignList| '|failed|) NIL) - ('T - (SPADLET |reAssignList| - (PROG (G168024) - (SPADLET G168024 NIL) - (RETURN - (DO ((G168033 |gensymList| - (CDR G168033)) - (|g| NIL) - (G168034 |nameList| - (CDR G168034)) - (|name| NIL)) - ((OR (ATOM G168033) - (PROGN - (SETQ |g| (CAR G168033)) - NIL) - (ATOM G168034) - (PROGN - (SETQ |name| (CAR G168034)) - NIL)) - (NREVERSE0 G168024)) - (SEQ (EXIT - (SETQ G168024 - (CONS - (PROGN - (SPADLET |LETTMP#1| - (OR - (|compSetq1| |name| |g| - |$EmptyMode| |e|) - (RETURN '|failed|))) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|) - G168024)))))))) - (COND - ((BOOT-EQUAL |reAssignList| '|failed|) NIL) - ('T - (SPADLET T$ - (CONS (CONS 'PROGN - (APPEND - (PROG (G168047) - (SPADLET G168047 NIL) - (RETURN - (DO - ((G168052 |assignList| - (CDR G168052)) - (T$ NIL)) - ((OR (ATOM G168052) - (PROGN - (SETQ T$ (CAR G168052)) - NIL)) - (NREVERSE0 G168047)) - (SEQ - (EXIT - (SETQ G168047 - (CONS (CAR T$) G168047))))))) - (PROG (G168062) - (SPADLET G168062 NIL) - (RETURN - (DO - ((G168067 |reAssignList| - (CDR G168067)) - (T$ NIL)) - ((OR (ATOM G168067) - (PROGN - (SETQ T$ (CAR G168067)) - NIL)) - (NREVERSE0 G168062)) - (SEQ - (EXIT - (SETQ G168062 - (CONS (CAR T$) G168062))))))))) - (CONS |$NoValueMode| - (CONS - (CADDR (|last| |reAssignList|)) - NIL)))) - (|markMultipleExplicit| |nameList| |valList| T$))))))))))) - -;canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends -; atom expr => ValueFlag and level=exitCount -; (op:= first expr)="QUOTE" => ValueFlag and level=exitCount -; MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag) -; op="TAGGEDexit" => -; expr is [.,count,data] => canReturn(data.expr,level,count,count=level) -; level=exitCount and not ValueFlag => nil -; op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] -; op="TAGGEDreturn" => nil -; op="CATCH" => -; [.,gs,data]:= expr -; (findThrow(gs,data,level,exitCount,ValueFlag) => true) where -; findThrow(gs,expr,level,exitCount,ValueFlag) == -; atom expr => nil -; expr is ["THROW", =gs,data] => true -; --this is pessimistic, but I know of no more accurate idea -; expr is ["SEQ",:l] => -; or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] -; or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] -; canReturn(data,level,exitCount,ValueFlag) -; op = "COND" => -; level = exitCount => -; or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] -; or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] -; for v in rest expr] -; op="IF" => -; expr is [.,a,b,c] -; if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then -; SAY "IF statement can not cause consequents to be executed" -; pp expr -; canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) -; or canReturn(c,level,exitCount,ValueFlag) -; --now we have an ordinary form -; atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] -; op is ["XLAM",args,bods] => -; and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] -; systemErrorHere '"canReturn" --for the time being - -(DEFUN |canReturn,findThrow| - (|gs| |expr| |level| |exitCount| |ValueFlag|) - (PROG (|ISTMP#1| |ISTMP#2| |data| |l|) - (RETURN - (SEQ (IF (ATOM |expr|) (EXIT NIL)) - (IF (AND (PAIRP |expr|) (EQ (QCAR |expr|) 'THROW) - (PROGN - (SPADLET |ISTMP#1| (QCDR |expr|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |gs|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |data| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT 'T)) - (IF (AND (PAIRP |expr|) (EQ (QCAR |expr|) 'SEQ) - (PROGN (SPADLET |l| (QCDR |expr|)) 'T)) - (EXIT (PROG (G168120) - (SPADLET G168120 NIL) - (RETURN - (DO ((G168126 NIL G168120) - (G168127 |l| (CDR G168127)) - (|u| NIL)) - ((OR G168126 (ATOM G168127) - (PROGN - (SETQ |u| (CAR G168127)) - NIL)) - G168120) - (SEQ (EXIT (SETQ G168120 - (OR G168120 - (|canReturn,findThrow| |gs| |u| - (PLUS |level| 1) |exitCount| - |ValueFlag|)))))))))) - (EXIT (PROG (G168134) - (SPADLET G168134 NIL) - (RETURN - (DO ((G168140 NIL G168134) - (G168141 (CDR |expr|) (CDR G168141)) - (|u| NIL)) - ((OR G168140 (ATOM G168141) - (PROGN (SETQ |u| (CAR G168141)) NIL)) - G168134) - (SEQ (EXIT (SETQ G168134 - (OR G168134 - (|canReturn,findThrow| |gs| - |u| |level| |exitCount| - |ValueFlag|))))))))))))) - -(DEFUN |canReturn| (|expr| |level| |exitCount| |ValueFlag|) - (PROG (|op| |count| |gs| |data| |a| |b| |ISTMP#3| |c| |ISTMP#1| - |args| |ISTMP#2| |bods|) - (declare (special |$convert2NewCompiler|)) - (RETURN - (SEQ (COND - ((ATOM |expr|) - (AND |ValueFlag| (BOOT-EQUAL |level| |exitCount|))) - ((BOOT-EQUAL (SPADLET |op| (CAR |expr|)) 'QUOTE) - (AND |ValueFlag| (BOOT-EQUAL |level| |exitCount|))) - ((MEMQ |op| '(WI MI)) - (|canReturn| (CADDR |expr|) |level| |count| |ValueFlag|)) - ((BOOT-EQUAL |op| '|TAGGEDexit|) - (COND - ((AND (PAIRP |expr|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |expr|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |count| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |data| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT (|canReturn| (CAR |data|) |level| |count| - (BOOT-EQUAL |count| |level|)))))) - ((AND (BOOT-EQUAL |level| |exitCount|) (NULL |ValueFlag|)) - NIL) - ((BOOT-EQUAL |op| 'SEQ) - (PROG (G168213) - (SPADLET G168213 NIL) - (RETURN - (DO ((G168219 NIL G168213) - (G168220 (CDR |expr|) (CDR G168220)) - (|u| NIL)) - ((OR G168219 (ATOM G168220) - (PROGN (SETQ |u| (CAR G168220)) NIL)) - G168213) - (SEQ (EXIT (SETQ G168213 - (OR G168213 - (|canReturn| |u| (PLUS |level| 1) - |exitCount| NIL))))))))) - ((BOOT-EQUAL |op| '|TAGGEDreturn|) NIL) - ((BOOT-EQUAL |op| 'CATCH) - (PROGN - (SPADLET |gs| (CADR |expr|)) - (SPADLET |data| (CADDR |expr|)) - (COND - ((|canReturn,findThrow| |gs| |data| |level| - |exitCount| |ValueFlag|) - 'T) - ('T - (|canReturn| |data| |level| |exitCount| |ValueFlag|))))) - ((BOOT-EQUAL |op| 'COND) - (COND - ((BOOT-EQUAL |level| |exitCount|) - (PROG (G168227) - (SPADLET G168227 NIL) - (RETURN - (DO ((G168233 NIL G168227) - (G168234 (CDR |expr|) (CDR G168234)) - (|u| NIL)) - ((OR G168233 (ATOM G168234) - (PROGN (SETQ |u| (CAR G168234)) NIL)) - G168227) - (SEQ (EXIT (SETQ G168227 - (OR G168227 - (|canReturn| (|last| |u|) - |level| |exitCount| - |ValueFlag|))))))))) - ('T - (PROG (G168241) - (SPADLET G168241 NIL) - (RETURN - (DO ((G168247 NIL G168241) - (G168248 (CDR |expr|) (CDR G168248)) - (|v| NIL)) - ((OR G168247 (ATOM G168248) - (PROGN (SETQ |v| (CAR G168248)) NIL)) - G168241) - (SEQ (EXIT (SETQ G168241 - (OR G168241 - (PROG (G168255) - (SPADLET G168255 NIL) - (RETURN - (DO - ((G168261 NIL - G168255) - (G168262 |v| - (CDR G168262)) - (|u| NIL)) - ((OR G168261 - (ATOM G168262) - (PROGN - (SETQ |u| - (CAR G168262)) - NIL)) - G168255) - (SEQ - (EXIT - (SETQ G168255 - (OR G168255 - (|canReturn| |u| - |level| |exitCount| - |ValueFlag|)))))))))))))))))) - ((BOOT-EQUAL |op| 'IF) - (PROGN - (AND (PAIRP |expr|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |expr|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T)))))))) - (COND - ((AND (NULL (|canReturn| |a| 0 0 'T)) - (NULL (AND (BOUNDP '|$convert2NewCompiler|) - |$convert2NewCompiler|))) - (SAY "IF statement can not cause consequents to be executed") - (|pp| |expr|))) - (OR (|canReturn| |a| |level| |exitCount| NIL) - (|canReturn| |b| |level| |exitCount| |ValueFlag|) - (|canReturn| |c| |level| |exitCount| |ValueFlag|)))) - ((ATOM |op|) - (PROG (G168269) - (SPADLET G168269 'T) - (RETURN - (DO ((G168275 NIL (NULL G168269)) - (G168276 |expr| (CDR G168276)) (|u| NIL)) - ((OR G168275 (ATOM G168276) - (PROGN (SETQ |u| (CAR G168276)) NIL)) - G168269) - (SEQ (EXIT (SETQ G168269 - (AND G168269 - (|canReturn| |u| |level| - |exitCount| |ValueFlag|))))))))) - ((AND (PAIRP |op|) (EQ (QCAR |op|) 'XLAM) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |args| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |bods| (QCAR |ISTMP#2|)) - 'T)))))) - (PROG (G168283) - (SPADLET G168283 'T) - (RETURN - (DO ((G168289 NIL (NULL G168283)) - (G168290 |expr| (CDR G168290)) (|u| NIL)) - ((OR G168289 (ATOM G168290) - (PROGN (SETQ |u| (CAR G168290)) NIL)) - G168283) - (SEQ (EXIT (SETQ G168283 - (AND G168283 - (|canReturn| |u| |level| - |exitCount| |ValueFlag|))))))))) - ('T (|systemErrorHere| "canReturn"))))))) - -;compList(l,m is ["List",mUnder],e) == -; markImport m -; markImport mUnder -; null l => [NIL,m,e] -; Tl:= [[.,mUnder,e]:= -; comp(x,mUnder,e) or return "failed" for i in 1.. for x in l] -; Tl="failed" => nil -; T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] - -(DEFUN |compList| (|l| |m| |e|) - (PROG (|LETTMP#1| |mUnder| |Tl| T$) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |m|) '|List|) (CAR |m|))) - (SPADLET |mUnder| (CADR |m|)) - (|markImport| |m|) - (|markImport| |mUnder|) - (COND - ((NULL |l|) (CONS NIL (CONS |m| (CONS |e| NIL)))) - ('T - (SPADLET |Tl| - (PROG (G168352) - (SPADLET G168352 NIL) - (RETURN - (DO ((|i| 1 (QSADD1 |i|)) - (G168362 |l| (CDR G168362)) - (|x| NIL)) - ((OR (ATOM G168362) - (PROGN - (SETQ |x| (CAR G168362)) - NIL)) - (NREVERSE0 G168352)) - (SEQ (EXIT - (SETQ G168352 - (CONS - (PROGN - (SPADLET |LETTMP#1| - (OR (|comp| |x| |mUnder| |e|) - (RETURN '|failed|))) - (SPADLET |mUnder| - (CADR |LETTMP#1|)) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|) - G168352)))))))) - (COND - ((BOOT-EQUAL |Tl| '|failed|) NIL) - ('T - (SPADLET T$ - (CONS (CONS 'LIST - (PROG (G168372) - (SPADLET G168372 NIL) - (RETURN - (DO - ((G168377 |Tl| - (CDR G168377)) - (T$ NIL)) - ((OR (ATOM G168377) - (PROGN - (SETQ T$ - (CAR G168377)) - NIL)) - (NREVERSE0 G168372)) - (SEQ - (EXIT - (SETQ G168372 - (CONS (CAR T$) - G168372)))))))) - (CONS (CONS '|List| - (CONS |mUnder| NIL)) - (CONS |e| NIL))))))))))))) - -;compVector(l,m is ["Vector",mUnder],e) == -; markImport m -; markImport mUnder -; null l => [$EmptyVector,m,e] -; Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] -; Tl="failed" => nil -; [["VECTOR",:[T.expr for T in Tl]],m,e] - -(DEFUN |compVector| (|l| |m| |e|) - (PROG (|LETTMP#1| |mUnder| |Tl|) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |m|) '|Vector|) (CAR |m|))) - (SPADLET |mUnder| (CADR |m|)) - (|markImport| |m|) - (|markImport| |mUnder|) - (COND - ((NULL |l|) - (CONS |$EmptyVector| (CONS |m| (CONS |e| NIL)))) - ('T - (SPADLET |Tl| - (PROG (G168422) - (SPADLET G168422 NIL) - (RETURN - (DO ((G168431 |l| (CDR G168431)) - (|x| NIL)) - ((OR (ATOM G168431) - (PROGN - (SETQ |x| (CAR G168431)) - NIL)) - (NREVERSE0 G168422)) - (SEQ (EXIT - (SETQ G168422 - (CONS - (PROGN - (SPADLET |LETTMP#1| - (OR (|comp| |x| |mUnder| |e|) - (RETURN '|failed|))) - (SPADLET |mUnder| - (CADR |LETTMP#1|)) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|) - G168422)))))))) - (COND - ((BOOT-EQUAL |Tl| '|failed|) NIL) - ('T - (CONS (CONS 'VECTOR - (PROG (G168441) - (SPADLET G168441 NIL) - (RETURN - (DO - ((G168446 |Tl| (CDR G168446)) - (T$ NIL)) - ((OR (ATOM G168446) - (PROGN - (SETQ T$ (CAR G168446)) - NIL)) - (NREVERSE0 G168441)) - (SEQ - (EXIT - (SETQ G168441 - (CONS (CAR T$) G168441)))))))) - (CONS |m| (CONS |e| NIL)))))))))))) - -;compColon([":",f,t],m,e) == -; $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e) -; --if inside an expression, ":" means to convert to m "on faith" -; f := markKillAll f -; $lhsOfColon: local:= f -; t:= -; t := markKillAll t -; atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' -; isDomainForm(t,e) and not $insideCategoryIfTrue => -; (if not MEMBER(t,getDomainsInScope e) then e:= addDomain(t,e); t) -; isDomainForm(t,e) or isCategoryForm(t,e) => t -; t is ["Mapping",m',:r] => t -; unknownTypeError t -; t -; if $insideCapsuleFunctionIfTrue then markDeclaredImport t -; f is ["LISTOF",:l] => -; (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) -; e:= -; f is [op,:argl] and not (t is ["Mapping",:.]) => -; --for MPOLY--replace parameters by formal arguments: RDJ 3/83 -; newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), -; [(x is [":",a,m] => a; x) for x in argl],t) -; signature:= -; ["Mapping",newTarget,: -; [(x is [":",a,m] => m; -; getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] -; put(op,"mode",signature,e) -; put(f,"mode",t,e) -; if not $bootStrapMode and $insideFunctorIfTrue and -; makeCategoryForm(t,e) is [catform,e] then -; e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) -; ["/throwAway",getmode(f,e),e] - -(DEFUN |compColon| (G168534 |m| |e|) - (PROG (|$lhsOfColon| |f| |t'| |m'| |r| |t| |l| |LETTMP#1| T$ |op| - |argl| |newTarget| |a| |signature| |ISTMP#1| |catform| - |ISTMP#2|) - (DECLARE (SPECIAL |$lhsOfColon|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G168534) '|:|) (CAR G168534))) - (SPADLET |f| (CADR G168534)) - (SPADLET |t| (CADDR G168534)) - (COND - ((BOOT-EQUAL |$insideExpressionIfTrue| 'T) - (|compPretend| - (CONS '|pretend| (CONS |f| (CONS |t| NIL))) |m| - |e|)) - ('T (SPADLET |f| (|markKillAll| |f|)) - (SPADLET |$lhsOfColon| |f|) - (SPADLET |t| - (PROGN - (SPADLET |t| (|markKillAll| |t|)) - (COND - ((AND (ATOM |t|) - (SPADLET |t'| - (|assoc| |t| - (|getDomainsInScope| |e|)))) - |t'|) - ((AND (|isDomainForm| |t| |e|) - (NULL |$insideCategoryIfTrue|)) - (COND - ((NULL (|member| |t| - (|getDomainsInScope| |e|))) - (SPADLET |e| (|addDomain| |t| |e|)))) - |t|) - ((OR (|isDomainForm| |t| |e|) - (|isCategoryForm| |t| |e|)) - |t|) - ((AND (PAIRP |t|) - (EQ (QCAR |t|) '|Mapping|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m'| (QCAR |ISTMP#1|)) - (SPADLET |r| (QCDR |ISTMP#1|)) - 'T)))) - |t|) - ('T (|unknownTypeError| |t|) |t|)))) - (COND - (|$insideCapsuleFunctionIfTrue| - (|markDeclaredImport| |t|))) - (COND - ((AND (PAIRP |f|) (EQ (QCAR |f|) 'LISTOF) - (PROGN (SPADLET |l| (QCDR |f|)) 'T)) - (DO ((G168585 |l| (CDR G168585)) (|x| NIL)) - ((OR (ATOM G168585) - (PROGN (SETQ |x| (CAR G168585)) NIL)) - NIL) - (SEQ (EXIT (SPADLET T$ - (PROGN - (SPADLET |LETTMP#1| - (|compColon| - (CONS '|:| - (CONS |x| (CONS |t| NIL))) - |m| |e|)) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|))))) - T$) - ('T - (SPADLET |e| - (COND - ((AND (PAIRP |f|) - (PROGN - (SPADLET |op| (QCAR |f|)) - (SPADLET |argl| (QCDR |f|)) - 'T) - (NULL - (AND (PAIRP |t|) - (EQ (QCAR |t|) '|Mapping|)))) - (SPADLET |newTarget| - (EQSUBSTLIST - (TAKE (|#| |argl|) - |$FormalMapVariableList|) - (PROG (G168602) - (SPADLET G168602 NIL) - (RETURN - (DO - ((G168614 |argl| - (CDR G168614)) - (|x| NIL)) - ((OR (ATOM G168614) - (PROGN - (SETQ |x| - (CAR G168614)) - NIL)) - (NREVERSE0 G168602)) - (SEQ - (EXIT - (SETQ G168602 - (CONS - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) - '|:|) - (PROGN - (SPADLET - |ISTMP#1| - (QCDR |x|)) - (AND - (PAIRP - |ISTMP#1|) - (PROGN - (SPADLET - |a| - (QCAR - |ISTMP#1|)) - (SPADLET - |ISTMP#2| - (QCDR - |ISTMP#1|)) - (AND - (PAIRP - |ISTMP#2|) - (EQ - (QCDR - |ISTMP#2|) - NIL) - (PROGN - (SPADLET - |m| - (QCAR - |ISTMP#2|)) - 'T)))))) - |a|) - ('T |x|)) - G168602))))))) - |t|)) - (SPADLET |signature| - (CONS '|Mapping| - (CONS |newTarget| - (PROG (G168631) - (SPADLET G168631 NIL) - (RETURN - (DO - ((G168643 |argl| - (CDR G168643)) - (|x| NIL)) - ((OR (ATOM G168643) - (PROGN - (SETQ |x| - (CAR G168643)) - NIL)) - (NREVERSE0 G168631)) - (SEQ - (EXIT - (SETQ G168631 - (CONS - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) - '|:|) - (PROGN - (SPADLET - |ISTMP#1| - (QCDR |x|)) - (AND - (PAIRP - |ISTMP#1|) - (PROGN - (SPADLET - |a| - (QCAR - |ISTMP#1|)) - (SPADLET - |ISTMP#2| - (QCDR - |ISTMP#1|)) - (AND - (PAIRP - |ISTMP#2|) - (EQ - (QCDR - |ISTMP#2|) - NIL) - (PROGN - (SPADLET - |m| - (QCAR - |ISTMP#2|)) - 'T)))))) - |m|) - ('T - (OR - (|getmode| |x| - |e|) - (|systemErrorHere| - "compColonOld")))) - G168631)))))))))) - (|put| |op| '|mode| |signature| |e|)) - ('T (|put| |f| '|mode| |t| |e|)))) - (COND - ((AND (NULL |$bootStrapMode|) - |$insideFunctorIfTrue| - (PROGN - (SPADLET |ISTMP#1| - (|makeCategoryForm| |t| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |catform| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |e| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |e| - (|put| |f| '|value| - (CONS (|genSomeVariable|) - (CONS |t| (CONS |$noEnv| NIL))) - |e|)))) - (CONS '|/throwAway| - (CONS (|getmode| |f| |e|) (CONS |e| NIL)))))))))))) - -;compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) - -(DEFUN |compConstruct| (|form| |m| |e|) - (PROG (T$) - (RETURN - (AND (SPADLET T$ (|compConstruct1| |form| |m| |e|)) - (|markConstruct| |form| T$))))) - -;compConstruct1(form is ["construct",:l],m,e) == -; y:= modeIsAggregateOf("List",m,e) => -; T:= compList(l,["List",CADR y],e) => convert(T,m) -; y:= modeIsAggregateOf("Vector",m,e) => -; T:= compVector(l,["Vector",CADR y],e) => convert(T,m) -; T:= compForm(form,m,e) => T -; for D in getDomainsInScope e repeat -; (y:=modeIsAggregateOf("List",D,e)) and -; (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => -; return T' -; (y:=modeIsAggregateOf("Vector",D,e)) and -; (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => -; return T' - -(DEFUN |compConstruct1| (|form| |m| |e|) - (PROG (|l| |y| T$ |T'|) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |form|) '|construct|) (CAR |form|))) - (SPADLET |l| (CDR |form|)) - (SEQ (COND - ((SPADLET |y| - (|modeIsAggregateOf| '|List| |m| |e|)) - (COND - ((SPADLET T$ - (|compList| |l| - (CONS '|List| - (CONS (CADR |y|) NIL)) - |e|)) - (EXIT (|convert| T$ |m|))))) - ((SPADLET |y| - (|modeIsAggregateOf| '|Vector| |m| |e|)) - (COND - ((SPADLET T$ - (|compVector| |l| - (CONS '|Vector| - (CONS (CADR |y|) NIL)) - |e|)) - (EXIT (|convert| T$ |m|))))) - ((SPADLET T$ (|compForm| |form| |m| |e|)) T$) - ('T - (DO ((G168706 (|getDomainsInScope| |e|) - (CDR G168706)) - (D NIL)) - ((OR (ATOM G168706) - (PROGN (SETQ D (CAR G168706)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND - (SPADLET |y| - (|modeIsAggregateOf| '|List| D - |e|)) - (SPADLET T$ - (|compList| |l| - (CONS '|List| - (CONS (CADR |y|) NIL)) - |e|)) - (SPADLET |T'| (|convert| T$ |m|))) - (RETURN |T'|)) - ((AND - (SPADLET |y| - (|modeIsAggregateOf| '|Vector| D - |e|)) - (SPADLET T$ - (|compVector| |l| - (CONS '|Vector| - (CONS (CADR |y|) NIL)) - |e|)) - (SPADLET |T'| (|convert| T$ |m|))) - (RETURN |T'|)))))))))))))) - -;compPretend(u := ["pretend",x,t],m,e) == -; t := markKillAll t -; m := markKillAll m -; e:= addDomain(t,e) -; T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil -; if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] -; T1:= [T.expr,t,T.env] -; t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<-- -; T':= coerce(T1,m) => -; warningMessage => -; stackWarning warningMessage -; markCompColonInside("@",T') -; markPretend(T1,T') -; nil - -(DEFUN |compPretend| (|u| |m| |e|) - (PROG (|x| |t| T$ |warningMessage| T1 |T'|) - (RETURN - (PROGN - (COND ((EQ (CAR |u|) '|pretend|) (CAR |u|))) - (SPADLET |x| (CADR |u|)) - (SPADLET |t| (CADDR |u|)) - (SPADLET |t| (|markKillAll| |t|)) - (SPADLET |m| (|markKillAll| |m|)) - (SPADLET |e| (|addDomain| |t| |e|)) - (SPADLET T$ - (OR (|comp| |x| |t| |e|) (|comp| |x| |$EmptyMode| |e|) - (RETURN NIL))) - (COND - ((BOOT-EQUAL (CADR T$) |t|) - (SPADLET |warningMessage| - (CONS '|pretend| - (CONS |t| - (CONS '| -- should replace by @| NIL)))))) - (SPADLET T1 (CONS (CAR T$) (CONS |t| (CONS (CADDR T$) NIL)))) - (COND - ((AND (BOOT-EQUAL |t| '$) (BOOT-EQUAL |m| '|Rep|)) - (|markPretend| T1 T1)) - ((SPADLET |T'| (|coerce| T1 |m|)) - (COND - (|warningMessage| (|stackWarning| |warningMessage|) - (|markCompColonInside| '@ |T'|)) - ('T (|markPretend| T1 |T'|)))) - ('T NIL)))))) - -;compAtSign(["@",x,m'],m,e) == -; m' := markKillAll m' -; m := markKillAll m -; e:= addDomain(m',e) -; T:= comp(x,m',e) or return nil -; coerce(T,m) - -(DEFUN |compAtSign| (G168753 |m| |e|) - (PROG (|x| |m'| T$) - (RETURN - (PROGN - (COND ((EQ (CAR G168753) '@) (CAR G168753))) - (SPADLET |x| (CADR G168753)) - (SPADLET |m'| (CADDR G168753)) - (SPADLET |m'| (|markKillAll| |m'|)) - (SPADLET |m| (|markKillAll| |m|)) - (SPADLET |e| (|addDomain| |m'| |e|)) - (SPADLET T$ (OR (|comp| |x| |m'| |e|) (RETURN NIL))) - (|coerce| T$ |m|))))) - -;compColonInside(x,m,e,m') == -; m' := markKillAll m' -; e:= addDomain(m',e) -; T:= comp(x,$EmptyMode,e) or return nil -; if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"] -; T:= [T.expr,m',T.env] -; m := markKillAll m -; T':= coerce(T,m) => -; warningMessage => -; stackWarning warningMessage -; markCompColonInside("@",T') -; stackWarning [":",m'," -- should replace by pretend"] -; markCompColonInside("pretend",T') -; nil - -(DEFUN |compColonInside| (|x| |m| |e| |m'|) - (PROG (|warningMessage| T$ |T'|) - (RETURN - (PROGN - (SPADLET |m'| (|markKillAll| |m'|)) - (SPADLET |e| (|addDomain| |m'| |e|)) - (SPADLET T$ (OR (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) - (COND - ((BOOT-EQUAL (CADR T$) |m'|) - (SPADLET |warningMessage| - (CONS '|:| - (CONS |m'| - (CONS '| -- should replace by ::| NIL)))))) - (SPADLET T$ (CONS (CAR T$) (CONS |m'| (CONS (CADDR T$) NIL)))) - (SPADLET |m| (|markKillAll| |m|)) - (COND - ((SPADLET |T'| (|coerce| T$ |m|)) - (COND - (|warningMessage| (|stackWarning| |warningMessage|) - (|markCompColonInside| '@ |T'|)) - ('T - (|stackWarning| - (CONS '|:| - (CONS |m'| - (CONS '| -- should replace by pretend| - NIL)))) - (|markCompColonInside| '|pretend| |T'|)))) - ('T NIL)))))) - -;resolve(min, mout) == -; din := markKillAll min -; dout := markKillAll mout -; din=$NoValueMode or dout=$NoValueMode => $NoValueMode -; dout=$EmptyMode => din -; STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94 -; STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94 -; din^=dout and (STRINGP din or STRINGP dout) => -; modeEqual(dout,$String) => dout -; modeEqual(din,$String) => nil -; mkUnion(din,dout) -; dout - -(DEFUN |resolve| (|min| |mout|) - (PROG (|din| |dout|) - (RETURN - (PROGN - (SPADLET |din| (|markKillAll| |min|)) - (SPADLET |dout| (|markKillAll| |mout|)) - (COND - ((OR (BOOT-EQUAL |din| |$NoValueMode|) - (BOOT-EQUAL |dout| |$NoValueMode|)) - |$NoValueMode|) - ((BOOT-EQUAL |dout| |$EmptyMode|) |din|) - ((AND (STRINGP |din|) (BOOT-EQUAL |dout| '(|Symbol|))) - |dout|) - ((AND (STRINGP |dout|) (BOOT-EQUAL |din| '(|Symbol|))) |din|) - ((AND (NEQUAL |din| |dout|) - (OR (STRINGP |din|) (STRINGP |dout|))) - (COND - ((|modeEqual| |dout| |$String|) |dout|) - ((|modeEqual| |din| |$String|) NIL) - ('T (|mkUnion| |din| |dout|)))) - ('T |dout|)))))) - -;coerce(T,m) == -; T := [T.expr,markKillAll T.mode,T.env] -; m := markKillAll m -; if not get(m, 'isLiteral,T.env) then markImport m -; $InteractiveMode => -; keyedSystemError("S2GE0016",['"coerce", -; '"function coerce called from the interpreter."]) -;--==================> changes <====================== -;--The following line is inappropriate for our needs::: -;--rplac(CADR T,substitute("$",$Rep,CADR T)) -; T' := coerce0(T,m) => T' -; T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env] -;--==================> changes <====================== -; coerce0(T,m) - -(DEFUN |coerce| (T$ |m|) - (PROG (|T'|) - (RETURN - (PROGN - (SPADLET T$ - (CONS (CAR T$) - (CONS (|markKillAll| (CADR T$)) - (CONS (CADDR T$) NIL)))) - (SPADLET |m| (|markKillAll| |m|)) - (COND - ((NULL (|get| |m| '|isLiteral| (CADDR T$))) - (|markImport| |m|))) - (COND - (|$InteractiveMode| - (|keyedSystemError| 'S2GE0016 - (CONS "coerce" - (CONS "function coerce called from the interpreter." - NIL)))) - ((SPADLET |T'| (|coerce0| T$ |m|)) |T'|) - ('T - (SPADLET T$ - (CONS (CAR T$) - (CONS (|fullSubstitute| '$ |$Representation| - (CADR T$)) - (CONS (CADDR T$) NIL)))) - (|coerce0| T$ |m|))))))) - -;coerce0(T,m) == -; T':= coerceEasy(T,m) => T' -; T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET) -; T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD) -; T':= coerceExtraHard(T,m) => T' -; T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil -; T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP) -; stackMessage fn(T.expr,T.mode,m) where -; -- if from from coerceable, this coerce was just a trial coercion -; -- from compFormWithModemap to filter through the modemaps -; fn(x,m1,m2) == -; ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", -; " to mode","%b",m2,"%d"] - -(DEFUN |coerce0,fn| (|x| |m1| |m2|) - (CONS '|Cannot coerce| - (CONS '|%b| - (CONS |x| - (CONS '|%d| - (CONS '|%l| - (CONS '| of mode| - (CONS '|%b| - (CONS |m1| - (CONS '|%d| - (CONS '|%l| - (CONS '| to mode| - (CONS '|%b| - (CONS |m2| - (CONS '|%d| NIL))))))))))))))) - -(DEFUN |coerce0| (T$ |m|) - (PROG (|T'|) - (RETURN - (COND - ((SPADLET |T'| (|coerceEasy| T$ |m|)) |T'|) - ((SPADLET |T'| (|coerceSubset| T$ |m|)) - (|markCoerce| T$ |T'| 'AUTOSUBSET)) - ((SPADLET |T'| (|coerceHard| T$ |m|)) - (|markCoerce| T$ |T'| 'AUTOHARD)) - ((SPADLET |T'| (|coerceExtraHard| T$ |m|)) |T'|) - ((OR (BOOT-EQUAL (CAR T$) '|$fromCoerceable$|) - (|isSomeDomainVariable| |m|)) - NIL) - ((SPADLET |T'| (|coerceRep| T$ |m|)) - (|markCoerce| T$ |T'| 'AUTOREP)) - ('T (|stackMessage| (|coerce0,fn| (CAR T$) (CADR T$) |m|))))))) - -;coerceSubset(T := [x,m,e],m') == -; m = $SmallInteger => -; m' = $Integer => [x,m',e] -; m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] -; nil -;-- pp [m, m'] -; isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] -; m is ['SubDomain,=m',:.] => [x,m',e] -; (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and -; -- obviously this is temporary -; eval substitute(x,"#1",pred) => [x,m',e] -; (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary -; and eval substitute(x,"*",pred) => -; [x,m',e] -; nil - -(DEFUN |coerceSubset| (T$ |m'|) - (PROG (|x| |m| |e| |r| |ISTMP#1| |pred|) - (RETURN - (PROGN - (SPADLET |x| (CAR T$)) - (SPADLET |m| (CADR T$)) - (SPADLET |e| (CADDR T$)) - (COND - ((BOOT-EQUAL |m| |$SmallInteger|) - (COND - ((BOOT-EQUAL |m'| |$Integer|) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ((OR (BOOT-EQUAL |m'| - (SPADLET |r| (|get| |x| '|range| |e|))) - (|isSubset| |r| |m'| |e|)) - (CONS |x| (CONS |r| (CONS |e| NIL)))) - ('T NIL))) - ((OR (|isSubset| |m| |m'| |e|) - (AND (BOOT-EQUAL |m| '|Rep|) (BOOT-EQUAL |m'| '$))) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|SubDomain|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |m'|)))) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ((AND (SPADLET |pred| - (LASSOC (|opOf| |m'|) - (|get| (|opOf| |m|) '|SubDomain| |e|))) - (INTEGERP |x|) (|eval| (MSUBST |x| '|#1| |pred|))) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ((AND (SPADLET |pred| - (|isSubset| |m'| (|maxSuperType| |m| |e|) |e|)) - (INTEGERP |x|) (|eval| (MSUBST |x| '* |pred|))) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ('T NIL)))))) - -;coerceRep(T,m) == -; md := T.mode -; atom md => nil -; CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or -; CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T -; nil - -(DEFUN |coerceRep| (T$ |m|) - (PROG (|md|) - (RETURN - (PROGN - (SPADLET |md| (CADR T$)) - (COND - ((ATOM |md|) NIL) - ((OR (AND (CONTAINED '|Rep| |md|) - (BOOT-EQUAL (MSUBST '$ '|Rep| |md|) |m|)) - (AND (CONTAINED '|Rep| |m|) - (BOOT-EQUAL (MSUBST '$ '|Rep| |m|) |md|))) - T$) - ('T NIL)))))) - -;--- GET rid of XLAMs -;spadCompileOrSetq form == -; --bizarre hack to take account of the existence of "known" functions -; --good for performance (LISPLLIB size, BPI size, NILSEC) -; [nam,[lam,vl,body]] := form -; CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] -; if vl is [:vl',E] and body is [nam',: =vl'] then -; LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] -; sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] -; else if (ATOM body or and/[ATOM x for x in body]) -; and vl is [:vl',E] and not CONTAINED(E,body) then -; macform := ['XLAM,vl',body] -; LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] -; sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] -; $insideCapsuleFunctionIfTrue => first COMP LIST form -; compileConstructor form - -(DEFUN |spadCompileOrSetq| (|form|) - (PROG (|nam| |lam| |vl| |body| |nam'| |ISTMP#1| E |vl'| |macform|) - (RETURN - (SEQ (PROGN - (SPADLET |nam| (CAR |form|)) - (SPADLET |lam| (CAADR |form|)) - (SPADLET |vl| (CADADR |form|)) - (SPADLET |body| (CAR (CDDADR |form|))) - (COND - ((CONTAINED (INTERN " " "BOOT") |body|) - (|sayBrightly| - (CONS " " - (APPEND (|bright| |nam|) - (CONS " not compiled" - NIL))))) - ('T - (COND - ((AND (PAIRP |vl|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |vl|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET E (QCAR |ISTMP#1|)) - (SPADLET |vl'| (QCDR |ISTMP#1|)) - 'T) - (PROGN (SPADLET |vl'| (NREVERSE |vl'|)) 'T) - (PAIRP |body|) - (PROGN (SPADLET |nam'| (QCAR |body|)) 'T) - (EQUAL (QCDR |body|) |vl'|)) - (|LAM,EVALANDFILEACTQ| - (CONS 'PUT - (CONS (MKQ |nam|) - (CONS (MKQ '|SPADreplace|) - (CONS (MKQ |nam'|) NIL))))) - (|sayBrightly| - (CONS " " - (APPEND (|bright| |nam|) - (CONS - "is replaced by" - (|bright| |nam'|)))))) - ((AND (OR (ATOM |body|) - (PROG (G168859) - (SPADLET G168859 'T) - (RETURN - (DO ((G168865 NIL (NULL G168859)) - (G168866 |body| (CDR G168866)) - (|x| NIL)) - ((OR G168865 (ATOM G168866) - (PROGN - (SETQ |x| (CAR G168866)) - NIL)) - G168859) - (SEQ (EXIT - (SETQ G168859 - (AND G168859 (ATOM |x|))))))))) - (PAIRP |vl|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |vl|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET E (QCAR |ISTMP#1|)) - (SPADLET |vl'| (QCDR |ISTMP#1|)) - 'T) - (PROGN (SPADLET |vl'| (NREVERSE |vl'|)) 'T) - (NULL (CONTAINED E |body|))) - (SPADLET |macform| - (CONS 'XLAM (CONS |vl'| (CONS |body| NIL)))) - (|LAM,EVALANDFILEACTQ| - (CONS 'PUT - (CONS (MKQ |nam|) - (CONS (MKQ '|SPADreplace|) - (CONS (MKQ |macform|) NIL))))) - (|sayBrightly| - (CONS " " - (APPEND (|bright| |nam|) - (CONS - "is replaced by" - (|bright| |body|)))))) - ('T NIL)) - (COND - (|$insideCapsuleFunctionIfTrue| - (CAR (COMP (LIST |form|)))) - ('T (|compileConstructor| |form|)))))))))) - -;coerceHard(T,m) == -; $e: local:= T.env -; m':= T.mode -; STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] -; modeEqual(m',m) or -; (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and -; modeEqual(m'',m) or -; (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and -; modeEqual(m'',m') => [T.expr,m,T.env] -; STRINGP T.expr and T.expr=m => [T.expr,m,$e] -; isCategoryForm(m,$e) => -; $bootStrapMode = true => [T.expr,m,$e] -; extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] -; nil -; nil - -(DEFUN |coerceHard| (T$ |m|) - (PROG (|$e| |m'| |ISTMP#1| |ISTMP#2| |m''|) - (DECLARE (SPECIAL |$e| |$bootStrapMode| |$String|)) - (RETURN - (PROGN - (SPADLET |$e| (CADDR T$)) - (SPADLET |m'| (CADR T$)) - (COND - ((AND (STRINGP |m'|) (|modeEqual| |m| |$String|)) - (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) - ((OR (|modeEqual| |m'| |m|) - (AND (OR (PROGN - (SPADLET |ISTMP#1| - (|get| |m'| '|value| |$e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m''| (QCAR |ISTMP#1|)) - 'T))) - (PROGN - (SPADLET |ISTMP#1| (|getmode| |m'| |$e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |m''| - (QCAR |ISTMP#2|)) - 'T)))))) - (|modeEqual| |m''| |m|)) - (AND (OR (PROGN - (SPADLET |ISTMP#1| (|get| |m| '|value| |$e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m''| (QCAR |ISTMP#1|)) - 'T))) - (PROGN - (SPADLET |ISTMP#1| (|getmode| |m| |$e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |m''| - (QCAR |ISTMP#2|)) - 'T)))))) - (|modeEqual| |m''| |m'|))) - (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))) - ((AND (STRINGP (CAR T$)) (BOOT-EQUAL (CAR T$) |m|)) - (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) - ((|isCategoryForm| |m| |$e|) - (COND - ((BOOT-EQUAL |$bootStrapMode| 'T) - (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) - ((|extendsCategoryForm| (CAR T$) (CADR T$) |m|) - (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) - ('T NIL))) - ('T NIL)))))) - -;coerceExtraHard(T is [x,m',e],m) == -; T':= autoCoerceByModemap(T,m) => T' -; isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and -; MEMBER(t,l) and (T':= autoCoerceByModemap(T,t)) and -; (T'':= coerce(T',m)) => T'' -; m' is ['Record,:.] and m = $Expression => -; [['coerceRe2E,x,['ELT,COPY m',0]],m,e] -; nil - -(DEFUN |coerceExtraHard| (T$ |m|) - (PROG (|x| |m'| |e| |ISTMP#1| |l| |t| |T'| |T''|) - (declare (special |$Expression|)) - (RETURN - (PROGN - (SPADLET |x| (CAR T$)) - (SPADLET |m'| (CADR T$)) - (SPADLET |e| (CADDR T$)) - (COND - ((SPADLET |T'| (|autoCoerceByModemap| T$ |m|)) |T'|) - ((AND (PROGN - (SPADLET |ISTMP#1| (|isUnionMode| |m'| |e|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Union|) - (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T))) - (SPADLET |t| (|hasType| |x| |e|)) (|member| |t| |l|) - (SPADLET |T'| (|autoCoerceByModemap| T$ |t|)) - (SPADLET |T''| (|coerce| |T'| |m|))) - |T''|) - ((AND (PAIRP |m'|) (EQ (QCAR |m'|) '|Record|) - (BOOT-EQUAL |m| |$Expression|)) - (CONS (CONS '|coerceRe2E| - (CONS |x| - (CONS (CONS 'ELT - (CONS (COPY |m'|) (CONS 0 NIL))) - NIL))) - (CONS |m| (CONS |e| NIL)))) - ('T NIL)))))) - -;compCoerce(u := ["::",x,m'],m,e) == -; m' := markKillAll m' -; e:= addDomain(m',e) -; m := markKillAll m -;--------------> new code <------------------- -; T:= compCoerce1(x,m',e) => coerce(T,m) -; T := comp(x,$EmptyMode,e) or return nil -; T.mode = $SmallInteger and -; MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) => -; compCoerce(["::",["::",x,$Integer],m'],m,e) -;--------------> new code <------------------- -; getmode(m',e) is ["Mapping",["UnionCategory",:l]] => -; l := [markKillAll x for x in l] -; T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil -; coerce([T.expr,m',T.env],m) - -(DEFUN |compCoerce| (|u| |m| |e|) - (PROG (|x| |m'| |ISTMP#1| |ISTMP#2| |ISTMP#3| |l| T$) - (declare (special |$Integer| |$SmallInteger| |$EmptyMode|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |u|) '|::|) (CAR |u|))) - (SPADLET |x| (CADR |u|)) - (SPADLET |m'| (CADDR |u|)) - (SPADLET |m'| (|markKillAll| |m'|)) - (SPADLET |e| (|addDomain| |m'| |e|)) - (SPADLET |m| (|markKillAll| |m|)) - (COND - ((SPADLET T$ (|compCoerce1| |x| |m'| |e|)) - (|coerce| T$ |m|)) - ('T - (SPADLET T$ - (OR (|comp| |x| |$EmptyMode| |e|) - (RETURN NIL))) - (COND - ((AND (BOOT-EQUAL (CADR T$) |$SmallInteger|) - (MEMQ (|opOf| |m|) - '(|NonNegativeInteger| |PositiveInteger|))) - (|compCoerce| - (CONS '|::| - (CONS (CONS '|::| - (CONS |x| (CONS |$Integer| NIL))) - (CONS |m'| NIL))) - |m| |e|)) - ((PROGN - (SPADLET |ISTMP#1| (|getmode| |m'| |e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) - '|UnionCategory|) - (PROGN - (SPADLET |l| (QCDR |ISTMP#3|)) - 'T))))))) - (SPADLET |l| - (PROG (G169011) - (SPADLET G169011 NIL) - (RETURN - (DO ((G169016 |l| (CDR G169016)) - (|x| NIL)) - ((OR (ATOM G169016) - (PROGN - (SETQ |x| (CAR G169016)) - NIL)) - (NREVERSE0 G169011)) - (SEQ (EXIT - (SETQ G169011 - (CONS (|markKillAll| |x|) - G169011)))))))) - (SPADLET T$ - (OR (PROG (G169022) - (SPADLET G169022 NIL) - (RETURN - (DO - ((G169028 NIL G169022) - (G169029 |l| (CDR G169029)) - (|m1| NIL)) - ((OR G169028 (ATOM G169029) - (PROGN - (SETQ |m1| (CAR G169029)) - NIL)) - G169022) - (SEQ - (EXIT - (SETQ G169022 - (OR G169022 - (|compCoerce1| |x| |m1| |e|)))))))) - (RETURN NIL))) - (|coerce| - (CONS (CAR T$) - (CONS |m'| (CONS (CADDR T$) NIL))) - |m|)))))))))) - -;compCoerce1(x,m',e) == -; T:= comp(x,m',e) -; if null T then T := comp(x,$EmptyMode,e) -; null T => return nil -; m1:= -; STRINGP T.mode => $String -; T.mode -; m':=resolve(m1,m') -; T:=[T.expr,m1,T.env] -; T':= coerce(T,m') => T' -; T':= coerceByModemap(T,m') => T' -; pred:=isSubset(m',T.mode,e) => -; gg:=GENSYM() -; pred:= substitute(gg,"*",pred) -; code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] -; [code,m',T.env] - -(DEFUN |compCoerce1| (|x| |m'| |e|) - (PROG (|m1| T$ |T'| |gg| |pred| |code|) - (declare (special |$String| |$EmptyMode|)) - (RETURN - (PROGN - (SPADLET T$ (|comp| |x| |m'| |e|)) - (COND ((NULL T$) (SPADLET T$ (|comp| |x| |$EmptyMode| |e|)))) - (COND - ((NULL T$) (RETURN NIL)) - ('T - (SPADLET |m1| - (COND - ((STRINGP (CADR T$)) |$String|) - ('T (CADR T$)))) - (SPADLET |m'| (|resolve| |m1| |m'|)) - (SPADLET T$ - (CONS (CAR T$) (CONS |m1| (CONS (CADDR T$) NIL)))) - (COND - ((SPADLET |T'| (|coerce| T$ |m'|)) |T'|) - ((SPADLET |T'| (|coerceByModemap| T$ |m'|)) |T'|) - ((SPADLET |pred| (|isSubset| |m'| (CADR T$) |e|)) - (PROGN - (SPADLET |gg| (GENSYM)) - (SPADLET |pred| (MSUBST |gg| '* |pred|)) - (SPADLET |code| - (CONS 'PROG1 - (CONS (CONS 'LET - (CONS |gg| (CONS (CAR T$) NIL))) - (CONS - (CONS '|check-subtype| - (CONS |pred| - (CONS (MKQ |m'|) - (CONS |gg| NIL)))) - NIL)))) - (CONS |code| (CONS |m'| (CONS (CADDR T$) NIL)))))))))))) - -;coerceByModemap([x,m,e],m') == -;--+ modified 6/27 for new runtime system -; u:= -; [modemap -; for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, -; s] and (modeEqual(t,m') or isSubset(t,m',e)) -; and (modeEqual(s,m) or isSubset(m,s,e))] or return nil -; mm:=first u -- patch for non-trival conditons -; fn := genDeltaEntry ['coerce,:mm] -; T := [["call",fn,x],m',e] -; markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil) - -(DEFUN |coerceByModemap| (G169091 |m'|) - (PROG (|x| |m| |e| |map| |cexpr| |ISTMP#1| |t| |ISTMP#2| |s| |u| |mm| - |fn| T$) - (RETURN - (SEQ (PROGN - (SPADLET |x| (CAR G169091)) - (SPADLET |m| (CADR G169091)) - (SPADLET |e| (CADDR G169091)) - (SPADLET |u| - (OR (PROG (G169118) - (SPADLET G169118 NIL) - (RETURN - (DO ((G169125 - (|getModemapList| '|coerce| 1 |e|) - (CDR G169125)) - (|modemap| NIL)) - ((OR (ATOM G169125) - (PROGN - (SETQ |modemap| (CAR G169125)) - NIL) - (PROGN - (PROGN - (SPADLET |map| (CAR |modemap|)) - (SPADLET |cexpr| - (CADR |modemap|)) - |modemap|) - NIL)) - (NREVERSE0 G169118)) - (SEQ (EXIT - (COND - ((AND (PAIRP |map|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |map|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |t| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |s| - (QCAR |ISTMP#2|)) - 'T))))) - (OR (|modeEqual| |t| |m'|) - (|isSubset| |t| |m'| |e|)) - (OR (|modeEqual| |s| |m|) - (|isSubset| |m| |s| |e|))) - (SETQ G169118 - (CONS |modemap| G169118))))))))) - (RETURN NIL))) - (SPADLET |mm| (CAR |u|)) - (SPADLET |fn| (|genDeltaEntry| (CONS '|coerce| |mm|))) - (SPADLET T$ - (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) - (CONS |m'| (CONS |e| NIL)))) - (|markCoerceByModemap| |x| |m| |m'| - (|markCallCoerce| |x| |m'| T$) NIL)))))) - -;autoCoerceByModemap([x,source,e],target) == -; u:= -; [cexpr -; for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ -; .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil -; fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil -; markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true) - -(DEFUN |autoCoerceByModemap| (G169173 |target|) - (PROG (|x| |source| |e| |map| |cexpr| |ISTMP#1| |t| |ISTMP#2| |s| |u| - |cond| |selfn| |fn|) - (RETURN - (SEQ (PROGN - (SPADLET |x| (CAR G169173)) - (SPADLET |source| (CADR G169173)) - (SPADLET |e| (CADDR G169173)) - (SPADLET |u| - (OR (PROG (G169203) - (SPADLET G169203 NIL) - (RETURN - (DO ((G169210 - (|getModemapList| '|autoCoerce| 1 - |e|) - (CDR G169210)) - (|modemap| NIL)) - ((OR (ATOM G169210) - (PROGN - (SETQ |modemap| (CAR G169210)) - NIL) - (PROGN - (PROGN - (SPADLET |map| (CAR |modemap|)) - (SPADLET |cexpr| - (CADR |modemap|)) - |modemap|) - NIL)) - (NREVERSE0 G169203)) - (SEQ (EXIT - (COND - ((AND (PAIRP |map|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |map|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |t| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |s| - (QCAR |ISTMP#2|)) - 'T))))) - (|modeEqual| |t| |target|) - (|modeEqual| |s| |source|)) - (SETQ G169203 - (CONS |cexpr| G169203))))))))) - (RETURN NIL))) - (SPADLET |fn| - (OR (PROG (G169217) - (SPADLET G169217 NIL) - (RETURN - (DO ((G169225 NIL G169217) - (G169226 |u| (CDR G169226)) - (G169168 NIL)) - ((OR G169225 (ATOM G169226) - (PROGN - (SETQ G169168 (CAR G169226)) - NIL) - (PROGN - (PROGN - (SPADLET |cond| - (CAR G169168)) - (SPADLET |selfn| - (CADR G169168)) - G169168) - NIL)) - G169217) - (SEQ (EXIT - (COND - ((BOOT-EQUAL |cond| 'T) - (SETQ G169217 - (OR G169217 |selfn|))))))))) - (RETURN NIL))) - (|markCoerceByModemap| |x| |source| |target| - (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) - (CONS |target| (CONS |e| NIL))) - 'T)))))) - -;--====================================================================== -;-- From compiler.boot -;--====================================================================== -;--comp3x(x,m,$e) == -;comp3(x,m,$e) == -; --returns a Triple or %else nil to signalcan't do' -; $e:= addDomain(m,$e) -; e:= $e --for debugging purposes -; m is ["Mapping",:.] => compWithMappingMode(x,m,e) -; m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) -; STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) -; ^x or atom x => compAtom(x,m,e) -; op:= first x -; getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u -; op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) -; op=":" => compColon(x,m,e) -; op="::" => compCoerce(x,m,e) -; not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => -; compTypeOf(x,m,e) -; ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)-- -; x is ['PART,:.] => compPART(x,m,e) -; ---------------------------------- -; t:= qt(14,compExpression(x,m,e)) -; t is [x',m',e'] and not MEMBER(m',getDomainsInScope e') => -; qt(15,[x',m',addDomain(m',e')]) -; qt(16,t) - -(DEFUN |comp3| (|x| |m| |$e|) - (DECLARE (SPECIAL |$e|)) - (PROG (|e| |a| |op| |ml| |u| |sig| |varlist| |ISTMP#3| |body| |t| - |x'| |ISTMP#1| |m'| |ISTMP#2| |e'|) - (declare (special |$insideCompTypeOf| |$e|)) - (RETURN - (PROGN - (SPADLET |$e| (|addDomain| |m| |$e|)) - (SPADLET |e| |$e|) - (COND - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Mapping|)) - (|compWithMappingMode| |x| |m| |e|)) - ((AND (PAIRP |m|) (EQ (QCAR |m|) 'QUOTE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) - (COND - ((BOOT-EQUAL |x| |a|) - (CONS |x| (CONS |m| (CONS |$e| NIL)))) - ('T NIL))) - ((STRINGP |m|) - (COND - ((ATOM |x|) - (COND - ((OR (BOOT-EQUAL |m| |x|) - (BOOT-EQUAL |m| (STRINGIMAGE |x|))) - (CONS |m| (CONS |m| (CONS |e| NIL)))) - ('T NIL))) - ('T NIL))) - ((OR (NULL |x|) (ATOM |x|)) (|compAtom| |x| |m| |e|)) - ('T (SPADLET |op| (CAR |x|)) - (COND - ((AND (PROGN - (SPADLET |ISTMP#1| (|getmode| |op| |e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|) - (PROGN (SPADLET |ml| (QCDR |ISTMP#1|)) 'T))) - (SPADLET |u| (|applyMapping| |x| |m| |e| |ml|))) - |u|) - ((AND (PAIRP |op|) (EQ (QCAR |op|) 'KAPPA) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |sig| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |varlist| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |body| (QCAR |ISTMP#3|)) - 'T)))))))) - (|compApply| |sig| |varlist| |body| (CDR |x|) |m| |e|)) - ((BOOT-EQUAL |op| '|:|) (|compColon| |x| |m| |e|)) - ((BOOT-EQUAL |op| '|::|) (|compCoerce| |x| |m| |e|)) - ((AND (NULL (BOOT-EQUAL |$insideCompTypeOf| 'T)) - (|stringPrefix?| "TypeOf" (PNAME |op|))) - (|compTypeOf| |x| |m| |e|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PART)) - (|compPART| |x| |m| |e|)) - ('T (SPADLET |t| (|qt| 14 (|compExpression| |x| |m| |e|))) - (COND - ((AND (PAIRP |t|) - (PROGN - (SPADLET |x'| (QCAR |t|)) - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m'| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |e'| (QCAR |ISTMP#2|)) - 'T))))) - (NULL (|member| |m'| (|getDomainsInScope| |e'|)))) - (|qt| 15 - (CONS |x'| - (CONS |m'| - (CONS (|addDomain| |m'| |e'|) NIL))))) - ('T (|qt| 16 |t|))))))))))) - -;yyyyy x == x - -(DEFUN |yyyyy| (|x|) |x|) - -;compExpression(x,m,e) == -; $insideExpressionIfTrue: local:= true -; if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x -; x := compRenameOp x -; atom first x and (fn:= GET(first x,"SPECIAL")) => -; FUNCALL(fn,x,m,e) -; compForm(x,m,e) - -(DEFUN |compExpression| (|x| |m| |e|) - (PROG (|$insideExpressionIfTrue| |ISTMP#1| |ISTMP#2| |ISTMP#3| - |ISTMP#4| |w| |ISTMP#5| |ISTMP#6| |ISTMP#7| |ISTMP#8| B - |ISTMP#9| |ISTMP#10| |ISTMP#11| |ISTMP#12| |ISTMP#13| - |ISTMP#14| |ISTMP#15| |ISTMP#16| |ISTMP#17| |ISTMP#18| |l| - |fn|) - (DECLARE (SPECIAL |$insideExpressionIfTrue|)) - (RETURN - (PROGN - (SPADLET |$insideExpressionIfTrue| 'T) - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) 'PART) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |w| - (QCAR |ISTMP#4|)) - 'T))))))) - (PROGN - (SPADLET |ISTMP#5| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#5|) - (PROGN - (SPADLET |ISTMP#6| (QCAR |ISTMP#5|)) - (AND (PAIRP |ISTMP#6|) - (PROGN - (SPADLET |ISTMP#7| - (QCAR |ISTMP#6|)) - (AND (PAIRP |ISTMP#7|) - (EQ (QCAR |ISTMP#7|) '|elt|) - (PROGN - (SPADLET |ISTMP#8| - (QCDR |ISTMP#7|)) - (AND (PAIRP |ISTMP#8|) - (PROGN - (SPADLET B - (QCAR |ISTMP#8|)) - (SPADLET |ISTMP#9| - (QCDR |ISTMP#8|)) - (AND (PAIRP |ISTMP#9|) - (EQ (QCDR |ISTMP#9|) NIL) - (EQ (QCAR |ISTMP#9|) - '|new|))))))) - (PROGN - (SPADLET |ISTMP#10| - (QCDR |ISTMP#6|)) - (AND (PAIRP |ISTMP#10|) - (PROGN - (SPADLET |ISTMP#11| - (QCAR |ISTMP#10|)) - (AND (PAIRP |ISTMP#11|) - (EQ (QCAR |ISTMP#11|) 'PART) - (PROGN - (SPADLET |ISTMP#12| - (QCDR |ISTMP#11|)) - (AND (PAIRP |ISTMP#12|) - (PROGN - (SPADLET |ISTMP#13| - (QCDR |ISTMP#12|)) - (AND (PAIRP |ISTMP#13|) - (EQ (QCDR |ISTMP#13|) - NIL) - (PROGN - (SPADLET |ISTMP#14| - (QCAR |ISTMP#13|)) - (AND - (PAIRP |ISTMP#14|) - (EQ - (QCAR |ISTMP#14|) - '|#|) - (PROGN - (SPADLET - |ISTMP#15| - (QCDR - |ISTMP#14|)) - (AND - (PAIRP - |ISTMP#15|) - (EQ - (QCDR - |ISTMP#15|) - NIL) - (PROGN - (SPADLET - |ISTMP#16| - (QCAR - |ISTMP#15|)) - (AND - (PAIRP - |ISTMP#16|) - (EQ - (QCAR - |ISTMP#16|) - 'PART) - (PROGN - (SPADLET - |ISTMP#17| - (QCDR - |ISTMP#16|)) - (AND - (PAIRP - |ISTMP#17|) - (PROGN - (SPADLET - |ISTMP#18| - (QCDR - |ISTMP#17|)) - (AND - (PAIRP - |ISTMP#18|) - (EQ - (QCDR - |ISTMP#18|) - NIL) - (PROGN - (SPADLET - |l| - (QCAR - |ISTMP#18|)) - 'T)))))))))))))))))))))))))) - (|yyyyy| |x|))) - (SPADLET |x| (|compRenameOp| |x|)) - (COND - ((AND (ATOM (CAR |x|)) - (SPADLET |fn| (GETL (CAR |x|) 'SPECIAL))) - (FUNCALL |fn| |x| |m| |e|)) - ('T (|compForm| |x| |m| |e|))))))) - -;compRenameOp x == ----------> new 12/3/94 -; x is [op,:r] and op is ['PART,.,op1] => -; [op1,:r] -; x - -(DEFUN |compRenameOp| (|x|) - (PROG (|op| |r| |ISTMP#1| |ISTMP#2| |op1|) - (RETURN - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |r| (QCDR |x|)) - 'T) - (PAIRP |op|) (EQ (QCAR |op|) 'PART) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |op1| (QCAR |ISTMP#2|)) - 'T)))))) - (CONS |op1| |r|)) - ('T |x|))))) - -;compCase(["case",x,m1],m,e) == -; m' := markKillAll m1 -; e:= addDomain(m',e) -; T:= compCase1(x,m',e) => coerce(T,m) -; nil - -(DEFUN |compCase| (G169646 |m| |e|) - (PROG (|x| |m1| |m'| T$) - (RETURN - (PROGN - (COND ((EQ (CAR G169646) '|case|) (CAR G169646))) - (SPADLET |x| (CADR G169646)) - (SPADLET |m1| (CADDR G169646)) - (SPADLET |m'| (|markKillAll| |m1|)) - (SPADLET |e| (|addDomain| |m'| |e|)) - (COND - ((SPADLET T$ (|compCase1| |x| |m'| |e|)) (|coerce| T$ |m|)) - ('T NIL)))))) - -;compCase1(x,m,e) == -; x1 := -; x is ['PART,.,a] => a -; x -; [x',m',e']:= comp(x1,$EmptyMode,e) or return nil -; if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true) -; -------------------------------------------------------------------------- -; m' isnt ['Union,:r] => nil -; mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e') -; | map is [.,.,s,t] and modeEqual(t,m) and -; (modeEqual(s,m') or switchMode and modeEqual(s,"$"))] -; or return nil -; u := [cexpr for [.,cexpr] in mml] -; fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil -; tag := genCaseTag(m, r, 1) or return nil -; x1 := -; switchMode => markRepper('rep, x) -; x -; markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e'])) - -(DEFUN |compCase1| (|x| |m| |e|) - (PROG (|a| |LETTMP#1| |x'| |e'| |m'| |switchMode| |r| |map| |ISTMP#1| - |ISTMP#2| |s| |ISTMP#3| |t| |mml| |cexpr| |u| |cond| - |selfn| |fn| |tag| |x1|) - (declare (special |$Boolean| |$EmptyMode|)) - (RETURN - (SEQ (PROGN - (SPADLET |x1| - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PART) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#2|)) - 'T)))))) - |a|) - ('T |x|))) - (SPADLET |LETTMP#1| - (OR (|comp| |x1| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |x'| (CAR |LETTMP#1|)) - (SPADLET |m'| (CADR |LETTMP#1|)) - (SPADLET |e'| (CADDR |LETTMP#1|)) - (COND - ((BOOT-EQUAL |m'| '$) - (AND (SPADLET |m'| (IFCAR (|get| '|Rep| '|value| |e|))) - (SPADLET |switchMode| 'T)))) - (COND - ((NULL (AND (PAIRP |m'|) (EQ (QCAR |m'|) '|Union|) - (PROGN (SPADLET |r| (QCDR |m'|)) 'T))) - NIL) - ('T - (SPADLET |mml| - (OR (PROG (G169728) - (SPADLET G169728 NIL) - (RETURN - (DO ((G169735 - (|getModemapList| '|case| 2 - |e'|) - (CDR G169735)) - (|mm| NIL)) - ((OR (ATOM G169735) - (PROGN - (SETQ |mm| (CAR G169735)) - NIL) - (PROGN - (PROGN - (SPADLET |map| (CAR |mm|)) - (SPADLET |cexpr| - (CADR |mm|)) - |mm|) - NIL)) - (NREVERSE0 G169728)) - (SEQ - (EXIT - (COND - ((AND (PAIRP |map|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |map|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |s| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) - NIL) - (PROGN - (SPADLET |t| - (QCAR |ISTMP#3|)) - 'T))))))) - (|modeEqual| |t| |m|) - (OR (|modeEqual| |s| |m'|) - (AND |switchMode| - (|modeEqual| |s| '$)))) - (SETQ G169728 - (CONS |mm| G169728))))))))) - (RETURN NIL))) - (SPADLET |u| - (PROG (G169747) - (SPADLET G169747 NIL) - (RETURN - (DO ((G169753 |mml| (CDR G169753)) - (G169713 NIL)) - ((OR (ATOM G169753) - (PROGN - (SETQ G169713 - (CAR G169753)) - NIL) - (PROGN - (PROGN - (SPADLET |cexpr| - (CADR G169713)) - G169713) - NIL)) - (NREVERSE0 G169747)) - (SEQ (EXIT - (SETQ G169747 - (CONS |cexpr| G169747)))))))) - (SPADLET |fn| - (OR (PROG (G169760) - (SPADLET G169760 NIL) - (RETURN - (DO ((G169768 NIL G169760) - (G169769 |u| (CDR G169769)) - (G169716 NIL)) - ((OR G169768 (ATOM G169769) - (PROGN - (SETQ G169716 - (CAR G169769)) - NIL) - (PROGN - (PROGN - (SPADLET |cond| - (CAR G169716)) - (SPADLET |selfn| - (CADR G169716)) - G169716) - NIL)) - G169760) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |cond| 'T) - (SETQ G169760 - (OR G169760 |selfn|))))))))) - (RETURN NIL))) - (SPADLET |tag| - (OR (|genCaseTag| |m| |r| 1) (RETURN NIL))) - (SPADLET |x1| - (COND - (|switchMode| (|markRepper| '|rep| |x|)) - ('T |x|))) - (|markCase| |x| |tag| - (|markCaseWas| |x1| - (CONS (CONS '|call| - (CONS |fn| (CONS |x'| NIL))) - (CONS |$Boolean| (CONS |e'| NIL)))))))))))) - -;genCaseTag(t,l,n) == -; l is [x, :l] => -; x = t => -; STRINGP x => INTERN x -; INTERN STRCONC("value", STRINGIMAGE n) -; x is ["::",=t,:.] => t -; STRINGP x => genCaseTag(t, l, n) -; genCaseTag(t, l, n + 1) -; nil - -(DEFUN |genCaseTag| (|t| |l| |n|) - (PROG (|x| |ISTMP#1|) - (RETURN - (COND - ((AND (PAIRP |l|) - (PROGN - (SPADLET |x| (QCAR |l|)) - (SPADLET |l| (QCDR |l|)) - 'T)) - (COND - ((BOOT-EQUAL |x| |t|) - (COND - ((STRINGP |x|) (INTERN |x|)) - ('T (INTERN (STRCONC '|value| (STRINGIMAGE |n|)))))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|::|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |t|)))) - |t|) - ((STRINGP |x|) (|genCaseTag| |t| |l| |n|)) - ('T (|genCaseTag| |t| |l| (PLUS |n| 1))))) - ('T NIL))))) - -;compIf(["IF",aOrig,b,c],m,E) == -; a := markKillButIfs aOrig -; [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil -; [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil -; [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil -; xb':= coerce(Tb,mc) or return nil -; x:= ["IF",xa,quotify xb'.expr,quotify xc] -; (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where -; Env(bEnv,cEnv,b,c,E) == -; canReturn(b,0,0,true) => -; (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) -; canReturn(c,0,0,true) => cEnv -; E -; [x,mc,returnEnv] - -(DEFUN |compIf,Env| (|bEnv| |cEnv| |b| |c| E) - (SEQ (IF (|canReturn| |b| 0 0 'T) - (EXIT (SEQ (IF (|canReturn| |c| 0 0 'T) - (EXIT (|intersectionEnvironment| |bEnv| - |cEnv|))) - (EXIT |bEnv|)))) - (IF (|canReturn| |c| 0 0 'T) (EXIT |cEnv|)) (EXIT E))) - -(DEFUN |compIf| (G169859 |m| E) - (PROG (|aOrig| |b| |c| |a| |LETTMP#1| |xa| |ma| |Ea| |Einv| |Tb| |xb| - |mb| |Eb| |Tc| |xc| |mc| |Ec| |xb'| |x| |returnEnv|) - (declare (special |$Boolean|)) - (RETURN - (PROGN - (COND ((EQ (CAR G169859) 'IF) (CAR G169859))) - (SPADLET |aOrig| (CADR G169859)) - (SPADLET |b| (CADDR G169859)) - (SPADLET |c| (CADDDR G169859)) - (SPADLET |a| (|markKillButIfs| |aOrig|)) - (SPADLET |LETTMP#1| - (OR (|compBoolean| |a| |aOrig| |$Boolean| E) - (RETURN NIL))) - (SPADLET |xa| (CAR |LETTMP#1|)) - (SPADLET |ma| (CADR |LETTMP#1|)) - (SPADLET |Ea| (CADDR |LETTMP#1|)) - (SPADLET |Einv| (CADDDR |LETTMP#1|)) - (SPADLET |Tb| (OR (|compFromIf| |b| |m| |Ea|) (RETURN NIL))) - (SPADLET |xb| (CAR |Tb|)) - (SPADLET |mb| (CADR |Tb|)) - (SPADLET |Eb| (CADDR |Tb|)) - (SPADLET |Tc| - (OR (|compFromIf| |c| (|resolve| |mb| |m|) |Einv|) - (RETURN NIL))) - (SPADLET |xc| (CAR |Tc|)) - (SPADLET |mc| (CADR |Tc|)) - (SPADLET |Ec| (CADDR |Tc|)) - (SPADLET |xb'| (OR (|coerce| |Tb| |mc|) (RETURN NIL))) - (SPADLET |x| - (CONS 'IF - (CONS |xa| - (CONS (|quotify| (CAR |xb'|)) - (CONS (|quotify| |xc|) NIL))))) - (SPADLET |returnEnv| - (|compIf,Env| (CADDR |xb'|) |Ec| (CAR |xb'|) |xc| E)) - (CONS |x| (CONS |mc| (CONS |returnEnv| NIL))))))) - -;compBoolean(p,pWas,m,Einit) == -; op := opOf p -; [p',m,E]:= -; fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) => -; APPLY(fop,[p,pWas,m,Einit]) or return nil -; T := comp(p,m,Einit) or return nil -; markAny('compBoolean,pWas,T) -; [p',m,getSuccessEnvironment(markKillAll p,E), -; getInverseEnvironment(markKillAll p,E)] - -(DEFUN |compBoolean| (|p| |pWas| |m| |Einit|) - (PROG (|op| |fop| T$ |LETTMP#1| |p'| E) - (RETURN - (PROGN - (SPADLET |op| (|opOf| |p|)) - (SPADLET |LETTMP#1| - (COND - ((SPADLET |fop| - (LASSOC |op| - '((|and| . |compAnd|) - (|or| . |compOr|) - (|not| . |compNot|)))) - (OR (APPLY |fop| - (CONS |p| - (CONS |pWas| - (CONS |m| (CONS |Einit| NIL))))) - (RETURN NIL))) - ('T - (SPADLET T$ - (OR (|comp| |p| |m| |Einit|) (RETURN NIL))) - (|markAny| '|compBoolean| |pWas| T$)))) - (SPADLET |p'| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET E (CADDR |LETTMP#1|)) - (CONS |p'| - (CONS |m| - (CONS (|getSuccessEnvironment| (|markKillAll| |p|) - E) - (CONS (|getInverseEnvironment| - (|markKillAll| |p|) E) - NIL)))))))) - -;compAnd([op,:args], pWas, m, e) == -;--called ONLY from compBoolean -; cargs := [T.expr for x in args -; | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil] -; null cargs => nil -; coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m) - -(DEFUN |compAnd| (G169938 |pWas| |m| |e|) - (PROG (|op| |args| T$ |cargs|) - (declare (special |$Boolean|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR G169938)) - (SPADLET |args| (CDR G169938)) - (SPADLET |cargs| - (PROG (G169955) - (SPADLET G169955 NIL) - (RETURN - (DO ((G169961 |args| (CDR G169961)) - (|x| NIL)) - ((OR (ATOM G169961) - (PROGN - (SETQ |x| (CAR G169961)) - NIL)) - (NREVERSE0 G169955)) - (SEQ (EXIT (COND - ((PROGN - (SPADLET T$ - (OR - (|compBoolean| |x| |x| - |$Boolean| |e|) - (RETURN NIL))) - (SPADLET |e| (CADDR T$)) - T$) - (SETQ G169955 - (CONS (CAR T$) G169955)))))))))) - (COND - ((NULL |cargs|) NIL) - ('T - (|coerce| - (|markAny| '|compAnd| |pWas| - (CONS (CONS 'AND |cargs|) - (CONS |$Boolean| (CONS |e| NIL)))) - |m|)))))))) - -;compOr([op,:args], pWas, m, e) == -;--called ONLY from compBoolean -; cargs := [T.expr for x in args -; | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil] -; null cargs => nil -; coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m) - -(DEFUN |compOr| (G169982 |pWas| |m| |e|) - (PROG (|op| |args| T$ |cargs|) - (declare (special |$Boolean|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR G169982)) - (SPADLET |args| (CDR G169982)) - (SPADLET |cargs| - (PROG (G169999) - (SPADLET G169999 NIL) - (RETURN - (DO ((G170005 |args| (CDR G170005)) - (|x| NIL)) - ((OR (ATOM G170005) - (PROGN - (SETQ |x| (CAR G170005)) - NIL)) - (NREVERSE0 G169999)) - (SEQ (EXIT (COND - ((PROGN - (SPADLET T$ - (OR - (|compBoolean| |x| |x| - |$Boolean| |e|) - (RETURN NIL))) - (SPADLET |e| (CADDDR T$)) - T$) - (SETQ G169999 - (CONS (CAR T$) G169999)))))))))) - (COND - ((NULL |cargs|) NIL) - ('T - (|coerce| - (|markAny| '|compOr| |pWas| - (CONS (CONS 'OR |cargs|) - (CONS |$Boolean| (CONS |e| NIL)))) - |m|)))))))) - -;compNot([op,arg], pWas, m, e) == -;--called ONLY from compBoolean -; [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil -; coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m) - -(DEFUN |compNot| (G170030 |pWas| |m| |e|) - (PROG (|op| |arg| |LETTMP#1| |x| |m1| |ei|) - (declare (special |$Boolean|)) - (RETURN - (PROGN - (SPADLET |op| (CAR G170030)) - (SPADLET |arg| (CADR G170030)) - (SPADLET |LETTMP#1| - (OR (|compBoolean| |arg| |arg| |$Boolean| |e|) - (RETURN NIL))) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |m1| (CADR |LETTMP#1|)) - (SPADLET |ei| (CADDDR |LETTMP#1|)) - (|coerce| - (|markAny| '|compNot| |pWas| - (CONS (CONS 'NOT (CONS |x| NIL)) - (CONS |$Boolean| (CONS |ei| NIL)))) - |m|))))) - -;compDefine(form,m,e) == -; $tripleCache: local:= nil -; $tripleHits: local:= 0 -; $macroIfTrue: local -; $packagesUsed: local -; ['DEF,.,originalSignature,.,body] := form -; if not $insideFunctorIfTrue then -; $originalBody := COPY body -; compDefine1(form,m,e) - -(DEFUN |compDefine| (|form| |m| |e|) - (PROG (|$tripleCache| |$tripleHits| |$macroIfTrue| |$packagesUsed| - |originalSignature| |body|) - (DECLARE (SPECIAL |$tripleCache| |$tripleHits| |$macroIfTrue| - |$packagesUsed| |$originalBody| |$insideFunctorIfTrue|)) - (RETURN - (PROGN - (SPADLET |$tripleCache| NIL) - (SPADLET |$tripleHits| 0) - (SPADLET |$macroIfTrue| NIL) - (SPADLET |$packagesUsed| NIL) - (SPADLET |originalSignature| (CADDR |form|)) - (SPADLET |body| (CAR (CDDDDR |form|))) - (COND - ((NULL |$insideFunctorIfTrue|) - (SPADLET |$originalBody| (COPY |body|)))) - (|compDefine1| |form| |m| |e|))))) - -;compDefine1(form,m,e) == -; $insideExpressionIfTrue: local:= false -; --1. decompose after macro-expanding form -; ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) -; $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) -; => [lhs,m,put(first lhs,'macro,rhs,e)] -; null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and -; (sig:= getSignatureFromMode(lhs,e)) => -; -- here signature of lhs is determined by a previous declaration -; compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) -; if signature.target=$Category then $insideCategoryIfTrue:= true -; if signature.target is ['Mapping,:map] then -; signature:= map -; form:= ['DEF,lhs,signature,specialCases,rhs] -;-- RDJ (11/83): when argument and return types are all declared, -;-- or arguments have types declared in the environment, -;-- and there is no existing modemap for this signature, add -;-- the modemap by a declaration, then strip off declarations and recurse -; e := compDefineAddSignature(lhs,signature,e) -;-- 2. if signature list for arguments is not empty, replace ('DEF,..) by -;-- ('where,('DEF,..),..) with an empty signature list; -;-- otherwise, fill in all NILs in the signature -; not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) -; signature.target=$Category => -; compDefineCategory(form,m,e,nil,$formalArgList) -; isDomainForm(rhs,e) and not $insideFunctorIfTrue => -; if null signature.target then signature:= -; [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: -; rest signature] -; rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) -; compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, -; $formalArgList) -; null $form => stackAndThrow ['"bad == form ",form] -; newPrefix:= -; $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) -; getAbbreviation($op,#rest $form) -; compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) - -(DEFUN |compDefine1| (|form| |m| |e|) - (PROG (|$insideExpressionIfTrue| |lhs| |specialCases| |sig| |ISTMP#1| - |map| |signature| |rhs| |newPrefix|) - (DECLARE (SPECIAL |$insideExpressionIfTrue| |$form| |$op| |$prefix| - |$formalArgList| |$insideFunctorIfTrue| |$Category| - |$insideCategoryIfTrue| |$ConstructorNames| - |$NoValueMode| |$EmptyMode| |$insideWhereIfTrue|)) - (RETURN - (SEQ (PROGN - (SPADLET |$insideExpressionIfTrue| NIL) - (SPADLET |form| (|macroExpand| |form| |e|)) - (SPADLET |lhs| (CADR |form|)) - (SPADLET |signature| (CADDR |form|)) - (SPADLET |specialCases| (CADDDR |form|)) - (SPADLET |rhs| (CAR (CDDDDR |form|))) - (COND - ((AND |$insideWhereIfTrue| (|isMacro| |form| |e|) - (OR (BOOT-EQUAL |m| |$EmptyMode|) - (BOOT-EQUAL |m| |$NoValueMode|))) - (CONS |lhs| - (CONS |m| - (CONS (|put| (CAR |lhs|) '|macro| |rhs| - |e|) - NIL)))) - ((AND (NULL (CAR |signature|)) - (NULL (MEMQ (KAR |rhs|) |$ConstructorNames|)) - (SPADLET |sig| (|getSignatureFromMode| |lhs| |e|))) - (|compDefine1| - (CONS 'DEF - (CONS |lhs| - (CONS (CONS (CAR |sig|) - (CDR |signature|)) - (CONS |specialCases| - (CONS |rhs| NIL))))) - |m| |e|)) - ('T - (COND - ((BOOT-EQUAL (CAR |signature|) |$Category|) - (SPADLET |$insideCategoryIfTrue| 'T))) - (COND - ((PROGN - (SPADLET |ISTMP#1| (CAR |signature|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|) - (PROGN (SPADLET |map| (QCDR |ISTMP#1|)) 'T))) - (SPADLET |signature| |map|) - (SPADLET |form| - (CONS 'DEF - (CONS |lhs| - (CONS |signature| - (CONS |specialCases| - (CONS |rhs| NIL)))))))) - (SPADLET |e| - (|compDefineAddSignature| |lhs| |signature| - |e|)) - (COND - ((NULL (PROG (G170094) - (SPADLET G170094 'T) - (RETURN - (DO ((G170100 NIL (NULL G170094)) - (G170101 (CDR |signature|) - (CDR G170101)) - (|x| NIL)) - ((OR G170100 (ATOM G170101) - (PROGN - (SETQ |x| (CAR G170101)) - NIL)) - G170094) - (SEQ (EXIT - (SETQ G170094 - (AND G170094 (NULL |x|))))))))) - (|compDefWhereClause| |form| |m| |e|)) - ((BOOT-EQUAL (CAR |signature|) |$Category|) - (|compDefineCategory| |form| |m| |e| NIL - |$formalArgList|)) - ((AND (|isDomainForm| |rhs| |e|) - (NULL |$insideFunctorIfTrue|)) - (COND - ((NULL (CAR |signature|)) - (SPADLET |signature| - (CONS (|getTargetFromRhs| |lhs| |rhs| - (|giveFormalParametersValues| - (CDR |lhs|) |e|)) - (CDR |signature|))))) - (SPADLET |rhs| - (|addEmptyCapsuleIfNecessary| - (CAR |signature|) |rhs|)) - (|compDefineFunctor| - (CONS 'DEF - (CONS |lhs| - (CONS |signature| - (CONS |specialCases| - (CONS |rhs| NIL))))) - |m| |e| NIL |$formalArgList|)) - ((NULL |$form|) - (|stackAndThrow| - (CONS "bad == form " - (CONS |form| NIL)))) - ('T - (SPADLET |newPrefix| - (COND - (|$prefix| - (INTERN (STRCONC - (|encodeItem| |$prefix|) - "," - (|encodeItem| |$op|)))) - ('T - (|getAbbreviation| |$op| - (|#| (CDR |$form|)))))) - (|compDefineCapsuleFunction| |form| |m| |e| - |newPrefix| |$formalArgList|)))))))))) - -;compDefineCategory(df,m,e,prefix,fal) == -; $domainShell: local -- holds the category of the object being compiled -; $lisplibCategory: local -; not $insideFunctorIfTrue and $LISPLIB => -; compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) -; compDefineCategory1(df,m,e,prefix,fal) - -(DEFUN |compDefineCategory| (|df| |m| |e| |prefix| |fal|) - (PROG (|$domainShell| |$lisplibCategory|) - (DECLARE (SPECIAL |$domainShell| |$lisplibCategory| $LISPLIB - |$insideFunctorIfTrue|)) - (RETURN - (PROGN - (SPADLET |$domainShell| NIL) - (SPADLET |$lisplibCategory| NIL) - (COND - ((AND (NULL |$insideFunctorIfTrue|) $LISPLIB) - (|compDefineLisplib| |df| |m| |e| |prefix| |fal| - '|compDefineCategory1|)) - ('T (|compDefineCategory1| |df| |m| |e| |prefix| |fal|))))))) - -;compDefineCategory1(df,m,e,prefix,fal) == -; $DEFdepth : local := 0 --for conversion to new compiler 3/93 -; $capsuleStack : local := nil --for conversion to new compiler 3/93 -; $predicateStack:local := nil --for conversion to new compiler 3/93 -; $signatureStack:local := nil --for conversion to new compiler 3/93 -; $importStack : local := nil --for conversion to new compiler 3/93 -; $globalImportStack : local := nil --for conversion to new compiler 3/93 -; $catAddForm : local := nil --for conversion to new compiler 2/95 -; $globalDeclareStack : local := nil -; $globalImportDefAlist: local:= nil -; $localMacroStack : local := nil --for conversion to new compiler 3/93 -; $freeStack : local := nil --for conversion to new compiler 3/93 -; $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 -; $categoryTranForm : local := nil --for conversion to new compiler 10/93 -; ['DEF,form,sig,sc,body] := df -; body := markKillAll body --these parts will be replaced by compDefineLisplib -; categoryCapsule := -;--+ -; body is ['add,cat,capsule] => -; body := cat -; capsule -; nil -; [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) -;--+ next two lines -;-- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil -;-- else -; if categoryCapsule and not $bootStrapMode then -; [.,.,e] := -; $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 -; $categoryPredicateList: local := -; makeCategoryPredicates(form,$lisplibCategory) -; defform := mkCategoryPackage(form,cat,categoryCapsule) -; ['DEF,[.,arg,:.],:.] := defform -; $categoryNameForDollar :local := arg -; compDefine1(defform,$EmptyMode,e) -; else -; [body,T] := $categoryTranForm -; markFinish(body,T) -; [d,m,e] - -(DEFUN |compDefineCategory1| (|df| |m| |e| |prefix| |fal|) - (PROG (|$DEFdepth| |$capsuleStack| |$predicateStack| - |$signatureStack| |$importStack| |$globalImportStack| - |$catAddForm| |$globalDeclareStack| |$globalImportDefAlist| - |$localMacroStack| |$freeStack| |$domainLevelVariableList| - |$categoryTranForm| |$insideCategoryPackageIfTrue| - |$categoryPredicateList| |$categoryNameForDollar| |form| - |sig| |sc| |ISTMP#1| |cat| |ISTMP#2| |capsule| - |categoryCapsule| |d| |defform| |arg| |LETTMP#1| |body| T$) - (DECLARE (SPECIAL |$DEFdepth| |$capsuleStack| |$predicateStack| - |$signatureStack| |$importStack| |$EmptyMode| - |$globalImportStack| |$catAddForm| |$lisplibCategory| - |$globalDeclareStack| |$globalImportDefAlist| - |$localMacroStack| |$freeStack| |$bootStrapMode| - |$domainLevelVariableList| |$categoryTranForm| - |$insideCategoryPackageIfTrue| - |$categoryPredicateList| - |$categoryNameForDollar|)) - (RETURN - (PROGN - (SPADLET |$DEFdepth| 0) - (SPADLET |$capsuleStack| NIL) - (SPADLET |$predicateStack| NIL) - (SPADLET |$signatureStack| NIL) - (SPADLET |$importStack| NIL) - (SPADLET |$globalImportStack| NIL) - (SPADLET |$catAddForm| NIL) - (SPADLET |$globalDeclareStack| NIL) - (SPADLET |$globalImportDefAlist| NIL) - (SPADLET |$localMacroStack| NIL) - (SPADLET |$freeStack| NIL) - (SPADLET |$domainLevelVariableList| NIL) - (SPADLET |$categoryTranForm| NIL) - (SPADLET |form| (CADR |df|)) - (SPADLET |sig| (CADDR |df|)) - (SPADLET |sc| (CADDDR |df|)) - (SPADLET |body| (CAR (CDDDDR |df|))) - (SPADLET |body| (|markKillAll| |body|)) - (SPADLET |categoryCapsule| - (COND - ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |cat| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |capsule| - (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |body| |cat|) |capsule|) - ('T NIL))) - (SPADLET |LETTMP#1| - (|compDefineCategory2| |form| |sig| |sc| |body| |m| - |e| |prefix| |fal|)) - (SPADLET |d| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((AND |categoryCapsule| (NULL |$bootStrapMode|)) - (SPADLET |LETTMP#1| - (PROGN - (SPADLET |$insideCategoryPackageIfTrue| 'T) - (SPADLET |$categoryPredicateList| - (|makeCategoryPredicates| |form| - |$lisplibCategory|)) - (SPADLET |defform| - (|mkCategoryPackage| |form| |cat| - |categoryCapsule|)) - (SPADLET |arg| (CADADR |defform|)) - (SPADLET |$categoryNameForDollar| |arg|) - (|compDefine1| |defform| |$EmptyMode| |e|))) - (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|) - ('T (SPADLET |body| (CAR |$categoryTranForm|)) - (SPADLET T$ (CADR |$categoryTranForm|)) - (|markFinish| |body| T$))) - (CONS |d| (CONS |m| (CONS |e| NIL))))))) - -;compDefineCategory2(form,signature,specialCases,body,m,e, -; $prefix,$formalArgList) == -; --1. bind global variables -; $insideCategoryIfTrue: local:= true -; $TOP__LEVEL: local -; $definition: local -; --used by DomainSubstitutionFunction -; $form: local -; $op: local -; $extraParms: local -; --Set in DomainSubstitutionFunction, used further down -;-- 1.1 augment e to add declaration $:
-; [$op,:argl]:= $definition:= form -; e:= addBinding("$",[['mode,:$definition]],e) -;-- 2. obtain signature -; signature':= -; [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] -; e:= giveFormalParametersValues(argl,e) -;-- 3. replace arguments by $1,..., substitute into body, -;-- and introduce declarations into environment -; sargl:= TAKE(# argl, $TriangleVariableList) -; $functorForm:= $form:= [$op,:sargl] -; $formalArgList:= [:sargl,:$formalArgList] -; aList:= [[a,:sa] for a in argl for sa in sargl] -; formalBody:= SUBLIS(aList,body) -; signature' := SUBLIS(aList,signature') -;--Begin lines for category default definitions -; $functionStats: local:= [0,0] -; $functorStats: local:= [0,0] -; $frontier: local := 0 -; $getDomainCode: local := nil -; $addForm: local:= nil -; for x in sargl for t in rest signature' repeat -; [.,.,e]:= compMakeDeclaration([":",x,t],m,e) -;-- 4. compile body in environment of %type declarations for arguments -; op':= $op -; -- following line causes cats with no with or Join to be fresh copies -; if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then -; formalBody := ['Join, formalBody] -; T := compOrCroak(formalBody,signature'.target,e) -;--------------------> new <------------------- -; $catAddForm := -; $originalBody is ['add,y,:.] => y -; $originalBody -; $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]] -;--------------------> new <------------------- -; body:= optFunctorBody markKillAll T.expr -; if $extraParms then -; formals:=actuals:=nil -; for u in $extraParms repeat -; formals:=[CAR u,:formals] -; actuals:=[MKQ CDR u,:actuals] -; body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] -; if argl then body:= -- always subst for args after extraparms -; ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: -; [['devaluate,u] for u in sargl]]],body] -; body:= -; ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]] -; fun:= compile [op',['LAM,sargl,body]] -;-- 5. give operator a 'modemap property -; pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] -; parSignature:= SUBLIS(pairlis,signature') -; parForm:= SUBLIS(pairlis,form) -;---- lisplibWrite('"compilerInfo", -;---- ['SETQ,'$CategoryFrame, -;---- ['put,['QUOTE,op'],' -;---- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, -;---- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) -; --Equivalent to the following two lines, we hope -; if null sargl then -; evalAndRwriteLispForm('NILADIC, -; ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) -;-- 6. put modemaps into InteractiveModemapFrame -; $domainShell := -; BOUNDP '$convertingSpadFile and $convertingSpadFile => nil -; eval [op',:MAPCAR('MKQ,sargl)] -; $lisplibCategory:= formalBody -;---- if $LISPLIB then -;---- $lisplibForm:= form -;---- $lisplibKind:= 'category -;---- modemap:= [[parForm,:parSignature],[true,op']] -;---- $lisplibModemap:= modemap -;---- $lisplibCategory:= formalBody -;---- form':=[op',:sargl] -;---- augLisplibModemapsFromCategory(form',formalBody,signature') -; [fun,'(Category),e] - -(DEFUN |compDefineCategory2| - (|form| |signature| |specialCases| |body| |m| |e| |$prefix| - |$formalArgList|) - (declare (ignore |specialCases|)) - (DECLARE (SPECIAL |$prefix| |$formalArgList|)) - (PROG (|$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$form| |$op| - |$extraParms| |$functionStats| |$functorStats| |$frontier| - |$getDomainCode| |$addForm| |argl| |sargl| |aList| - |signature'| |LETTMP#1| |op'| |formalBody| T$ |ISTMP#1| |y| - |formals| |actuals| |g| |fun| |pairlis| |parSignature| - |parForm|) - (DECLARE (SPECIAL |$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$op| - |$form| |$op| |$extraParms| |$functionStats| - |$functorStats| |$frontier| |$getDomainCode| - |$addForm| |$lisplibCategory| |$convertingSpadFile| - |$domainShell| |$FormalMapVariableList| |$functorForm| - |$originalBody| |$categoryTranForm| |$originalBody| - |$catAddForm| |$addForm| |$formalArgList| - |$TriangleVariableList| )) - (RETURN - (SEQ (PROGN - (SPADLET |$insideCategoryIfTrue| 'T) - (SPADLET $TOP_LEVEL NIL) - (SPADLET |$definition| NIL) - (SPADLET |$form| NIL) - (SPADLET |$op| NIL) - (SPADLET |$extraParms| NIL) - (SPADLET |$definition| |form|) - (SPADLET |$op| (CAR |$definition|)) - (SPADLET |argl| (CDR |$definition|)) - (SPADLET |e| - (|addBinding| '$ - (CONS (CONS '|mode| |$definition|) NIL) |e|)) - (SPADLET |signature'| - (CONS (CAR |signature|) - (PROG (G170284) - (SPADLET G170284 NIL) - (RETURN - (DO ((G170289 |argl| (CDR G170289)) - (|a| NIL)) - ((OR (ATOM G170289) - (PROGN - (SETQ |a| (CAR G170289)) - NIL)) - (NREVERSE0 G170284)) - (SEQ (EXIT - (SETQ G170284 - (CONS - (|getArgumentModeOrMoan| |a| - |$definition| |e|) - G170284))))))))) - (SPADLET |e| (|giveFormalParametersValues| |argl| |e|)) - (SPADLET |sargl| - (TAKE (|#| |argl|) |$TriangleVariableList|)) - (SPADLET |$functorForm| - (SPADLET |$form| (CONS |$op| |sargl|))) - (SPADLET |$formalArgList| - (APPEND |sargl| |$formalArgList|)) - (SPADLET |aList| - (PROG (G170300) - (SPADLET G170300 NIL) - (RETURN - (DO ((G170306 |argl| (CDR G170306)) - (|a| NIL) - (G170307 |sargl| (CDR G170307)) - (|sa| NIL)) - ((OR (ATOM G170306) - (PROGN - (SETQ |a| (CAR G170306)) - NIL) - (ATOM G170307) - (PROGN - (SETQ |sa| (CAR G170307)) - NIL)) - (NREVERSE0 G170300)) - (SEQ (EXIT (SETQ G170300 - (CONS (CONS |a| |sa|) - G170300)))))))) - (SPADLET |formalBody| (SUBLIS |aList| |body|)) - (SPADLET |signature'| (SUBLIS |aList| |signature'|)) - (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) - (SPADLET |$functorStats| (CONS 0 (CONS 0 NIL))) - (SPADLET |$frontier| 0) - (SPADLET |$getDomainCode| NIL) - (SPADLET |$addForm| NIL) - (DO ((G170323 |sargl| (CDR G170323)) (|x| NIL) - (G170324 (CDR |signature'|) (CDR G170324)) - (|t| NIL)) - ((OR (ATOM G170323) - (PROGN (SETQ |x| (CAR G170323)) NIL) - (ATOM G170324) - (PROGN (SETQ |t| (CAR G170324)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |LETTMP#1| - (|compMakeDeclaration| - (CONS '|:| - (CONS |x| (CONS |t| NIL))) - |m| |e|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - |LETTMP#1|)))) - (SPADLET |op'| |$op|) - (COND - ((AND (NEQUAL (|opOf| |formalBody|) '|Join|) - (NEQUAL (|opOf| |formalBody|) '|mkCategory|)) - (SPADLET |formalBody| - (CONS '|Join| (CONS |formalBody| NIL))))) - (SPADLET T$ - (|compOrCroak| |formalBody| (CAR |signature'|) - |e|)) - (SPADLET |$catAddForm| - (COND - ((AND (PAIRP |$originalBody|) - (EQ (QCAR |$originalBody|) '|add|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |$originalBody|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#1|)) - 'T)))) - |y|) - ('T |$originalBody|))) - (SPADLET |$categoryTranForm| - (CONS |$originalBody| - (CONS (CONS |$form| - (CONS - (CONS '|Mapping| |signature'|) - (CONS (CADDR T$) NIL))) - NIL))) - (SPADLET |body| - (|optFunctorBody| (|markKillAll| (CAR T$)))) - (COND - (|$extraParms| - (SPADLET |formals| (SPADLET |actuals| NIL)) - (DO ((G170338 |$extraParms| (CDR G170338)) - (|u| NIL)) - ((OR (ATOM G170338) - (PROGN (SETQ |u| (CAR G170338)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |formals| - (CONS (CAR |u|) |formals|)) - (SPADLET |actuals| - (CONS (MKQ (CDR |u|)) - |actuals|)))))) - (SPADLET |body| - (CONS '|sublisV| - (CONS (CONS 'PAIR - (CONS - (CONS 'QUOTE - (CONS |formals| NIL)) - (CONS (CONS 'LIST |actuals|) - NIL))) - (CONS |body| NIL)))))) - (COND - (|argl| (SPADLET |body| - (CONS '|sublisV| - (CONS - (CONS 'PAIR - (CONS - (CONS 'QUOTE - (CONS |sargl| NIL)) - (CONS - (CONS 'LIST - (PROG (G170348) - (SPADLET G170348 NIL) - (RETURN - (DO - ((G170353 |sargl| - (CDR G170353)) - (|u| NIL)) - ((OR (ATOM G170353) - (PROGN - (SETQ |u| - (CAR G170353)) - NIL)) - (NREVERSE0 G170348)) - (SEQ - (EXIT - (SETQ G170348 - (CONS - (CONS '|devaluate| - (CONS |u| NIL)) - G170348)))))))) - NIL))) - (CONS |body| NIL)))))) - (SPADLET |body| - (CONS 'PROG1 - (CONS (CONS 'LET - (CONS (SPADLET |g| (GENSYM)) - (CONS |body| NIL))) - (CONS (CONS 'SETELT - (CONS |g| - (CONS 0 - (CONS - (|mkConstructor| - |$functorForm|) - NIL)))) - NIL)))) - (SPADLET |fun| - (|compile| - (CONS |op'| - (CONS (CONS 'LAM - (CONS |sargl| (CONS |body| NIL))) - NIL)))) - (SPADLET |pairlis| - (PROG (G170364) - (SPADLET G170364 NIL) - (RETURN - (DO ((G170370 |argl| (CDR G170370)) - (|a| NIL) - (G170371 |$FormalMapVariableList| - (CDR G170371)) - (|v| NIL)) - ((OR (ATOM G170370) - (PROGN - (SETQ |a| (CAR G170370)) - NIL) - (ATOM G170371) - (PROGN - (SETQ |v| (CAR G170371)) - NIL)) - (NREVERSE0 G170364)) - (SEQ (EXIT (SETQ G170364 - (CONS (CONS |a| |v|) G170364)))))))) - (SPADLET |parSignature| (SUBLIS |pairlis| |signature'|)) - (SPADLET |parForm| (SUBLIS |pairlis| |form|)) - (COND - ((NULL |sargl|) - (|evalAndRwriteLispForm| 'NILADIC - (CONS 'MAKEPROP - (CONS (CONS 'QUOTE (CONS |op'| NIL)) - (CONS ''NILADIC (CONS 'T NIL))))))) - (SPADLET |$domainShell| - (COND - ((AND (BOUNDP '|$convertingSpadFile|) - |$convertingSpadFile|) - NIL) - ('T - (|eval| (CONS |op'| (MAPCAR 'MKQ |sargl|)))))) - (SPADLET |$lisplibCategory| |formalBody|) - (CONS |fun| (CONS '(|Category|) (CONS |e| NIL)))))))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document}