diff --git a/changelog b/changelog index 6c804ab..dcdf237 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20091004 tpd src/axiom-website/patches.html 20091004.01.tpd.patch +20091004 tpd src/interp/i-map.lisp cleanup 20091003 tpd src/axiom-website/patches.html 20091003.03.tpd.patch 20091003 tpd src/interp/i-output.lisp cleanup 20091003 tpd src/axiom-website/patches.html 20091003.02.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index c1d42d1..30c6bfc 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2093,5 +2093,7 @@ src/interp/i-spec1.lisp cleanup
src/interp/i-resolv.lisp cleanup
20091003.03.tpd.patch src/interp/i-output.lisp cleanup
+20091004.01.tpd.patch +src/interp/i-map.lisp cleanup
diff --git a/src/interp/i-map.lisp.pamphlet b/src/interp/i-map.lisp.pamphlet index 31dd942..ebd9d1c 100644 --- a/src/interp/i-map.lisp.pamphlet +++ b/src/interp/i-map.lisp.pamphlet @@ -51,23 +51,27 @@ ; name := CONCAT(name,'";",$specialMapNameSuffix) ; INTERN name -(DEFUN |makeInternalMapName| (|userName| |numArgs| |numMms| |extraPart|) - (PROG (|name|) - (RETURN - (PROGN - (SPADLET |name| - (CONCAT "*" - (STRINGIMAGE |numArgs|) ";" - (|object2String| |userName|) ";" - (STRINGIMAGE |numMms|) ";" - (|object2String| (FRAMENAME (CAR |$interpreterFrameRing|))))) - (COND - (|extraPart| - (SPADLET |name| (CONCAT |name| ";" |extraPart|)))) - (COND - (|$specialMapNameSuffix| - (SPADLET |name| (CONCAT |name| ";" |$specialMapNameSuffix|)))) - (INTERN |name|))))) +(DEFUN |makeInternalMapName| + (|userName| |numArgs| |numMms| |extraPart|) + (PROG (|name|) + (DECLARE (SPECIAL |$specialMapNameSuffix| |$interpreterFrameRing|)) + (RETURN + (PROGN + (SPADLET |name| + (CONCAT "*" (STRINGIMAGE |numArgs|) ";" + (|object2String| |userName|) ";" + (STRINGIMAGE |numMms|) ";" + (|object2String| + (FRAMENAME (CAR |$interpreterFrameRing|))))) + (COND + (|extraPart| + (SPADLET |name| (CONCAT |name| ";" |extraPart|)))) + (COND + (|$specialMapNameSuffix| + (SPADLET |name| + (CONCAT |name| ";" |$specialMapNameSuffix|)))) + (INTERN |name|))))) + ;isInternalMapName name == ; -- this only returns true or false as a "best guess" @@ -80,20 +84,18 @@ ; true (DEFUN |isInternalMapName| (|name|) - (PROG (|name'| |sz|) - (RETURN - (COND - ((OR (NULL (IDENTP |name|)) - (BOOT-EQUAL |name| (QUOTE *)) - (BOOT-EQUAL |name| (QUOTE **))) - NIL) - ((QUOTE T) - (SPADLET |sz| (SIZE (SPADLET |name'| (PNAME |name|)))) - (COND - ((OR (> 7 |sz|) (NEQUAL (|char| (QUOTE *)) (ELT |name'| 0))) NIL) - ((NULL (DIGITP (ELT |name'| 1))) NIL) - ((NULL (STRPOS (MAKESTRING ";") |name'| 1 NIL)) NIL) - ((QUOTE T) (QUOTE T)))))))) + (PROG (|name'| |sz|) + (RETURN + (COND + ((OR (NULL (IDENTP |name|)) (BOOT-EQUAL |name| '*) + (BOOT-EQUAL |name| '**)) + NIL) + ('T (SPADLET |sz| (SIZE (SPADLET |name'| (PNAME |name|)))) + (COND + ((OR (> 7 |sz|) (NEQUAL (|char| '*) (ELT |name'| 0))) NIL) + ((NULL (DIGITP (ELT |name'| 1))) NIL) + ((NULL (STRPOS (MAKESTRING ";") |name'| 1 NIL)) NIL) + ('T 'T))))))) ;makeInternalMapMinivectorName(name) == ; STRINGP name => @@ -101,14 +103,14 @@ ; INTERN STRCONC(PNAME name,'";MV") (DEFUN |makeInternalMapMinivectorName| (|name|) - (COND - ((STRINGP |name|) (INTERN (STRCONC |name| (MAKESTRING ";MV")))) - ((QUOTE T) (INTERN (STRCONC (PNAME |name|) (MAKESTRING ";MV")))))) + (COND + ((STRINGP |name|) (INTERN (STRCONC |name| (MAKESTRING ";MV")))) + ('T (INTERN (STRCONC (PNAME |name|) (MAKESTRING ";MV")))))) ;mkCacheName(name) == INTERNL(STRINGIMAGE name,'";AL") (DEFUN |mkCacheName| (|name|) - (INTERNL (STRINGIMAGE |name|) (MAKESTRING ";AL"))) + (INTERNL (STRINGIMAGE |name|) (MAKESTRING ";AL"))) ;mkAuxiliaryName(name) == INTERNL(STRINGIMAGE name,'";AUX") @@ -118,25 +120,24 @@ ;--% Adding a function definition ;isMapExpr x == x is ['MAP,:.] -(DEFUN |isMapExpr| (|x|) - (AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE MAP)))) +(DEFUN |isMapExpr| (|x|) (AND (PAIRP |x|) (EQ (QCAR |x|) 'MAP))) ;isMap x == ; y := get(x,'value,$InteractiveFrame) => ; objVal y is ['MAP,:.] => x (DEFUN |isMap| (|x|) - (PROG (|y| |ISTMP#1|) - (RETURN - (SEQ - (COND - ((SPADLET |y| (|get| |x| (QUOTE |value|) |$InteractiveFrame|)) - (EXIT - (COND - ((PROGN - (SPADLET |ISTMP#1| (|objVal| |y|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE MAP)))) - (EXIT |x|)))))))))) + (PROG (|y| |ISTMP#1|) + (DECLARE (SPECIAL |$InteractiveFrame|)) + (RETURN + (SEQ (COND + ((SPADLET |y| (|get| |x| '|value| |$InteractiveFrame|)) + (EXIT (COND + ((PROGN + (SPADLET |ISTMP#1| (|objVal| |y|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'MAP))) + (EXIT |x|)))))))))) ;addDefMap(['DEF,lhs,mapsig,.,rhs],pred) == ; -- Create a new map, add to an existing one, or define a variable @@ -208,112 +209,130 @@ ; clearDependencies(op,'T) ; addMap(lhs,rhs,pred) -(DEFUN |addDefMap| (#0=#:G166106 |pred|) - (PROG (|$env| |$eval| |$genValue| |$freeVars| |$localVars| |mapsig| |rhs| - |lhs| |op| |oldMode| |op'| |parameters| |someDecs| |d'| |allDecs| - |mapmode| |ISTMP#1| |ISTMP#2| |mapargs| |numargs| |userVariables1| - |userVariables2| |userVariables3| |userVariables4| |newDependencies|) - (DECLARE (SPECIAL |$env| |$eval| |$genValue| |$freeVars| |$localVars|)) - (RETURN - (SEQ - (PROGN - (SPADLET |lhs| (CADR #0#)) - (SPADLET |mapsig| (CADDR #0#)) - (SPADLET |rhs| (CAR (CDDDDR #0#))) - (COND - ((NULL (PAIRP |lhs|)) - (SPADLET |op| |lhs|) - (|putHist| |op| (QUOTE |isInterpreterRule|) (QUOTE T) |$e|) - (|putHist| |op| (QUOTE |isInterpreterFunction|) NIL |$e|) - (SPADLET |lhs| (CONS |lhs| NIL))) - ((QUOTE T) - (SPADLET |op| (CAR |lhs|)) - (COND - ((AND (SPADLET |oldMode| (|get| |op| (QUOTE |mode|) |$e|)) - (NULL - (AND - (PAIRP |oldMode|) - (EQ (QCAR |oldMode|) (QUOTE |Mapping|))))) - (|throwKeyedMsg| (QUOTE S2IM0001) (CONS |op| (CONS |oldMode| NIL)))) - ((QUOTE T) - (|putHist| |op| (QUOTE |isInterpreterRule|) NIL |$e|) - (|putHist| |op| (QUOTE |isInterpreterFunction|) (QUOTE T) |$e|))))) - (COND - ((OR (NUMBERP |op|) (|member| |op| (QUOTE (|true| |false| |nil| % %%)))) - (|throwKeyedMsg| (QUOTE S2IM0002) (CONS |lhs| NIL))) - ((NEQUAL |op| (SPADLET |op'| (|unabbrev| |op|))) - (|throwKeyedMsg| (QUOTE S2IM0003) (CONS |op| (CONS |op'| NIL)))) - ((QUOTE T) - (SPADLET |parameters| - (PROG (#1=#:G166128) - (SPADLET #1# NIL) - (RETURN - (DO ((#2=#:G166134 (CDR |lhs|) (CDR #2#)) (|p| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |p| (CAR #2#)) NIL)) - (NREVERSE0 #1#)) - (SEQ (EXIT (COND ((IDENTP |p|) (SETQ #1# (CONS |p| #1#)))))))))) - (SPADLET |someDecs| NIL) - (SPADLET |allDecs| (QUOTE T)) - (SPADLET |mapmode| (CONS (QUOTE |Mapping|) NIL)) - (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) - (SPADLET |$eval| (QUOTE T)) - (SPADLET |$genValue| (QUOTE T)) - (DO ((#3=#:G166143 |mapsig| (CDR #3#)) (|d| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |d| (CAR #3#)) NIL)) NIL) - (SEQ - (EXIT - (COND - (|d| - (SPADLET |someDecs| (QUOTE T)) - (SPADLET |d'| (|evaluateType| (|unabbrev| |d|))) - (COND - ((|isPartialMode| |d'|) (|throwKeyedMsg| (QUOTE S2IM0004) NIL)) - ((QUOTE T) (SPADLET |mapmode| (CONS |d'| |mapmode|))))) - ((QUOTE T) (SPADLET |allDecs| NIL)))))) - (COND - (|allDecs| - (SPADLET |mapmode| (NREVERSE |mapmode|)) - (|putHist| |op| (QUOTE |mode|) |mapmode| |$e|) - (|sayKeyedMsg| (QUOTE S2IM0006) - (CONS (|formatOpSignature| |op| (CDR |mapmode|)) NIL))) - (|someDecs| (|throwKeyedMsg| (QUOTE S2IM0007) (CONS |op| NIL))) - ((QUOTE T) NIL)) - (COND - ((PROGN - (SPADLET |ISTMP#1| (|get| |op| (QUOTE |mode|) |$e|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN (SPADLET |mapargs| (QCDR |ISTMP#2|)) (QUOTE T)))))) - (SEQ - (COND - ((EQCAR |rhs| (QUOTE |rules|)) - (COND - ((NEQUAL 0 (SPADLET |numargs| (|#| (CDR |lhs|)))) - (EXIT - (|throwKeyedMsg| 'S2IM0027 (CONS |numargs| (CONS |op| NIL))))))) - ((NEQUAL (|#| (CDR |lhs|)) (|#| |mapargs|)) - (|throwKeyedMsg| (QUOTE S2IM0008) (CONS |op| NIL))))))) - (SPADLET |userVariables1| (|getUserIdentifiersIn| |rhs|)) - (SPADLET |$freeVars| NIL) - (SPADLET |$localVars| NIL) - (DO ((#4=#:G166152 |parameters| (CDR #4#)) (|parm| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |parm| (CAR #4#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |$mapName| |parm|)))) - (SPADLET |userVariables2| - (SETDIFFERENCE |userVariables1| (|findLocalVars| |op| |rhs|))) - (SPADLET |userVariables3| (SETDIFFERENCE |userVariables2| |parameters|)) - (SPADLET |userVariables4| - (REMDUP (SETDIFFERENCE |userVariables3| (CONS |op| NIL)))) - (SPADLET |newDependencies| - (|makeNewDependencies| |op| |userVariables4|)) - (|putDependencies| |op| |newDependencies|) - (|clearDependencies| |op| (QUOTE T)) - (|addMap| |lhs| |rhs| |pred|)))))))) +(DEFUN |addDefMap| (G166106 |pred|) + (PROG (|$env| |$eval| |$genValue| |$freeVars| |$localVars| |mapsig| + |rhs| |lhs| |op| |oldMode| |op'| |parameters| + |someDecs| |d'| |allDecs| |mapmode| |ISTMP#1| |ISTMP#2| + |mapargs| |numargs| |userVariables1| |userVariables2| + |userVariables3| |userVariables4| |newDependencies|) + (DECLARE (SPECIAL |$env| |$eval| |$genValue| |$freeVars| + |$localVars| |$mapName| |$e|)) + (RETURN + (SEQ (PROGN + (SPADLET |lhs| (CADR G166106)) + (SPADLET |mapsig| (CADDR G166106)) + (SPADLET |rhs| (CAR (CDDDDR G166106))) + (COND + ((NULL (PAIRP |lhs|)) (SPADLET |op| |lhs|) + (|putHist| |op| '|isInterpreterRule| 'T |$e|) + (|putHist| |op| '|isInterpreterFunction| NIL |$e|) + (SPADLET |lhs| (CONS |lhs| NIL))) + ('T (SPADLET |op| (CAR |lhs|)) + (COND + ((AND (SPADLET |oldMode| (|get| |op| '|mode| |$e|)) + (NULL (AND (PAIRP |oldMode|) + (EQ (QCAR |oldMode|) '|Mapping|)))) + (|throwKeyedMsg| 'S2IM0001 + (CONS |op| (CONS |oldMode| NIL)))) + ('T (|putHist| |op| '|isInterpreterRule| NIL |$e|) + (|putHist| |op| '|isInterpreterFunction| 'T |$e|))))) + (COND + ((OR (NUMBERP |op|) + (|member| |op| '(|true| |false| |nil| % %%))) + (|throwKeyedMsg| 'S2IM0002 (CONS |lhs| NIL))) + ((NEQUAL |op| (SPADLET |op'| (|unabbrev| |op|))) + (|throwKeyedMsg| 'S2IM0003 + (CONS |op| (CONS |op'| NIL)))) + ('T + (SPADLET |parameters| + (PROG (G166128) + (SPADLET G166128 NIL) + (RETURN + (DO ((G166134 (CDR |lhs|) + (CDR G166134)) + (|p| NIL)) + ((OR (ATOM G166134) + (PROGN + (SETQ |p| (CAR G166134)) + NIL)) + (NREVERSE0 G166128)) + (SEQ (EXIT + (COND + ((IDENTP |p|) + (SETQ G166128 + (CONS |p| G166128)))))))))) + (SPADLET |someDecs| NIL) (SPADLET |allDecs| 'T) + (SPADLET |mapmode| (CONS '|Mapping| NIL)) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (SPADLET |$eval| 'T) (SPADLET |$genValue| 'T) + (DO ((G166143 |mapsig| (CDR G166143)) (|d| NIL)) + ((OR (ATOM G166143) + (PROGN (SETQ |d| (CAR G166143)) NIL)) + NIL) + (SEQ (EXIT (COND + (|d| (SPADLET |someDecs| 'T) + (SPADLET |d'| + (|evaluateType| (|unabbrev| |d|))) + (COND + ((|isPartialMode| |d'|) + (|throwKeyedMsg| 'S2IM0004 NIL)) + ('T + (SPADLET |mapmode| + (CONS |d'| |mapmode|))))) + ('T (SPADLET |allDecs| NIL)))))) + (COND + (|allDecs| (SPADLET |mapmode| (NREVERSE |mapmode|)) + (|putHist| |op| '|mode| |mapmode| |$e|) + (|sayKeyedMsg| 'S2IM0006 + (CONS (|formatOpSignature| |op| + (CDR |mapmode|)) + NIL))) + (|someDecs| + (|throwKeyedMsg| 'S2IM0007 (CONS |op| NIL))) + ('T NIL)) + (COND + ((PROGN + (SPADLET |ISTMP#1| (|get| |op| '|mode| |$e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |mapargs| (QCDR |ISTMP#2|)) + 'T))))) + (SEQ (COND + ((EQCAR |rhs| '|rules|) + (COND + ((NEQUAL 0 + (SPADLET |numargs| + (|#| (CDR |lhs|)))) + (EXIT (|throwKeyedMsg| 'S2IM0027 + (CONS |numargs| (CONS |op| NIL))))))) + ((NEQUAL (|#| (CDR |lhs|)) (|#| |mapargs|)) + (|throwKeyedMsg| 'S2IM0008 (CONS |op| NIL))))))) + (SPADLET |userVariables1| + (|getUserIdentifiersIn| |rhs|)) + (SPADLET |$freeVars| NIL) (SPADLET |$localVars| NIL) + (DO ((G166152 |parameters| (CDR G166152)) + (|parm| NIL)) + ((OR (ATOM G166152) + (PROGN (SETQ |parm| (CAR G166152)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |parm|)))) + (SPADLET |userVariables2| + (SETDIFFERENCE |userVariables1| + (|findLocalVars| |op| |rhs|))) + (SPADLET |userVariables3| + (SETDIFFERENCE |userVariables2| |parameters|)) + (SPADLET |userVariables4| + (REMDUP (SETDIFFERENCE |userVariables3| + (CONS |op| NIL)))) + (SPADLET |newDependencies| + (|makeNewDependencies| |op| |userVariables4|)) + (|putDependencies| |op| |newDependencies|) + (|clearDependencies| |op| 'T) + (|addMap| |lhs| |rhs| |pred|)))))))) ;addMap(lhs,rhs,pred) == ; [op,:argl] := lhs @@ -348,97 +367,123 @@ ; objNew(newMap,type) (DEFUN |addMap| (|lhs| |rhs| |pred|) - (PROG (|$sl| |op| |argl| |formalArgList| |ISTMP#1| |s| |ISTMP#2| |p| - |predList| |x| |argList| |argPredList| |finalPred| |body| |obj| - |oldMap| |newMap| |type| |recursive|) - (DECLARE (SPECIAL |$sl|)) - (RETURN - (SEQ - (PROGN - (SPADLET |op| (CAR |lhs|)) - (SPADLET |argl| (CDR |lhs|)) - (SPADLET |$sl| NIL) - (SPADLET |formalArgList| - (PROG (#0=#:G166242) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166248 |argl| (CDR #1#)) - (|x| NIL) - (#2=#:G166249 |$FormalMapVariableList| (CDR #2#)) - (|s| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |x| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |s| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (|mkFormalArg| (|makeArgumentIntoNumber| |x|) |s|) - #0#)))))))) - (SPADLET |argList| - (PROG (#3=#:G166271) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166285 |formalArgList| (CDR #4#)) (|x| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) (NREVERSE0 #3#)) - (SEQ - (EXIT - (SETQ #3# - (CONS - (PROGN - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE SUCHTHAT)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |s| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |p| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (SPADLET |predList| (CONS |p| |predList|)) - (SPADLET |x| |s|))) - |x|) - #3#)))))))) - (|mkMapAlias| |op| |argl|) - (SPADLET |argPredList| (NREVERSE |predList|)) - (SPADLET |finalPred| - (MKPF - (COND - ((AND |pred| (NEQUAL |pred| (QUOTE T))) - (APPEND |argPredList| (CONS (SUBLISNQ |$sl| |pred|) NIL))) - ((QUOTE T) |argPredList|)) (QUOTE |and|))) - (SPADLET |body| (SUBLISNQ |$sl| |rhs|)) - (SPADLET |oldMap| - (COND - ((SPADLET |obj| (|get| |op| (QUOTE |value|) |$InteractiveFrame|)) - (|objVal| |obj|)) - ((QUOTE T) NIL))) - (SPADLET |newMap| - (|augmentMap| |op| |argList| |finalPred| |body| |oldMap|)) - (COND - ((NULL |newMap|) - (|sayRemoveFunctionOrValue| |op|) - (|putHist| |op| (QUOTE |alias|) NIL |$e|) - (INTERN " " "BOOT")) - ((QUOTE T) - (COND - ((|get| |op| (QUOTE |isInterpreterRule|) |$e|) - (SPADLET |type| (CONS (QUOTE |RuleCalled|) (CONS |op| NIL)))) - ((QUOTE T) - (SPADLET |type| (CONS (QUOTE |FunctionCalled|) (CONS |op| NIL))))) - (SPADLET |recursive| - (COND - ((EQL (|depthOfRecursion| |op| |newMap|) 0) NIL) - ((QUOTE T) (QUOTE T)))) - (|putHist| |op| (QUOTE |recursive|) |recursive| |$e|) - (|objNew| |newMap| |type|)))))))) + (PROG (|$sl| |op| |argl| |formalArgList| |ISTMP#1| |s| |ISTMP#2| |p| + |predList| |argList| |argPredList| |finalPred| + |body| |obj| |oldMap| |newMap| |type| |recursive|) + (DECLARE (SPECIAL |$sl| |$e| |$InteractiveFrame| + |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |lhs|)) + (SPADLET |argl| (CDR |lhs|)) + (SPADLET |$sl| NIL) + (SPADLET |formalArgList| + (PROG (G166242) + (SPADLET G166242 NIL) + (RETURN + (DO ((G166248 |argl| (CDR G166248)) + (|x| NIL) + (G166249 |$FormalMapVariableList| + (CDR G166249)) + (|s| NIL)) + ((OR (ATOM G166248) + (PROGN + (SETQ |x| (CAR G166248)) + NIL) + (ATOM G166249) + (PROGN + (SETQ |s| (CAR G166249)) + NIL)) + (NREVERSE0 G166242)) + (SEQ (EXIT (SETQ G166242 + (CONS + (|mkFormalArg| + (|makeArgumentIntoNumber| + |x|) + |s|) + G166242)))))))) + (SPADLET |argList| + (PROG (G166271) + (SPADLET G166271 NIL) + (RETURN + (DO ((G166285 |formalArgList| + (CDR G166285)) + (|x| NIL)) + ((OR (ATOM G166285) + (PROGN + (SETQ |x| (CAR G166285)) + NIL)) + (NREVERSE0 G166271)) + (SEQ (EXIT (SETQ G166271 + (CONS + (PROGN + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + 'SUCHTHAT) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ + (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |p| + (QCAR + |ISTMP#2|)) + 'T)))))) + (SPADLET |predList| + (CONS |p| |predList|)) + (SPADLET |x| |s|))) + |x|) + G166271)))))))) + (|mkMapAlias| |op| |argl|) + (SPADLET |argPredList| (NREVERSE |predList|)) + (SPADLET |finalPred| + (MKPF (COND + ((AND |pred| (NEQUAL |pred| 'T)) + (APPEND |argPredList| + (CONS (SUBLISNQ |$sl| |pred|) + NIL))) + ('T |argPredList|)) + '|and|)) + (SPADLET |body| (SUBLISNQ |$sl| |rhs|)) + (SPADLET |oldMap| + (COND + ((SPADLET |obj| + (|get| |op| '|value| + |$InteractiveFrame|)) + (|objVal| |obj|)) + ('T NIL))) + (SPADLET |newMap| + (|augmentMap| |op| |argList| |finalPred| |body| + |oldMap|)) + (COND + ((NULL |newMap|) (|sayRemoveFunctionOrValue| |op|) + (|putHist| |op| '|alias| NIL |$e|) (INTERN " " "BOOT")) + ('T + (COND + ((|get| |op| '|isInterpreterRule| |$e|) + (SPADLET |type| + (CONS '|RuleCalled| (CONS |op| NIL)))) + ('T + (SPADLET |type| + (CONS '|FunctionCalled| (CONS |op| NIL))))) + (SPADLET |recursive| + (COND + ((EQL (|depthOfRecursion| |op| |newMap|) 0) + NIL) + ('T 'T))) + (|putHist| |op| '|recursive| |recursive| |$e|) + (|objNew| |newMap| |type|)))))))) ;augmentMap(op,args,pred,body,oldMap) == ; pattern:= makePattern(args,pred) @@ -454,28 +499,30 @@ ; resultMap (DEFUN |augmentMap| (|op| |args| |pred| |body| |oldMap|) - (PROG (|pattern| |newMap| |entry| |tail| |resultMap|) - (RETURN - (PROGN - (SPADLET |pattern| (|makePattern| |args| |pred|)) - (SPADLET |newMap| (|deleteMap| |op| |pattern| |oldMap|)) - (COND - ((BOOT-EQUAL |body| (INTERN " " "BOOT")) - (COND - ((BOOT-EQUAL |newMap| |oldMap|) - (|sayMSG| (CONS " Cannot find part of" - (APPEND (|bright| |op|) (CONS "to delete." NIL)))))) - |newMap|) - ((QUOTE T) - (SPADLET |entry| (CONS |pattern| |body|)) - (SPADLET |resultMap| - (COND - ((AND (PAIRP |newMap|) - (EQ (QCAR |newMap|) (QUOTE MAP)) - (PROGN (SPADLET |tail| (QCDR |newMap|)) (QUOTE T))) - (CONS (QUOTE MAP) (APPEND |tail| (CONS |entry| NIL)))) - ((QUOTE T) (CONS (QUOTE MAP) (CONS |entry| NIL))))) - |resultMap|)))))) + (PROG (|pattern| |newMap| |entry| |tail| |resultMap|) + (RETURN + (PROGN + (SPADLET |pattern| (|makePattern| |args| |pred|)) + (SPADLET |newMap| (|deleteMap| |op| |pattern| |oldMap|)) + (COND + ((BOOT-EQUAL |body| (INTERN " " "BOOT")) + (COND + ((BOOT-EQUAL |newMap| |oldMap|) + (|sayMSG| + (CONS " Cannot find part of" + (APPEND (|bright| |op|) + (CONS "to delete." NIL)))))) + |newMap|) + ('T (SPADLET |entry| (CONS |pattern| |body|)) + (SPADLET |resultMap| + (COND + ((AND (PAIRP |newMap|) (EQ (QCAR |newMap|) 'MAP) + (PROGN + (SPADLET |tail| (QCDR |newMap|)) + 'T)) + (CONS 'MAP (APPEND |tail| (CONS |entry| NIL)))) + ('T (CONS 'MAP (CONS |entry| NIL))))) + |resultMap|)))))) ;deleteMap(op,pattern,map) == ; map is ["MAP",:tail] => @@ -487,35 +534,42 @@ ; NIL (DEFUN |deleteMap| (|op| |pattern| |map|) - (PROG (|tail| |replacement| |newMap|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |map|) - (EQ (QCAR |map|) (QUOTE MAP)) - (PROGN (SPADLET |tail| (QCDR |map|)) (QUOTE T))) - (SPADLET |newMap| - (CONS (QUOTE MAP) - (PROG (#0=#:G166340) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166346 |tail| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((COND - ((AND (PAIRP |x|) - (EQUAL (QCAR |x|) |pattern|) - (PROGN (SPADLET |replacement| (QCDR |x|)) (QUOTE T))) - (|sayDroppingFunctions| |op| (CONS |x| NIL))) - ((QUOTE T) (QUOTE T))) - (SETQ #0# (CONS |x| #0#))))))))))) - (COND - ((NULL (CDR |newMap|)) NIL) - ((QUOTE T) |newMap|))) - ((QUOTE T) NIL)))))) + (PROG (|tail| |replacement| |newMap|) + (RETURN + (SEQ (COND + ((AND (PAIRP |map|) (EQ (QCAR |map|) 'MAP) + (PROGN (SPADLET |tail| (QCDR |map|)) 'T)) + (SPADLET |newMap| + (CONS 'MAP + (PROG (G166340) + (SPADLET G166340 NIL) + (RETURN + (DO ((G166346 |tail| + (CDR G166346)) + (|x| NIL)) + ((OR (ATOM G166346) + (PROGN + (SETQ |x| (CAR G166346)) + NIL)) + (NREVERSE0 G166340)) + (SEQ + (EXIT + (COND + ((COND + ((AND (PAIRP |x|) + (EQUAL (QCAR |x|) + |pattern|) + (PROGN + (SPADLET |replacement| + (QCDR |x|)) + 'T)) + (|sayDroppingFunctions| |op| + (CONS |x| NIL))) + ('T 'T)) + (SETQ G166340 + (CONS |x| G166340))))))))))) + (COND ((NULL (CDR |newMap|)) NIL) ('T |newMap|))) + ('T NIL)))))) ;getUserIdentifiersIn body == ; null body => nil @@ -537,75 +591,81 @@ ; REMDUP bodyIdList (DEFUN |getUserIdentifiersIn| (|body|) - (PROG (|ISTMP#1| |ISTMP#2| |body1| |itl| |userIds| |op| |l| |argIdList| - |bodyIdList|) - (RETURN - (SEQ - (COND - ((NULL |body|) NIL) - ((IDENTP |body|) - (COND - ((|isSharpVarWithNum| |body|) NIL) - ((BOOT-EQUAL |body| (INTERN " " "BOOT")) NIL) - ((QUOTE T) (CONS |body| NIL)))) - ((AND (PAIRP |body|) (EQ (QCAR |body|) (QUOTE WRAPPED))) NIL) - ((OR - (AND - (PAIRP |body|) - (EQ (QCAR |body|) (QUOTE COLLECT)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T)) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |body1| (QCAR |ISTMP#2|)) - (SPADLET |itl| (QCDR |ISTMP#2|)) - (QUOTE T)) - (PROGN (SPADLET |itl| (NREVERSE |itl|)) (QUOTE T))))) - (AND (PAIRP |body|) - (EQ (QCAR |body|) (QUOTE REPEAT)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T)) - (PAIRP |ISTMP#2|) + (PROG (|ISTMP#1| |ISTMP#2| |body1| |itl| |userIds| |op| |l| + |argIdList| |bodyIdList|) + (RETURN + (SEQ (COND + ((NULL |body|) NIL) + ((IDENTP |body|) + (COND + ((|isSharpVarWithNum| |body|) NIL) + ((BOOT-EQUAL |body| (INTERN " " "BOOT")) NIL) + ('T (CONS |body| NIL)))) + ((AND (PAIRP |body|) (EQ (QCAR |body|) 'WRAPPED)) NIL) + ((OR (AND (PAIRP |body|) (EQ (QCAR |body|) 'COLLECT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |body1| (QCAR |ISTMP#2|)) + (SPADLET |itl| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |itl| (NREVERSE |itl|)) + 'T)))) + (AND (PAIRP |body|) (EQ (QCAR |body|) 'REPEAT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |body1| (QCAR |ISTMP#2|)) + (SPADLET |itl| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |itl| (NREVERSE |itl|)) + 'T))))) + (SPADLET |userIds| + (S+ (|getUserIdentifiersInIterators| |itl|) + (|getUserIdentifiersIn| |body1|))) + (S- |userIds| (|getIteratorIds| |itl|))) + ((AND (PAIRP |body|) + (PROGN + (SPADLET |op| (QCAR |body|)) + (SPADLET |l| (QCDR |body|)) + 'T)) (PROGN - (SPADLET |body1| (QCAR |ISTMP#2|)) - (SPADLET |itl| (QCDR |ISTMP#2|)) - (QUOTE T)) - (PROGN (SPADLET |itl| (NREVERSE |itl|)) (QUOTE T)))))) - (SPADLET |userIds| - (S+ (|getUserIdentifiersInIterators| |itl|) - (|getUserIdentifiersIn| |body1|))) - (S- |userIds| (|getIteratorIds| |itl|))) - ((AND (PAIRP |body|) - (PROGN - (SPADLET |op| (QCAR |body|)) - (SPADLET |l| (QCDR |body|)) - (QUOTE T))) - (PROGN - (SPADLET |argIdList| - (PROG (#0=#:G166391) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166396 |l| (CDR #1#)) (|y| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) #0#) - (SEQ - (EXIT - (SETQ #0# (APPEND #0# (|getUserIdentifiersIn| |y|))))))))) - (SPADLET |bodyIdList| - (COND - ((NULL - (OR - (GETL |op| (QUOTE |Nud|)) - (GETL |op| (QUOTE |Led|)) - (GETL |op| (QUOTE |up|)))) - (NCONC (|getUserIdentifiersIn| |op|) |argIdList|)) - ((QUOTE T) |argIdList|))) - (REMDUP |bodyIdList|)))))))) + (SPADLET |argIdList| + (PROG (G166391) + (SPADLET G166391 NIL) + (RETURN + (DO ((G166396 |l| (CDR G166396)) + (|y| NIL)) + ((OR (ATOM G166396) + (PROGN + (SETQ |y| (CAR G166396)) + NIL)) + G166391) + (SEQ (EXIT + (SETQ G166391 + (APPEND G166391 + (|getUserIdentifiersIn| |y|))))))))) + (SPADLET |bodyIdList| + (COND + ((NULL (OR (GETL |op| '|Nud|) + (GETL |op| '|Led|) + (GETL |op| '|up|))) + (NCONC (|getUserIdentifiersIn| |op|) + |argIdList|)) + ('T |argIdList|))) + (REMDUP |bodyIdList|)))))))) ;getUserIdentifiersInIterators itl == ; for x in itl repeat @@ -620,77 +680,99 @@ ; REMDUP varList (DEFUN |getUserIdentifiersInIterators| (|itl|) - (PROG (|i| |l| |ISTMP#2| |y| |op| |ISTMP#1| |a| |varList|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G166485 |itl| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE STEP)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |i| (QCAR |ISTMP#1|)) - (SPADLET |l| (QCDR |ISTMP#1|)) - (QUOTE T))))) - (SPADLET |varList| - (APPEND - (PROG (#1=#:G166491) - (SPADLET #1# NIL) - (RETURN - (DO ((#2=#:G166496 |l| (CDR #2#)) (|y| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |y| (CAR #2#)) NIL)) #1#) - (SEQ - (EXIT - (SETQ #1# (APPEND #1# (|getUserIdentifiersIn| |y|)))))))) - |varList|))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE IN)) - (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 |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (SPADLET |varList| (APPEND (|getUserIdentifiersIn| |y|) |varList|))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE ON)) - (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 |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (SPADLET |varList| (APPEND (|getUserIdentifiersIn| |y|) |varList|))) - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) - (|member| |op| (QUOTE (|\|| WHILE UNTIL)))) - (SPADLET |varList| (APPEND (|getUserIdentifiersIn| |a|) |varList|))) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "getUserIdentifiersInIterators" - (CONS "unknown iterator construct" NIL)))))))) - (REMDUP |varList|)))))) + (PROG (|i| |l| |ISTMP#2| |y| |op| |ISTMP#1| |a| |varList|) + (RETURN + (SEQ (PROGN + (DO ((G166485 |itl| (CDR G166485)) (|x| NIL)) + ((OR (ATOM G166485) + (PROGN (SETQ |x| (CAR G166485)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |i| (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + 'T)))) + (SPADLET |varList| + (APPEND + (PROG (G166491) + (SPADLET G166491 NIL) + (RETURN + (DO + ((G166496 |l| + (CDR G166496)) + (|y| NIL)) + ((OR (ATOM G166496) + (PROGN + (SETQ |y| + (CAR G166496)) + NIL)) + G166491) + (SEQ + (EXIT + (SETQ G166491 + (APPEND G166491 + (|getUserIdentifiersIn| + |y|)))))))) + |varList|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IN) + (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 |y| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |varList| + (APPEND + (|getUserIdentifiersIn| |y|) + |varList|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'ON) + (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 |y| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |varList| + (APPEND + (|getUserIdentifiersIn| |y|) + |varList|))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + 'T))) + (|member| |op| '(|\|| WHILE UNTIL))) + (SPADLET |varList| + (APPEND + (|getUserIdentifiersIn| |a|) + |varList|))) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS "getUserIdentifiersInIterators" + (CONS + "unknown iterator construct" + NIL)))))))) + (REMDUP |varList|)))))) ;getIteratorIds itl == ; for x in itl repeat @@ -701,41 +783,40 @@ ; varList (DEFUN |getIteratorIds| (|itl|) - (PROG (|i| |ISTMP#1| |y| |varList|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G166551 |itl| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE STEP)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |i| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |varList| (CONS |i| |varList|))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE IN)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |varList| (CONS |y| |varList|))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE ON)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |varList| (CONS |y| |varList|))) - ((QUOTE T) NIL))))) - |varList|))))) + (PROG (|i| |ISTMP#1| |y| |varList|) + (RETURN + (SEQ (PROGN + (DO ((G166551 |itl| (CDR G166551)) (|x| NIL)) + ((OR (ATOM G166551) + (PROGN (SETQ |x| (CAR G166551)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |i| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |varList| (CONS |i| |varList|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |varList| (CONS |y| |varList|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'ON) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |varList| (CONS |y| |varList|))) + ('T NIL))))) + |varList|))))) ;makeArgumentIntoNumber x == ; x=$Zero => 0 @@ -745,26 +826,22 @@ ; [removeZeroOne first x,:removeZeroOne rest x] (DEFUN |makeArgumentIntoNumber| (|x|) - (PROG (|ISTMP#1| |n|) - (RETURN - (COND - ((BOOT-EQUAL |x| |$Zero|) 0) - ((BOOT-EQUAL |x| |$One|) 1) - ((ATOM |x|) |x|) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE -)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |n| (QCAR |ISTMP#1|)) - (QUOTE T)))) - (NUMBERP |n|)) - (SPADDIFFERENCE |n|)) - ((QUOTE T) - (CONS (|removeZeroOne| (CAR |x|)) (|removeZeroOne| (CDR |x|)))))))) + (PROG (|ISTMP#1| |n|) + (DECLARE (SPECIAL |$One| |$Zero|)) + (RETURN + (COND + ((BOOT-EQUAL |x| |$Zero|) 0) + ((BOOT-EQUAL |x| |$One|) 1) + ((ATOM |x|) |x|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '-) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |n| (QCAR |ISTMP#1|)) 'T))) + (NUMBERP |n|)) + (SPADDIFFERENCE |n|)) + ('T + (CONS (|removeZeroOne| (CAR |x|)) (|removeZeroOne| (CDR |x|)))))))) ;mkMapAlias(op,argl) == ; u:= mkAliasList argl @@ -774,31 +851,36 @@ ; $e:= putHist(op,"alias",newAlias,$e) (DEFUN |mkMapAlias| (|op| |argl|) - (PROG (|u| |alias| |newAlias|) - (RETURN - (SEQ - (PROGN - (SPADLET |u| (|mkAliasList| |argl|)) - (SPADLET |newAlias| - (COND - ((SPADLET |alias| (|get| |op| (QUOTE |alias|) |$e|)) - (PROG (#0=#:G166587) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166593 |alias| (CDR #1#)) - (|x| NIL) - (#2=#:G166594 |u| (CDR #2#)) - (|y| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |x| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |y| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (COND (|y| |y|) ((QUOTE T) |x|)) #0#)))))))) - ((QUOTE T) |u|))) - (SPADLET |$e| (|putHist| |op| (QUOTE |alias|) |newAlias| |$e|))))))) + (PROG (|u| |alias| |newAlias|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (SEQ (PROGN + (SPADLET |u| (|mkAliasList| |argl|)) + (SPADLET |newAlias| + (COND + ((SPADLET |alias| (|get| |op| '|alias| |$e|)) + (PROG (G166587) + (SPADLET G166587 NIL) + (RETURN + (DO ((G166593 |alias| (CDR G166593)) + (|x| NIL) + (G166594 |u| (CDR G166594)) + (|y| NIL)) + ((OR (ATOM G166593) + (PROGN + (SETQ |x| (CAR G166593)) + NIL) + (ATOM G166594) + (PROGN + (SETQ |y| (CAR G166594)) + NIL)) + (NREVERSE0 G166587)) + (SEQ (EXIT + (SETQ G166587 + (CONS (COND (|y| |y|) ('T |x|)) + G166587)))))))) + ('T |u|))) + (SPADLET |$e| (|putHist| |op| '|alias| |newAlias| |$e|))))))) ;mkAliasList l == fn(l,nil) where fn(l,acc) == ; null l => NREVERSE acc @@ -806,13 +888,14 @@ ; fn(rest l,[first l,:acc]) (DEFUN |mkAliasList,fn| (|l| |acc|) - (SEQ - (IF (NULL |l|) (EXIT (NREVERSE |acc|))) - (IF (OR (NULL (IDENTP (CAR |l|))) (|member| (CAR |l|) |acc|)) - (EXIT (|mkAliasList,fn| (CDR |l|) (CONS NIL |acc|)))) - (EXIT (|mkAliasList,fn| (CDR |l|) (CONS (CAR |l|) |acc|))))) + (SEQ (IF (NULL |l|) (EXIT (NREVERSE |acc|))) + (IF (OR (NULL (IDENTP (CAR |l|))) (|member| (CAR |l|) |acc|)) + (EXIT (|mkAliasList,fn| (CDR |l|) (CONS NIL |acc|)))) + (EXIT (|mkAliasList,fn| (CDR |l|) (CONS (CAR |l|) |acc|))))) + (DEFUN |mkAliasList| (|l|) (|mkAliasList,fn| |l| NIL)) + ;args2Tuple args == ; args is [first,:rest] => ; null rest => first @@ -820,16 +903,16 @@ ; nil (DEFUN |args2Tuple| (|args|) - (PROG (CAR CDR) - (RETURN - (COND - ((AND (PAIRP |args|) - (PROGN - (SPADLET CAR (QCAR |args|)) - (SPADLET CDR (QCDR |args|)) - (QUOTE T))) - (COND ((NULL CDR) CAR) ((QUOTE T) (CONS (QUOTE |Tuple|) |args|)))) - ((QUOTE T) NIL))))) + (PROG (CAR CDR) + (RETURN + (COND + ((AND (PAIRP |args|) + (PROGN + (SPADLET CAR (QCAR |args|)) + (SPADLET CDR (QCDR |args|)) + 'T)) + (COND ((NULL CDR) CAR) ('T (CONS '|Tuple| |args|)))) + ('T NIL))))) ;makePattern(args,pred) == ; nargs:= #args @@ -840,42 +923,41 @@ ; addPatternPred(["Tuple",:TAKE(nargs,$FormalMapVariableList)],pred) (DEFUN |makePattern| (|args| |pred|) - (PROG (|nargs| |ISTMP#1| |ISTMP#2| |n| |u|) - (RETURN - (PROGN - (SPADLET |nargs| (|#| |args|)) - (COND - ((EQL |nargs| 1) - (COND - ((AND (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE =)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |#1|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |n| (QCAR |ISTMP#2|)) (QUOTE T))))))) - |n|) - ((QUOTE T) (|addPatternPred| (QUOTE |#1|) |pred|)))) - ((SPADLET |u| (|canMakeTuple| |nargs| |pred|)) |u|) - ((QUOTE T) - (|addPatternPred| - (CONS (QUOTE |Tuple|) (TAKE |nargs| |$FormalMapVariableList|)) - |pred|))))))) + (PROG (|nargs| |ISTMP#1| |ISTMP#2| |n| |u|) + (DECLARE (SPECIAL |$FormalMapVariableList|)) + (RETURN + (PROGN + (SPADLET |nargs| (|#| |args|)) + (COND + ((EQL |nargs| 1) + (COND + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) '=) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |n| (QCAR |ISTMP#2|)) + 'T)))))) + |n|) + ('T (|addPatternPred| '|#1| |pred|)))) + ((SPADLET |u| (|canMakeTuple| |nargs| |pred|)) |u|) + ('T + (|addPatternPred| + (CONS '|Tuple| (TAKE |nargs| |$FormalMapVariableList|)) + |pred|))))))) ;addPatternPred(arg,pred) == ; pred=true => arg ; ["|",arg,pred] (DEFUN |addPatternPred| (|arg| |pred|) - (COND - ((BOOT-EQUAL |pred| (QUOTE T)) |arg|) - ((QUOTE T) (CONS (QUOTE |\||) (CONS |arg| (CONS |pred| NIL)))))) + (COND + ((BOOT-EQUAL |pred| 'T) |arg|) + ('T (CONS '|\|| (CONS |arg| (CONS |pred| NIL)))))) ;canMakeTuple(nargs,pred) == ; pred is ["and",:l] and nargs=#l and @@ -884,50 +966,61 @@ ; ["Tuple",:u] (DEFUN |canMakeTuple| (|nargs| |pred|) - (PROG (|l| |ISTMP#1| |ISTMP#2| |a| |u|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE |and|)) - (PROGN (SPADLET |l| (QCDR |pred|)) (QUOTE T)) - (BOOT-EQUAL |nargs| (|#| |l|)) - (SPADLET |u| - (PROG (#0=#:G166675) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166687 |$FormalMapVariableList| (CDR #1#)) - (|y| NIL) - (#2=#:G166688 (|orderList| |l|) (CDR #2#)) - (|x| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |y| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |x| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (COND - ((AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE =)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |y|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#2|)) (QUOTE T))))))) - |a|) - ((QUOTE T) (RETURN NIL))) - #0#))))))))) - (EXIT (CONS (QUOTE |Tuple|) |u|)))))))) + (PROG (|l| |ISTMP#1| |ISTMP#2| |a| |u|) + (DECLARE (SPECIAL |$FormalMapVariableList|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) '|and|) + (PROGN (SPADLET |l| (QCDR |pred|)) 'T) + (BOOT-EQUAL |nargs| (|#| |l|)) + (SPADLET |u| + (PROG (G166675) + (SPADLET G166675 NIL) + (RETURN + (DO ((G166687 + |$FormalMapVariableList| + (CDR G166687)) + (|y| NIL) + (G166688 (|orderList| |l|) + (CDR G166688)) + (|x| NIL)) + ((OR (ATOM G166687) + (PROGN + (SETQ |y| (CAR G166687)) + NIL) + (ATOM G166688) + (PROGN + (SETQ |x| (CAR G166688)) + NIL)) + (NREVERSE0 G166675)) + (SEQ (EXIT + (SETQ G166675 + (CONS + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '=) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL + (QCAR |ISTMP#1|) |y|) + (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 (RETURN NIL))) + G166675))))))))) + (EXIT (CONS '|Tuple| |u|)))))))) ;sayRemoveFunctionOrValue x == ; (obj := getValue x) and (md := objMode obj) => @@ -937,24 +1030,29 @@ ; sayMessage ['" ",:bright x,'"has no value so this does nothing."] (DEFUN |sayRemoveFunctionOrValue| (|x|) - (PROG (|obj| |md|) - (RETURN - (COND - ((AND (SPADLET |obj| (|getValue| |x|)) (SPADLET |md| (|objMode| |obj|))) - (COND - ((BOOT-EQUAL |md| |$EmptyMode|) - (|sayMessage| - (CONS " " - (APPEND (|bright| |x|) (CONS "now has no function parts." NIL))))) - ((QUOTE T) - (|sayMessage| - (CONS " value for" - (APPEND (|bright| |x|) (CONS "has been removed." NIL))))))) - ((QUOTE T) - (|sayMessage| - (CONS " " - (APPEND (|bright| |x|) - (CONS "has no value so this does nothing." NIL))))))))) + (PROG (|obj| |md|) + (DECLARE (SPECIAL |$EmptyMode|)) + (RETURN + (COND + ((AND (SPADLET |obj| (|getValue| |x|)) + (SPADLET |md| (|objMode| |obj|))) + (COND + ((BOOT-EQUAL |md| |$EmptyMode|) + (|sayMessage| + (CONS " " + (APPEND (|bright| |x|) + (CONS "now has no function parts." NIL))))) + ('T + (|sayMessage| + (CONS " value for" + (APPEND (|bright| |x|) + (CONS "has been removed." NIL))))))) + ('T + (|sayMessage| + (CONS " " + (APPEND (|bright| |x|) + (CONS "has no value so this does nothing." + NIL))))))))) ;sayDroppingFunctions(op,l) == ; sayKeyedMsg("S2IM0017",[#l,op]) @@ -964,39 +1062,42 @@ ; nil (DEFUN |sayDroppingFunctions| (|op| |l|) - (PROG (|pattern| |replacement|) - (RETURN - (SEQ - (PROGN - (|sayKeyedMsg| (QUOTE S2IM0017) (CONS (|#| |l|) (CONS |op| NIL))) - (COND - (|$displayDroppedMap| - (DO ((#0=#:G166722 |l| (CDR #0#)) (#1=#:G166713 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |pattern| (CAR #1#)) - (SPADLET |replacement| (CDR #1#)) - #1#) - NIL)) - NIL) - (SEQ (EXIT (|displaySingleRule| |op| |pattern| |replacement|)))))) - NIL))))) + (PROG (|pattern| |replacement|) + (DECLARE (SPECIAL |$displayDroppedMap|)) + (RETURN + (SEQ (PROGN + (|sayKeyedMsg| 'S2IM0017 (CONS (|#| |l|) (CONS |op| NIL))) + (COND + (|$displayDroppedMap| + (DO ((G166722 |l| (CDR G166722)) + (G166713 NIL)) + ((OR (ATOM G166722) + (PROGN + (SETQ G166713 (CAR G166722)) + NIL) + (PROGN + (PROGN + (SPADLET |pattern| (CAR G166713)) + (SPADLET |replacement| (CDR G166713)) + G166713) + NIL)) + NIL) + (SEQ (EXIT (|displaySingleRule| |op| |pattern| + |replacement|)))))) + NIL))))) ;makeRuleForm(op,pattern)== ; pattern is ["Tuple",:l] => [op,:l] ; [op,:pattern] (DEFUN |makeRuleForm| (|op| |pattern|) - (PROG (|l|) - (RETURN - (COND - ((AND (PAIRP |pattern|) - (EQ (QCAR |pattern|) (QUOTE |Tuple|)) - (PROGN (SPADLET |l| (QCDR |pattern|)) (QUOTE T))) - (CONS |op| |l|)) - ((QUOTE T) (CONS |op| |pattern|)))))) + (PROG (|l|) + (RETURN + (COND + ((AND (PAIRP |pattern|) (EQ (QCAR |pattern|) '|Tuple|) + (PROGN (SPADLET |l| (QCDR |pattern|)) 'T)) + (CONS |op| |l|)) + ('T (CONS |op| |pattern|)))))) ;mkFormalArg(x,s) == ; isConstantArgument x => ["SUCHTHAT",s,["=",s,x]] @@ -1008,49 +1109,49 @@ ; ['SUCHTHAT,s,["=",s,x]] (DEFUN |mkFormalArg| (|x| |s|) - (PROG (|y|) - (RETURN - (COND - ((|isConstantArgument| |x|) - (CONS - (QUOTE SUCHTHAT) - (CONS |s| (CONS (CONS (QUOTE =) (CONS |s| (CONS |x| NIL))) NIL)))) - ((|isPatternArgument| |x|) - (CONS - (QUOTE SUCHTHAT) - (CONS |s| (CONS (CONS (QUOTE |is|) (CONS |s| (CONS |x| NIL))) NIL)))) - ((IDENTP |x|) - (COND - ((SPADLET |y| (LASSOC |x| |$sl|)) - (CONS - (QUOTE SUCHTHAT) - (CONS |s| (CONS (CONS (QUOTE =) (CONS |s| (CONS |y| NIL))) NIL)))) - ((QUOTE T) (SPADLET |$sl| (CONS (CONS |x| |s|) |$sl|)) |s|))) - ((QUOTE T) - (CONS - (QUOTE SUCHTHAT) - (CONS |s| (CONS (CONS (QUOTE =) (CONS |s| (CONS |x| NIL))) NIL)))))))) + (PROG (|y|) + (DECLARE (SPECIAL |$sl|)) + (RETURN + (COND + ((|isConstantArgument| |x|) + (CONS 'SUCHTHAT + (CONS |s| + (CONS (CONS '= (CONS |s| (CONS |x| NIL))) NIL)))) + ((|isPatternArgument| |x|) + (CONS 'SUCHTHAT + (CONS |s| + (CONS (CONS '|is| (CONS |s| (CONS |x| NIL))) NIL)))) + ((IDENTP |x|) + (COND + ((SPADLET |y| (LASSOC |x| |$sl|)) + (CONS 'SUCHTHAT + (CONS |s| + (CONS (CONS '= (CONS |s| (CONS |y| NIL))) NIL)))) + ('T (SPADLET |$sl| (CONS (CONS |x| |s|) |$sl|)) |s|))) + ('T + (CONS 'SUCHTHAT + (CONS |s| + (CONS (CONS '= (CONS |s| (CONS |x| NIL))) NIL)))))))) ;isConstantArgument x == ; NUMBERP x => x ; x is ["QUOTE",.] => x (DEFUN |isConstantArgument| (|x|) - (PROG (|ISTMP#1|) - (RETURN - (COND - ((NUMBERP |x|) |x|) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE QUOTE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - |x|))))) + (PROG (|ISTMP#1|) + (RETURN + (COND + ((NUMBERP |x|) |x|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + |x|))))) ;isPatternArgument x == x is ["construct",:.] (DEFUN |isPatternArgument| (|x|) - (AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE |construct|)))) + (AND (PAIRP |x|) (EQ (QCAR |x|) '|construct|))) ;--% Map dependencies ;makeNewDependencies (op, userVariables) == @@ -1060,12 +1161,11 @@ ; :makeNewDependencies (op, rest userVariables)] (DEFUN |makeNewDependencies| (|op| |userVariables|) - (COND - ((NULL |userVariables|) NIL) - ((QUOTE T) - (CONS - (CONS (CAR |userVariables|) (CONS |op| NIL)) - (|makeNewDependencies| |op| (CDR |userVariables|)))))) + (COND + ((NULL |userVariables|) NIL) + ('T + (CONS (CONS (CAR |userVariables|) (CONS |op| NIL)) + (|makeNewDependencies| |op| (CDR |userVariables|)))))) ;putDependencies (op, dependencies) == ; oldDependencies := getFlag "$dependencies" @@ -1087,36 +1187,38 @@ ; putFlag ("$dependencies", newDependencies) (DEFUN |putDependencies,removeObsoleteDependencies| (|op| |oldDep|) - (SEQ - (IF (NULL |oldDep|) (EXIT NIL)) - (IF (BOOT-EQUAL |op| (CDR (CAR |oldDep|))) - (EXIT (|putDependencies,removeObsoleteDependencies| |op| (CDR |oldDep|)))) - (EXIT - (CONS - (CAR |oldDep|) - (|putDependencies,removeObsoleteDependencies| |op| (CDR |oldDep|)))))) + (SEQ (IF (NULL |oldDep|) (EXIT NIL)) + (IF (BOOT-EQUAL |op| (CDR (CAR |oldDep|))) + (EXIT (|putDependencies,removeObsoleteDependencies| |op| + (CDR |oldDep|)))) + (EXIT (CONS (CAR |oldDep|) + (|putDependencies,removeObsoleteDependencies| |op| + (CDR |oldDep|)))))) (DEFUN |putDependencies| (|op| |dependencies|) - (PROG (|oldDependencies| |newDependencies|) - (RETURN - (PROGN - (SPADLET |oldDependencies| (|getFlag| (QUOTE |$dependencies|))) - (SPADLET |oldDependencies| - (|putDependencies,removeObsoleteDependencies| |op| |oldDependencies|)) - (SPADLET |newDependencies| (|union| |dependencies| |oldDependencies|)) - (|putFlag| (QUOTE |$dependencies|) |newDependencies|))))) + (PROG (|oldDependencies| |newDependencies|) + (RETURN + (PROGN + (SPADLET |oldDependencies| (|getFlag| '|$dependencies|)) + (SPADLET |oldDependencies| + (|putDependencies,removeObsoleteDependencies| |op| + |oldDependencies|)) + (SPADLET |newDependencies| + (|union| |dependencies| |oldDependencies|)) + (|putFlag| '|$dependencies| |newDependencies|))))) ;clearDependencies(x,clearLocalModemapsIfTrue) == ; $dependencies: local:= COPY getFlag "$dependencies" ; clearDep1(x,nil,nil,$dependencies) (DEFUN |clearDependencies| (|x| |clearLocalModemapsIfTrue|) - (PROG (|$dependencies|) - (DECLARE (SPECIAL |$dependencies|)) - (RETURN - (PROGN - (SPADLET |$dependencies| (COPY (|getFlag| (QUOTE |$dependencies|)))) - (|clearDep1| |x| NIL NIL |$dependencies|))))) + (declare (ignore |clearLocalModemapsIfTrue|)) + (PROG (|$dependencies|) + (DECLARE (SPECIAL |$dependencies|)) + (RETURN + (PROGN + (SPADLET |$dependencies| (COPY (|getFlag| '|$dependencies|))) + (|clearDep1| |x| NIL NIL |$dependencies|))))) ;clearDep1(x,toDoList,doneList,depList) == ; x in doneList => nil @@ -1132,34 +1234,31 @@ ; 'done (DEFUN |clearDep1| (|x| |toDoList| |doneList| |depList|) - (PROG (|newDone| |a| |res|) - (RETURN - (SEQ - (COND - ((|member| |x| |doneList|) NIL) - ((QUOTE T) - (|clearCache| |x|) - (SPADLET |newDone| (CONS |x| |doneList|)) - (DO ((#0=#:G166792 NIL (NULL |a|))) - (#0# NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |a| (ASSQ |x| |depList|)) - (COND - (|a| - (PROGN - (SPADLET |depList| (|delete| |a| |depList|)) - (SPADLET |toDoList| - (|union| |toDoList| (SETDIFFERENCE (CDR |a|) |doneList|)))))))))) - (COND - ((AND (PAIRP |toDoList|) - (PROGN - (SPADLET |a| (QCAR |toDoList|)) - (SPADLET |res| (QCDR |toDoList|)) - (QUOTE T))) - (|clearDep1| |a| |res| |newDone| |depList|)) - ((QUOTE T) (QUOTE |done|))))))))) + (PROG (|newDone| |a| |res|) + (RETURN + (SEQ (COND + ((|member| |x| |doneList|) NIL) + ('T (|clearCache| |x|) + (SPADLET |newDone| (CONS |x| |doneList|)) + (DO ((G166792 NIL (NULL |a|))) (G166792 NIL) + (SEQ (EXIT (PROGN + (SPADLET |a| (ASSQ |x| |depList|)) + (COND + (|a| (PROGN + (SPADLET |depList| + (|delete| |a| |depList|)) + (SPADLET |toDoList| + (|union| |toDoList| + (SETDIFFERENCE (CDR |a|) + |doneList|)))))))))) + (COND + ((AND (PAIRP |toDoList|) + (PROGN + (SPADLET |a| (QCAR |toDoList|)) + (SPADLET |res| (QCDR |toDoList|)) + 'T)) + (|clearDep1| |a| |res| |newDone| |depList|)) + ('T '|done|)))))))) ;--% Formatting and displaying maps ;displayRule(op,rule) == @@ -1168,12 +1267,13 @@ ; nil (DEFUN |displayRule| (|op| |rule|) - (COND - ((NULL |rule|) NIL) - ((QUOTE T) - (|mathprint| - (CONS (QUOTE CONCAT) (CONS (QUOTE |Definition: |) (CONS |rule| NIL)))) - NIL))) + (declare (ignore |op|)) + (COND + ((NULL |rule|) NIL) + ('T + (|mathprint| + (CONS 'CONCAT (CONS '|Definition: | (CONS |rule| NIL)))) + NIL))) ;outputFormat(x,m) == ; -- this is largely junk and is being phased out @@ -1189,33 +1289,35 @@ ; objValUnwrap T (DEFUN |outputFormat| (|x| |m|) - (PROG (T$) - (RETURN - (COND - ((IDENTP |m|) |x|) - ((OR (BOOT-EQUAL |m| |$OutputForm|) (BOOT-EQUAL |m| |$EmptyMode|)) |x|) - ((|categoryForm?| |m|) |x|) - ((|isMapExpr| |x|) |x|) - ((|containsVars| |x|) |x|) - ((AND (ATOM |x|) (BOOT-EQUAL (CAR |m|) (QUOTE |List|))) |x|) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |construct|)) - (BOOT-EQUAL |m| (QUOTE (|List| (|Expression|))))) - |x|) - ((QUOTE T) - (SPADLET T$ - (OR - (|coerceInteractive| - (|objNewWrap| |x| (|maximalSuperType| |m|)) |$OutputForm|) - (RETURN |x|))) - (|objValUnwrap| T$)))))) + (PROG (T$) + (DECLARE (SPECIAL |$OutputForm| |$EmptyMode| |$OutputForm|)) + (RETURN + (COND + ((IDENTP |m|) |x|) + ((OR (BOOT-EQUAL |m| |$OutputForm|) + (BOOT-EQUAL |m| |$EmptyMode|)) + |x|) + ((|categoryForm?| |m|) |x|) + ((|isMapExpr| |x|) |x|) + ((|containsVars| |x|) |x|) + ((AND (ATOM |x|) (BOOT-EQUAL (CAR |m|) '|List|)) |x|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|construct|) + (BOOT-EQUAL |m| '(|List| (|Expression|)))) + |x|) + ('T + (SPADLET T$ + (OR (|coerceInteractive| + (|objNewWrap| |x| (|maximalSuperType| |m|)) + |$OutputForm|) + (RETURN |x|))) + (|objValUnwrap| T$)))))) ;displaySingleRule($op,pattern,replacement) == ; mathprint ['MAP,[pattern,:replacement]] (DEFUN |displaySingleRule| (|$op| |pattern| |replacement|) - (DECLARE (SPECIAL |$op|)) - (|mathprint| (CONS (QUOTE MAP) (CONS (CONS |pattern| |replacement|) NIL)))) + (DECLARE (SPECIAL |$op|)) + (|mathprint| (CONS 'MAP (CONS (CONS |pattern| |replacement|) NIL)))) ;displayMap(headingIfTrue,$op,map) == ; mathprint @@ -1223,12 +1325,12 @@ ; map (DEFUN |displayMap| (|headingIfTrue| |$op| |map|) - (DECLARE (SPECIAL |$op|)) + (DECLARE (SPECIAL |$op|)) (|mathprint| - (COND - (|headingIfTrue| - (CONS (QUOTE CONCAT) (CONS (PNAME (QUOTE |value: |)) (CONS |map| NIL)))) - ((QUOTE T) |map|)))) + (COND + (|headingIfTrue| + (CONS 'CONCAT (CONS (PNAME '|value: |) (CONS |map| NIL)))) + ('T |map|)))) ;simplifyMapPattern (x,alias) == ; for a in alias @@ -1255,106 +1357,104 @@ ; x (DEFUN |simplifyMapPattern,unTrivialize| (|x|) - (PROG (|l| |op| |ISTMP#1| |a| |ISTMP#2|) - (RETURN - (SEQ - (IF (AND - (AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |l| (QCDR |x|)) - (QUOTE T))) - (|member| |op| (QUOTE (|and| |or|)))) - (EXIT - (MKPF - (PROG (#0=#:G166866) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166871 |l| (CDR #1#)) (|y| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|simplifyMapPattern,unTrivialize| |y|) #0#))))))) - |op|))) - (IF (AND - (AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (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) - (EQUAL (QCAR |ISTMP#2|) |a|)))))) - (|member| |op| (QUOTE (= |is|)))) - (EXIT (QUOTE T))) - (EXIT |x|))))) + (PROG (|l| |op| |ISTMP#1| |a| |ISTMP#2|) + (RETURN + (SEQ (IF (AND (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |l| (QCDR |x|)) + 'T)) + (|member| |op| '(|and| |or|))) + (EXIT (MKPF (PROG (G166866) + (SPADLET G166866 NIL) + (RETURN + (DO ((G166871 |l| (CDR G166871)) + (|y| NIL)) + ((OR (ATOM G166871) + (PROGN + (SETQ |y| (CAR G166871)) + NIL)) + (NREVERSE0 G166866)) + (SEQ (EXIT + (SETQ G166866 + (CONS + (|simplifyMapPattern,unTrivialize| + |y|) + G166866))))))) + |op|))) + (IF (AND (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (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) + (EQUAL (QCAR |ISTMP#2|) |a|)))))) + (|member| |op| '(= |is|))) + (EXIT 'T)) + (EXIT |x|))))) (DEFUN |simplifyMapPattern| (|x| |alias|) - (PROG (|lhs| |rhs| |ISTMP#1| |y| |ISTMP#2| |sl| |y'| |pred| |rhs'|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G166896 |alias| (CDR #0#)) - (|a| NIL) - (#1=#:G166897 |$FormalMapVariableList| (CDR #1#)) - (|m| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |a| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |m| (CAR #1#)) NIL)) - NIL) - (SEQ - (EXIT - (COND - ((AND |a| (NULL (CONTAINED |a| |x|))) - (SPADLET |x| (MSUBST |a| |m| |x|))))))) - (SPADLET |lhs| (CAR |x|)) - (SPADLET |rhs| (CDR |x|)) - (SPADLET |rhs| (|simplifyMapConstructorRefs| |rhs|)) - (SPADLET |x| (CONS |lhs| |rhs|)) - (COND - ((AND (PAIRP |lhs|) - (EQ (QCAR |lhs|) (QUOTE |\||)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |lhs|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |pred| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (SPADLET |pred| (|predTran| |pred|)) - (COND - ((SPADLET |sl| (|getEqualSublis| |pred|)) - (SPADLET |y'| (SUBLIS |sl| |y|)) - (SPADLET |pred| - (|simplifyMapPattern,unTrivialize| (SUBLIS |sl| |pred|))) - (SPADLET |rhs'| (SUBLIS |sl| |rhs|)) - (COND - ((BOOT-EQUAL |pred| (QUOTE T)) (CONS |y'| |rhs'|)) - ((QUOTE T) - (CONS - (CONS - (QUOTE PAREN) - (CONS (CONS (QUOTE |\||) (CONS |y'| (CONS |pred| NIL))) NIL)) - |rhs'|)))) - ((BOOT-EQUAL |pred| (QUOTE T)) (CONS |y| |rhs|)) - ((QUOTE T) - (CONS - (CONS - (QUOTE PAREN) - (CONS (CONS (QUOTE |\||) (CONS |y| (CONS |pred| NIL))) NIL)) - |rhs|)))) - ((BOOT-EQUAL |lhs| (QUOTE T)) (CONS (QUOTE |true|) |rhs|)) - ((QUOTE T) |x|))))))) + (PROG (|lhs| |rhs| |ISTMP#1| |y| |ISTMP#2| |sl| |y'| |pred| |rhs'|) + (DECLARE (SPECIAL |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (DO ((G166896 |alias| (CDR G166896)) (|a| NIL) + (G166897 |$FormalMapVariableList| (CDR G166897)) + (|m| NIL)) + ((OR (ATOM G166896) + (PROGN (SETQ |a| (CAR G166896)) NIL) + (ATOM G166897) + (PROGN (SETQ |m| (CAR G166897)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND |a| (NULL (CONTAINED |a| |x|))) + (SPADLET |x| (MSUBST |a| |m| |x|))))))) + (SPADLET |lhs| (CAR |x|)) + (SPADLET |rhs| (CDR |x|)) + (SPADLET |rhs| (|simplifyMapConstructorRefs| |rhs|)) + (SPADLET |x| (CONS |lhs| |rhs|)) + (COND + ((AND (PAIRP |lhs|) (EQ (QCAR |lhs|) '|\||) + (PROGN + (SPADLET |ISTMP#1| (QCDR |lhs|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |pred| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |pred| (|predTran| |pred|)) + (COND + ((SPADLET |sl| (|getEqualSublis| |pred|)) + (SPADLET |y'| (SUBLIS |sl| |y|)) + (SPADLET |pred| + (|simplifyMapPattern,unTrivialize| + (SUBLIS |sl| |pred|))) + (SPADLET |rhs'| (SUBLIS |sl| |rhs|)) + (COND + ((BOOT-EQUAL |pred| 'T) (CONS |y'| |rhs'|)) + ('T + (CONS (CONS 'PAREN + (CONS (CONS '|\|| + (CONS |y'| (CONS |pred| NIL))) + NIL)) + |rhs'|)))) + ((BOOT-EQUAL |pred| 'T) (CONS |y| |rhs|)) + ('T + (CONS (CONS 'PAREN + (CONS (CONS '|\|| + (CONS |y| (CONS |pred| NIL))) + NIL)) + |rhs|)))) + ((BOOT-EQUAL |lhs| 'T) (CONS '|true| |rhs|)) + ('T |x|))))))) ;simplifyMapConstructorRefs form == ; -- try to linear format constructor names @@ -1378,58 +1478,71 @@ ; form (DEFUN |simplifyMapConstructorRefs| (|form|) - (PROG (|op| |args| |obj| |ISTMP#1| |dom| |dom'| |dom''|) - (RETURN - (SEQ - (COND - ((ATOM |form|) |form|) - ((QUOTE T) - (SPADLET |op| (CAR |form|)) - (SPADLET |args| (CDR |form|)) - (COND - ((|member| |op| (QUOTE (|exit| SEQ))) - (CONS |op| - (PROG (#0=#:G166943) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166948 |args| (CDR #1#)) (|a| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |a| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|simplifyMapConstructorRefs| |a|) #0#))))))))) - ((|member| |op| (QUOTE (REPEAT))) - (CONS |op| - (CONS - (CAR |args|) - (PROG (#2=#:G166958) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G166963 (CDR |args|) (CDR #3#)) (|a| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |a| (CAR #3#)) NIL)) - (NREVERSE0 #2#)) - (SEQ - (EXIT - (SETQ #2# (CONS (|simplifyMapConstructorRefs| |a|) #2#)))))))))) - ((|member| |op| (QUOTE (|:| |::| @))) - (COND - ((AND (PAIRP |args|) - (PROGN - (SPADLET |obj| (QCAR |args|)) - (SPADLET |ISTMP#1| (QCDR |args|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |dom| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |dom'| (|prefix2String| |dom|)) - (SPADLET |dom''| - (COND - ((ATOM |dom'|) |dom'|) - ((NULL (CDR |dom'|)) (CAR |dom'|)) - ((QUOTE T) (APPLY (QUOTE CONCAT) |dom'|)))) - (CONS |op| (CONS |obj| (CONS |dom''| NIL)))) - ((QUOTE T) |form|))) - ((QUOTE T) |form|)))))))) + (PROG (|op| |args| |obj| |ISTMP#1| |dom| |dom'| |dom''|) + (RETURN + (SEQ (COND + ((ATOM |form|) |form|) + ('T (SPADLET |op| (CAR |form|)) + (SPADLET |args| (CDR |form|)) + (COND + ((|member| |op| '(|exit| SEQ)) + (CONS |op| + (PROG (G166943) + (SPADLET G166943 NIL) + (RETURN + (DO ((G166948 |args| (CDR G166948)) + (|a| NIL)) + ((OR (ATOM G166948) + (PROGN + (SETQ |a| (CAR G166948)) + NIL)) + (NREVERSE0 G166943)) + (SEQ (EXIT (SETQ G166943 + (CONS + (|simplifyMapConstructorRefs| + |a|) + G166943))))))))) + ((|member| |op| '(REPEAT)) + (CONS |op| + (CONS (CAR |args|) + (PROG (G166958) + (SPADLET G166958 NIL) + (RETURN + (DO ((G166963 (CDR |args|) + (CDR G166963)) + (|a| NIL)) + ((OR (ATOM G166963) + (PROGN + (SETQ |a| (CAR G166963)) + NIL)) + (NREVERSE0 G166958)) + (SEQ + (EXIT + (SETQ G166958 + (CONS + (|simplifyMapConstructorRefs| + |a|) + G166958)))))))))) + ((|member| |op| '(|:| |::| @)) + (COND + ((AND (PAIRP |args|) + (PROGN + (SPADLET |obj| (QCAR |args|)) + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |dom| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |dom'| (|prefix2String| |dom|)) + (SPADLET |dom''| + (COND + ((ATOM |dom'|) |dom'|) + ((NULL (CDR |dom'|)) (CAR |dom'|)) + ('T (APPLY 'CONCAT |dom'|)))) + (CONS |op| (CONS |obj| (CONS |dom''| NIL)))) + ('T |form|))) + ('T |form|)))))))) ;predTran x == ; x is ["IF",a,b,c] => @@ -1440,40 +1553,36 @@ ; x (DEFUN |predTran| (|x|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c|) - (RETURN - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE IF)) - (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|) - (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|)) (QUOTE T))))))))) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c|) + (RETURN (COND - ((BOOT-EQUAL |c| (QUOTE |false|)) - (MKPF - (CONS (|predTran| |a|) (CONS (|predTran| |b|) NIL)) - (QUOTE |and|))) - ((BOOT-EQUAL |b| (QUOTE |true|)) - (MKPF - (CONS (|predTran| |a|) (CONS (|predTran| |c|) NIL)) - (QUOTE |or|))) - ((AND (BOOT-EQUAL |b| (QUOTE |false|)) (BOOT-EQUAL |c| (QUOTE |true|))) - (CONS (QUOTE |not|) (CONS (|predTran| |a|) NIL))) - ((QUOTE T) |x|))) - ((QUOTE T) |x|))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) + (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|) + (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 + ((BOOT-EQUAL |c| '|false|) + (MKPF (CONS (|predTran| |a|) (CONS (|predTran| |b|) NIL)) + '|and|)) + ((BOOT-EQUAL |b| '|true|) + (MKPF (CONS (|predTran| |a|) (CONS (|predTran| |c|) NIL)) + '|or|)) + ((AND (BOOT-EQUAL |b| '|false|) (BOOT-EQUAL |c| '|true|)) + (CONS '|not| (CONS (|predTran| |a|) NIL))) + ('T |x|))) + ('T |x|))))) ;getEqualSublis pred == fn(pred,nil) where fn(x,sl) == ; (x:= SUBLIS(sl,x)) is [op,:l] and op in '(_and _or) => @@ -1487,60 +1596,60 @@ ; sl (DEFUN |getEqualSublis,fn| (|x| |sl|) - (PROG (|op| |l| |ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (SEQ - (IF (AND - (PROGN - (SPADLET |ISTMP#1| (SPADLET |x| (SUBLIS |sl| |x|))) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |op| (QCAR |ISTMP#1|)) - (SPADLET |l| (QCDR |ISTMP#1|)) - (QUOTE T)))) - (|member| |op| (QUOTE (|and| |or|)))) - (EXIT - (SEQ - (DO ((#0=#:G167072 |l| (CDR #0#)) (|y| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |y| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (SPADLET |sl| (|getEqualSublis,fn| |y| |sl|))))) - (EXIT |sl|)))) - (IF (AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |is|)) - (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|)) (QUOTE T))))))) - (EXIT (CONS (CONS |a| |b|) |sl|))) - (IF (AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE =)) - (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|)) (QUOTE T))))))) - (EXIT - (SEQ - (IF (AND (IDENTP |a|) (NULL (CONTAINED |a| |b|))) - (EXIT (CONS (CONS |a| |b|) |sl|))) - (IF (AND (IDENTP |b|) (NULL (CONTAINED |b| |a|))) - (EXIT (CONS (CONS |b| |a|) |sl|))) - (EXIT |sl|)))) - (EXIT |sl|))))) + (PROG (|op| |l| |ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (SEQ (IF (AND (PROGN + (SPADLET |ISTMP#1| + (SPADLET |x| (SUBLIS |sl| |x|))) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + 'T))) + (|member| |op| '(|and| |or|))) + (EXIT (SEQ (DO ((G167072 |l| (CDR G167072)) + (|y| NIL)) + ((OR (ATOM G167072) + (PROGN + (SETQ |y| (CAR G167072)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |sl| + (|getEqualSublis,fn| |y| |sl|))))) + (EXIT |sl|)))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|is|) + (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)))))) + (EXIT (CONS (CONS |a| |b|) |sl|))) + (IF (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)))))) + (EXIT (SEQ (IF (AND (IDENTP |a|) + (NULL (CONTAINED |a| |b|))) + (EXIT (CONS (CONS |a| |b|) |sl|))) + (IF (AND (IDENTP |b|) + (NULL (CONTAINED |b| |a|))) + (EXIT (CONS (CONS |b| |a|) |sl|))) + (EXIT |sl|)))) + (EXIT |sl|))))) (DEFUN |getEqualSublis| (|pred|) (|getEqualSublis,fn| |pred| NIL)) @@ -1590,118 +1699,147 @@ ; x (DEFUN |analyzeMap,f| (|x|) - (SEQ - (IF (|isEqualOrSubDomain| |x| |$Integer|) (EXIT |$Integer|)) - (EXIT |x|))) + (DECLARE (SPECIAL |$Integer|)) + (SEQ (IF (|isEqualOrSubDomain| |x| |$Integer|) (EXIT |$Integer|)) + (EXIT |x|))) (DEFUN |analyzeMap| (|op| |argTypes| |mapDef| |tar|) - (PROG (|$compilingMap| |$definingMap| |$minivector| |$mapThrowCount| - |$mapReturnTypes| |$repeatLabel| |$breakCount| |$mapTarget| - |$interpOnly| |$mapName| |mapAndArgTypes| |ISTMP#2| |target| - |map| |x| |opName| |fun| |ISTMP#1| |sig|) - (DECLARE (SPECIAL |$compilingMap| |$definingMap| |$minivector| - |$mapThrowCount| |$mapReturnTypes| |$repeatLabel| - |$breakCount| |$mapTarget| |$interpOnly| |$mapName|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$compilingMap| (QUOTE T)) - (SPADLET |$definingMap| (QUOTE T)) - (SPADLET |$minivector| NIL) - (SPADLET |$mapThrowCount| 0) - (SPADLET |$mapReturnTypes| NIL) - (SPADLET |$repeatLabel| NIL) - (SPADLET |$breakCount| 0) - (SPADLET |$mapTarget| |tar|) - (SPADLET |$interpOnly| NIL) - (SPADLET |$mapName| (ELT |op| 0)) - (COND - ((|get| |$mapName| (QUOTE |recursive|) |$e|) - (SPADLET |argTypes| - (PROG (#0=#:G167131) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167136 |argTypes| (CDR #1#)) (|t| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |t| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (|analyzeMap,f| |t|) #0#)))))))))) - (SPADLET |mapAndArgTypes| (CONS |$mapName| |argTypes|)) - (COND - ((|member| |mapAndArgTypes| |$analyzingMapList|) - (COND - ((PROGN - (SPADLET |ISTMP#1| (|getMode| |op|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN (SPADLET |target| (QCAR |ISTMP#2|)) (QUOTE T)))))) - |target|) - ((QUOTE T) - (|throwKeyedMsg| (QUOTE S2IM0009) - (CONS |$mapName| - (CONS - (PROG (#2=#:G167142) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G167148 |$analyzingMapList| (CDR #3#)) - (#4=#:G167116 NIL)) - ((OR (ATOM #3#) - (PROGN (SETQ #4# (CAR #3#)) NIL) - (PROGN (PROGN (SPADLET |map| (CAR #4#)) #4#) NIL)) - #2#) - (SEQ - (EXIT - (SETQ #2# - (APPEND #2# (CONS (MAKESTRING " ") (CONS |map| NIL))))))))) - NIL)))))) - ((QUOTE T) - (PUSH |mapAndArgTypes| |$analyzingMapList|) - (SPADLET |mapDef| - (|mapDefsWithCorrectArgCount| (|#| |argTypes|) |mapDef|)) - (COND - ((NULL |mapDef|) (POP |$analyzingMapList|) NIL) - ((QUOTE T) - (UNWIND-PROTECT - (SPADLET |x| - (CATCH - (QUOTE |mapCompiler|) - (|analyzeMap0| |op| |argTypes| |mapDef|))) - (POP |$analyzingMapList|)) - (COND - ((BOOT-EQUAL |x| (QUOTE |tryInterpOnly|)) - (SPADLET |opName| (|getUnname| |op|)) - (SPADLET |fun| (|mkInterpFun| |op| |opName| |argTypes|)) - (COND - ((NULL - (PROGN - (SPADLET |ISTMP#1| (|getMode| |op|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |sig| - (CONS NIL - (PROG (#5=#:G167159) - (SPADLET #5# NIL) - (RETURN - (DO ((#6=#:G167164 |argTypes| (CDR #6#)) (|type| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |type| (CAR #6#)) NIL)) - (NREVERSE0 #5#)) - (SEQ (EXIT (SETQ #5# (CONS NIL #5#))))))))))) - (SPADLET |$e| - (|putHist| |opName| - (QUOTE |localModemap|) - (CONS - (CONS - (CONS (QUOTE |interpOnly|) |sig|) - (CONS |fun| (CONS NIL NIL))) - NIL) - |$e|))) - ((QUOTE T) |x|))))))))))) + (PROG (|$compilingMap| |$definingMap| |$minivector| |$mapThrowCount| + |$mapReturnTypes| |$repeatLabel| |$breakCount| |$mapTarget| + |$interpOnly| |$mapName| |mapAndArgTypes| |ISTMP#2| + |target| |map| |x| |opName| |fun| |ISTMP#1| |sig|) + (DECLARE (SPECIAL |$compilingMap| |$definingMap| |$minivector| |$e| + |$mapThrowCount| |$mapReturnTypes| |$repeatLabel| + |$breakCount| |$mapTarget| |$interpOnly| + |$mapName| |$analyzingMapList|)) + (RETURN + (SEQ (PROGN + (SPADLET |$compilingMap| 'T) + (SPADLET |$definingMap| 'T) + (SPADLET |$minivector| NIL) + (SPADLET |$mapThrowCount| 0) + (SPADLET |$mapReturnTypes| NIL) + (SPADLET |$repeatLabel| NIL) + (SPADLET |$breakCount| 0) + (SPADLET |$mapTarget| |tar|) + (SPADLET |$interpOnly| NIL) + (SPADLET |$mapName| (ELT |op| 0)) + (COND + ((|get| |$mapName| '|recursive| |$e|) + (SPADLET |argTypes| + (PROG (G167131) + (SPADLET G167131 NIL) + (RETURN + (DO ((G167136 |argTypes| + (CDR G167136)) + (|t| NIL)) + ((OR (ATOM G167136) + (PROGN + (SETQ |t| (CAR G167136)) + NIL)) + (NREVERSE0 G167131)) + (SEQ (EXIT + (SETQ G167131 + (CONS (|analyzeMap,f| |t|) + G167131)))))))))) + (SPADLET |mapAndArgTypes| (CONS |$mapName| |argTypes|)) + (COND + ((|member| |mapAndArgTypes| |$analyzingMapList|) + (COND + ((PROGN + (SPADLET |ISTMP#1| (|getMode| |op|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |target| (QCAR |ISTMP#2|)) + 'T))))) + |target|) + ('T + (|throwKeyedMsg| 'S2IM0009 + (CONS |$mapName| + (CONS (PROG (G167142) + (SPADLET G167142 NIL) + (RETURN + (DO + ((G167148 |$analyzingMapList| + (CDR G167148)) + (G167116 NIL)) + ((OR (ATOM G167148) + (PROGN + (SETQ G167116 + (CAR G167148)) + NIL) + (PROGN + (PROGN + (SPADLET |map| + (CAR G167116)) + G167116) + NIL)) + G167142) + (SEQ + (EXIT + (SETQ G167142 + (APPEND G167142 + (CONS (MAKESTRING " ") + (CONS |map| NIL))))))))) + NIL)))))) + ('T (PUSH |mapAndArgTypes| |$analyzingMapList|) + (SPADLET |mapDef| + (|mapDefsWithCorrectArgCount| (|#| |argTypes|) + |mapDef|)) + (COND + ((NULL |mapDef|) (POP |$analyzingMapList|) NIL) + ('T + (UNWIND-PROTECT + (SPADLET |x| + (CATCH '|mapCompiler| + (|analyzeMap0| |op| |argTypes| + |mapDef|))) + (POP |$analyzingMapList|)) + (COND + ((BOOT-EQUAL |x| '|tryInterpOnly|) + (SPADLET |opName| (|getUnname| |op|)) + (SPADLET |fun| + (|mkInterpFun| |op| |opName| |argTypes|)) + (COND + ((NULL (PROGN + (SPADLET |ISTMP#1| (|getMode| |op|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |sig| + (QCDR |ISTMP#1|)) + 'T)))) + (SPADLET |sig| + (CONS NIL + (PROG (G167159) + (SPADLET G167159 NIL) + (RETURN + (DO + ((G167164 |argTypes| + (CDR G167164)) + (|type| NIL)) + ((OR (ATOM G167164) + (PROGN + (SETQ |type| + (CAR G167164)) + NIL)) + (NREVERSE0 G167159)) + (SEQ + (EXIT + (SETQ G167159 + (CONS NIL G167159))))))))))) + (SPADLET |$e| + (|putHist| |opName| '|localModemap| + (CONS + (CONS (CONS '|interpOnly| |sig|) + (CONS |fun| (CONS NIL NIL))) + NIL) + |$e|))) + ('T |x|))))))))))) ;analyzeMap0(op,argTypes,mapDef) == ; -- Type analyze and compile a map. Returns the target type of the map. @@ -1714,25 +1852,24 @@ ; analyzeUndeclaredMap(getUnname op,argTypes,mapDef,$mapList) (DEFUN |analyzeMap0| (|op| |argTypes| |mapDef|) - (PROG (|$MapArgumentTypeList| |m| |ISTMP#1| |sig|) - (DECLARE (SPECIAL |$MapArgumentTypeList|)) - (RETURN - (PROGN - (SPADLET |$MapArgumentTypeList| |argTypes|) - (COND - ((NEQUAL (|numMapArgs| |mapDef|) (|#| |argTypes|)) NIL) - ((OR - (PROGN - (SPADLET |ISTMP#1| (SPADLET |m| (|getMode| |op|))) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) (QUOTE T)))) - (AND |m| (SPADLET |sig| (CONS |m| NIL)))) - (|analyzeDeclaredMap| |op| |argTypes| |sig| |mapDef| |$mapList|)) - ((QUOTE T) - (|analyzeUndeclaredMap| - (|getUnname| |op|) |argTypes| |mapDef| |$mapList|))))))) + (PROG (|$MapArgumentTypeList| |m| |ISTMP#1| |sig|) + (DECLARE (SPECIAL |$MapArgumentTypeList| |$mapList|)) + (RETURN + (PROGN + (SPADLET |$MapArgumentTypeList| |argTypes|) + (COND + ((NEQUAL (|numMapArgs| |mapDef|) (|#| |argTypes|)) NIL) + ((OR (PROGN + (SPADLET |ISTMP#1| (SPADLET |m| (|getMode| |op|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) 'T))) + (AND |m| (SPADLET |sig| (CONS |m| NIL)))) + (|analyzeDeclaredMap| |op| |argTypes| |sig| |mapDef| + |$mapList|)) + ('T + (|analyzeUndeclaredMap| (|getUnname| |op|) |argTypes| + |mapDef| |$mapList|))))))) ;compFailure msg == ; -- Called when compilation fails in such a way that interpret-code @@ -1745,19 +1882,19 @@ ; THROW('mapCompiler,'tryInterpOnly) (DEFUN |compFailure| (|msg|) - (COND - ((NULL |$useCoerceOrCroak|) - (THROW (QUOTE |coerceOrCroaker|) (QUOTE |croaked|))) - ((QUOTE T) - (COND - (|$reportInterpOnly| - (|sayMSG| |msg|) - (|sayMSG| (MAKESTRING " We will attempt to interpret the code.")))) - (COND - ((NULL |$compilingMap|) - (THROW (QUOTE |loopCompiler|) (QUOTE |tryInterpOnly|))) - ((QUOTE T) - (THROW (QUOTE |mapCompiler|) (QUOTE |tryInterpOnly|))))))) + (DECLARE (SPECIAL |$compilingMap| |$reportInterpOnly| + |$useCoerceOrCroak|)) + (COND + ((NULL |$useCoerceOrCroak|) (THROW '|coerceOrCroaker| '|croaked|)) + ('T + (COND + (|$reportInterpOnly| (|sayMSG| |msg|) + (|sayMSG| + (MAKESTRING " We will attempt to interpret the code.")))) + (COND + ((NULL |$compilingMap|) + (THROW '|loopCompiler| '|tryInterpOnly|)) + ('T (THROW '|mapCompiler| '|tryInterpOnly|)))))) ;mkInterpFun(op,opName,argTypes) == ; -- creates a function form to put in fun slot of interp-only @@ -1775,69 +1912,84 @@ ; funName (DEFUN |mkInterpFun| (|op| |opName| |argTypes|) - (PROG (|ISTMP#1| |sig| |parms| |arglCode| |funName| |body|) - (RETURN - (SEQ - (COND - ((NULL - (PROGN - (SPADLET |ISTMP#1| (|getMode| |op|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) (QUOTE T))))) - NIL) - ((QUOTE T) - (SPADLET |parms| - (PROG (#0=#:G167251) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167257 |argTypes| (CDR #1#)) - (|type| NIL) - (#2=#:G167258 |$FormalMapVariableList| (CDR #2#)) - (|var| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |type| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |var| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS |var| #0#)))))))) - (SPADLET |arglCode| - (CONS - (QUOTE LIST) - (PROG (#3=#:G167272) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G167278 |argTypes| (CDR #4#)) - (|type| NIL) - (#5=#:G167279 |parms| (CDR #5#)) - (|argName| NIL)) - ((OR (ATOM #4#) - (PROGN (SETQ |type| (CAR #4#)) NIL) - (ATOM #5#) - (PROGN (SETQ |argName| (CAR #5#)) NIL)) - (NREVERSE0 #3#)) - (SEQ - (EXIT - (SETQ #3# - (CONS - (CONS - (QUOTE |putValueValue|) - (CONS - (CONS (QUOTE |mkAtreeNode|) (CONS (MKQ |argName|) NIL)) - (CONS - (|objNewCode| - (CONS (QUOTE |wrap|) (CONS |argName| NIL)) |type|) - NIL))) - #3#))))))))) - (SPADLET |funName| (GENSYM)) - (SPADLET |body| - (CONS - (QUOTE |rewriteMap1|) - (CONS (MKQ |opName|) (CONS |arglCode| (CONS (MKQ |sig|) NIL))))) - (|putMapCode| |opName| |body| |sig| |funName| |parms| NIL) - (|genMapCode| |opName| |body| |sig| |funName| |parms| NIL) - |funName|)))))) + (PROG (|ISTMP#1| |sig| |parms| |arglCode| |funName| |body|) + (DECLARE (SPECIAL |$FormalMapVariableList|)) + (RETURN + (SEQ (COND + ((NULL (PROGN + (SPADLET |ISTMP#1| (|getMode| |op|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) 'T)))) + NIL) + ('T + (SPADLET |parms| + (PROG (G167251) + (SPADLET G167251 NIL) + (RETURN + (DO ((G167257 |argTypes| (CDR G167257)) + (|type| NIL) + (G167258 |$FormalMapVariableList| + (CDR G167258)) + (|var| NIL)) + ((OR (ATOM G167257) + (PROGN + (SETQ |type| (CAR G167257)) + NIL) + (ATOM G167258) + (PROGN + (SETQ |var| (CAR G167258)) + NIL)) + (NREVERSE0 G167251)) + (SEQ (EXIT (SETQ G167251 + (CONS |var| G167251)))))))) + (SPADLET |arglCode| + (CONS 'LIST + (PROG (G167272) + (SPADLET G167272 NIL) + (RETURN + (DO ((G167278 |argTypes| + (CDR G167278)) + (|type| NIL) + (G167279 |parms| + (CDR G167279)) + (|argName| NIL)) + ((OR (ATOM G167278) + (PROGN + (SETQ |type| (CAR G167278)) + NIL) + (ATOM G167279) + (PROGN + (SETQ |argName| + (CAR G167279)) + NIL)) + (NREVERSE0 G167272)) + (SEQ + (EXIT + (SETQ G167272 + (CONS + (CONS '|putValueValue| + (CONS + (CONS '|mkAtreeNode| + (CONS (MKQ |argName|) NIL)) + (CONS + (|objNewCode| + (CONS '|wrap| + (CONS |argName| NIL)) + |type|) + NIL))) + G167272))))))))) + (SPADLET |funName| (GENSYM)) + (SPADLET |body| + (CONS '|rewriteMap1| + (CONS (MKQ |opName|) + (CONS |arglCode| + (CONS (MKQ |sig|) NIL))))) + (|putMapCode| |opName| |body| |sig| |funName| |parms| + NIL) + (|genMapCode| |opName| |body| |sig| |funName| |parms| + NIL) + |funName|)))))) ;rewriteMap(op,opName,argl) == ; -- interpret-code handler for maps. Recursively calls the interpreter @@ -1856,62 +2008,75 @@ ; rewriteMap0(op,opName,argl) (DEFUN |rewriteMap| (|op| |opName| |argl|) - (PROG (|ISTMP#1| |sig| |arglCode|) - (RETURN - (SEQ - (COND - ((NULL |$genValue|) - (COND - ((NULL - (PROGN - (SPADLET |ISTMP#1| (|get| |opName| (QUOTE |mode|) |$e|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) (QUOTE T))))) - (|compFailure| (CONS " Cannot compile map:" (|bright| |opName|)))) - ((QUOTE T) - (SPADLET |arglCode| - (CONS - (QUOTE LIST) - (PROG (#0=#:G167311) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167317 |argl| (CDR #1#)) - (|arg| NIL) - (#2=#:G167318 |$FormalMapVariableList| (CDR #2#)) - (|argName| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |arg| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |argName| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (CONS - (QUOTE |putValueValue|) - (CONS - (CONS (QUOTE |mkAtreeNode|) (CONS (MKQ |argName|) NIL)) - (CONS - (|objNewCode| - (CONS - (QUOTE |wrap|) - (CONS - (|wrapped2Quote| (|objVal| (|getValue| |arg|))) - NIL)) - (|getMode| |arg|)) - NIL))) - #0#))))))))) - (|putValue| |op| - (|objNew| - (CONS - (QUOTE |rewriteMap1|) - (CONS (MKQ |opName|) (CONS |arglCode| (CONS (MKQ |sig|) NIL)))) - (CAR |sig|))) - (|putModeSet| |op| (CONS (CAR |sig|) NIL))))) - ((QUOTE T) (|rewriteMap0| |op| |opName| |argl|))))))) + (PROG (|ISTMP#1| |sig| |arglCode|) + (DECLARE (SPECIAL |$FormalMapVariableList| |$e| |$genValue|)) + (RETURN + (SEQ (COND + ((NULL |$genValue|) + (COND + ((NULL (PROGN + (SPADLET |ISTMP#1| + (|get| |opName| '|mode| |$e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |sig| (QCDR |ISTMP#1|)) + 'T)))) + (|compFailure| + (CONS " Cannot compile map:" + (|bright| |opName|)))) + ('T + (SPADLET |arglCode| + (CONS 'LIST + (PROG (G167311) + (SPADLET G167311 NIL) + (RETURN + (DO + ((G167317 |argl| + (CDR G167317)) + (|arg| NIL) + (G167318 + |$FormalMapVariableList| + (CDR G167318)) + (|argName| NIL)) + ((OR (ATOM G167317) + (PROGN + (SETQ |arg| (CAR G167317)) + NIL) + (ATOM G167318) + (PROGN + (SETQ |argName| + (CAR G167318)) + NIL)) + (NREVERSE0 G167311)) + (SEQ + (EXIT + (SETQ G167311 + (CONS + (CONS '|putValueValue| + (CONS + (CONS '|mkAtreeNode| + (CONS (MKQ |argName|) NIL)) + (CONS + (|objNewCode| + (CONS '|wrap| + (CONS + (|wrapped2Quote| + (|objVal| + (|getValue| |arg|))) + NIL)) + (|getMode| |arg|)) + NIL))) + G167311))))))))) + (|putValue| |op| + (|objNew| + (CONS '|rewriteMap1| + (CONS (MKQ |opName|) + (CONS |arglCode| + (CONS (MKQ |sig|) NIL)))) + (CAR |sig|))) + (|putModeSet| |op| (CONS (CAR |sig|) NIL))))) + ('T (|rewriteMap0| |op| |opName| |argl|))))))) ;putBodyInEnv(opName, numArgs) == ; val := get(opName, 'value, $e) @@ -1921,30 +2086,31 @@ ; 'failed (DEFUN |putBodyInEnv| (|opName| |numArgs|) - (PROG (|val| |ISTMP#1| |bod|) - (RETURN - (PROGN - (SPADLET |val| (|get| |opName| (QUOTE |value|) |$e|)) - (COND - ((AND (PAIRP |val|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |val|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) - (PROGN (SPADLET |bod| (QCDR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |$e| - (|putHist| |opName| - (QUOTE |mapBody|) - (|combineMapParts| (|mapDefsWithCorrectArgCount| |numArgs| |bod|)) - |$e|))) - ((QUOTE T) (QUOTE |failed|))))))) + (PROG (|val| |ISTMP#1| |bod|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (PROGN + (SPADLET |val| (|get| |opName| '|value| |$e|)) + (COND + ((AND (PAIRP |val|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |val|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) 'MAP) + (PROGN (SPADLET |bod| (QCDR |ISTMP#1|)) 'T)))) + (SPADLET |$e| + (|putHist| |opName| '|mapBody| + (|combineMapParts| + (|mapDefsWithCorrectArgCount| |numArgs| + |bod|)) + |$e|))) + ('T '|failed|)))))) ;removeBodyFromEnv(opName) == ; $e := putHist(opName, 'mapBody, nil, $e) (DEFUN |removeBodyFromEnv| (|opName|) - (SPADLET |$e| (|putHist| |opName| (QUOTE |mapBody|) NIL |$e|))) + (DECLARE (SPECIAL |$e|)) + (SPADLET |$e| (|putHist| |opName| '|mapBody| NIL |$e|))) ;rewriteMap0(op,opName,argl) == ; -- $genValue case of map rewriting @@ -1977,67 +2143,71 @@ ; ms := putModeSet(op,[objMode val]) (DEFUN |rewriteMap0| (|op| |opName| |argl|) - (PROG (|$env| |s| |ISTMP#1| |ISTMP#2| |tar| |t| |argTypes| |m| |val| |ms|) - (DECLARE (SPECIAL |$env|)) - (RETURN - (SEQ - (PROGN - (|putBodyInEnv| |opName| (|#| |argl|)) - (COND - ((SPADLET |s| (|get| |opName| (QUOTE |mode|) |$e|)) - (SPADLET |tar| (CADR |s|)) - (SPADLET |argTypes| (CDDR |s|))) - ((QUOTE T) - (SPADLET |tar| NIL) (SPADLET |argTypes| NIL))) - (SPADLET |ISTMP#1| (|get| |opName| (QUOTE |mode|) |$e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |tar| (QCAR |ISTMP#2|)) - (SPADLET |argTypes| (QCDR |ISTMP#2|)) - (QUOTE T))))) - (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) - (DO ((#0=#:G167379 |argl| (CDR #0#)) - (|arg| NIL) - (#1=#:G167380 |$FormalMapVariableList| (CDR #1#)) - (|var| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |arg| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |var| (CAR #1#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (COND - (|argTypes| - (SPADLET |t| (CAR |argTypes|)) - (SPADLET |argTypes| (CDR |argTypes|)) - (SPADLET |val| - (COND - ((AND (PAIRP |t|) (EQ (QCAR |t|) (QUOTE |Mapping|))) - (|getValue| |arg|)) - ((QUOTE T) (|coerceInteractive| (|getValue| |arg|) |t|))))) - ((QUOTE T) (SPADLET |val| (|getValue| |arg|)))) - (SPADLET |$env| (|put| |var| (QUOTE |value|) |val| |$env|)) - (COND - ((VECP |arg|) - (SPADLET |$env| - (|put| |var| (QUOTE |name|) (|getUnname| |arg|) |$env|)))) - (COND - ((SPADLET |m| (|getMode| |arg|)) - (SPADLET |$env| (|put| |var| (QUOTE |mode|) |m| |$env|)))))))) - (COND - ((NULL (SPADLET |val| (|interpMap| |opName| |tar|))) - (|throwKeyedMsg| (QUOTE S2IM0010) (CONS |opName| NIL))) - ((QUOTE T) - (|putValue| |op| |val|) - (|removeBodyFromEnv| |opName|) - (SPADLET |ms| (|putModeSet| |op| (CONS (|objMode| |val|) NIL)))))))))) + (PROG (|$env| |s| |ISTMP#1| |ISTMP#2| |tar| |t| |argTypes| |m| |val| + |ms|) + (DECLARE (SPECIAL |$env| |$FormalMapVariableList| |$e|)) + (RETURN + (SEQ (PROGN + (|putBodyInEnv| |opName| (|#| |argl|)) + (COND + ((SPADLET |s| (|get| |opName| '|mode| |$e|)) + (SPADLET |tar| (CADR |s|)) + (SPADLET |argTypes| (CDDR |s|))) + ('T (SPADLET |tar| NIL) (SPADLET |argTypes| NIL))) + (SPADLET |ISTMP#1| (|get| |opName| '|mode| |$e|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |tar| (QCAR |ISTMP#2|)) + (SPADLET |argTypes| (QCDR |ISTMP#2|)) + 'T)))) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (DO ((G167379 |argl| (CDR G167379)) (|arg| NIL) + (G167380 |$FormalMapVariableList| (CDR G167380)) + (|var| NIL)) + ((OR (ATOM G167379) + (PROGN (SETQ |arg| (CAR G167379)) NIL) + (ATOM G167380) + (PROGN (SETQ |var| (CAR G167380)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|argTypes| + (SPADLET |t| (CAR |argTypes|)) + (SPADLET |argTypes| (CDR |argTypes|)) + (SPADLET |val| + (COND + ((AND (PAIRP |t|) + (EQ (QCAR |t|) + '|Mapping|)) + (|getValue| |arg|)) + ('T + (|coerceInteractive| + (|getValue| |arg|) |t|))))) + ('T (SPADLET |val| (|getValue| |arg|)))) + (SPADLET |$env| + (|put| |var| '|value| |val| + |$env|)) + (COND + ((VECP |arg|) + (SPADLET |$env| + (|put| |var| '|name| + (|getUnname| |arg|) |$env|)))) + (COND + ((SPADLET |m| (|getMode| |arg|)) + (SPADLET |$env| + (|put| |var| '|mode| |m| + |$env|)))))))) + (COND + ((NULL (SPADLET |val| (|interpMap| |opName| |tar|))) + (|throwKeyedMsg| 'S2IM0010 (CONS |opName| NIL))) + ('T (|putValue| |op| |val|) + (|removeBodyFromEnv| |opName|) + (SPADLET |ms| + (|putModeSet| |op| + (CONS (|objMode| |val|) NIL)))))))))) ;rewriteMap1(opName,argl,sig) == ; -- compiled case of map rewriting @@ -2071,61 +2241,71 @@ ; objValUnwrap(val) (DEFUN |rewriteMap1| (|opName| |argl| |sig|) - (PROG (|$env| |tar| |v| |evArgl| |t| |argTypes| |m| |val|) - (DECLARE (SPECIAL |$env|)) - (RETURN - (SEQ - (PROGN - (|putBodyInEnv| |opName| (|#| |argl|)) - (COND - (|sig| (SPADLET |tar| (CAR |sig|)) (SPADLET |argTypes| (CDR |sig|))) - ((QUOTE T) (SPADLET |tar| NIL) (SPADLET |argTypes| NIL))) - (SPADLET |evArgl| NIL) - (DO ((#0=#:G167426 (REVERSE |argl|) (CDR #0#)) (|arg| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |arg| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |v| (|getValue| |arg|)) - (SPADLET |evArgl| - (CONS (|objNew| (|objVal| |v|) (|objMode| |v|)) |evArgl|)))))) - (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) - (DO ((#1=#:G167441 |argl| (CDR #1#)) - (|arg| NIL) - (#2=#:G167442 |evArgl| (CDR #2#)) - (|evArg| NIL) - (#3=#:G167443 |$FormalMapVariableList| (CDR #3#)) - (|var| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |arg| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |evArg| (CAR #2#)) NIL) - (ATOM #3#) - (PROGN (SETQ |var| (CAR #3#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (COND - (|argTypes| - (SPADLET |t| (CAR |argTypes|)) - (SPADLET |argTypes| (CDR |argTypes|)) - (SPADLET |val| + (PROG (|$env| |tar| |v| |evArgl| |t| |argTypes| |m| |val|) + (DECLARE (SPECIAL |$env| |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (|putBodyInEnv| |opName| (|#| |argl|)) (COND - ((AND (PAIRP |t|) (EQ (QCAR |t|) (QUOTE |Mapping|))) |evArg|) - ((QUOTE T) (|coerceInteractive| |evArg| |t|))))) - ((QUOTE T) (SPADLET |val| |evArg|))) - (SPADLET |$env| (|put| |var| (QUOTE |value|) |val| |$env|)) - (COND - ((VECP |arg|) - (SPADLET |$env| - (|put| |var| (QUOTE |name|) (|getUnname| |arg|) |$env|)))) - (COND - ((SPADLET |m| (|getMode| |arg|)) - (SPADLET |$env| (|put| |var| (QUOTE |mode|) |m| |$env|)))))))) - (SPADLET |val| (|interpMap| |opName| |tar|)) - (|removeBodyFromEnv| |opName|) - (|objValUnwrap| |val|)))))) + (|sig| (SPADLET |tar| (CAR |sig|)) + (SPADLET |argTypes| (CDR |sig|))) + ('T (SPADLET |tar| NIL) (SPADLET |argTypes| NIL))) + (SPADLET |evArgl| NIL) + (DO ((G167426 (REVERSE |argl|) (CDR G167426)) + (|arg| NIL)) + ((OR (ATOM G167426) + (PROGN (SETQ |arg| (CAR G167426)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |v| (|getValue| |arg|)) + (SPADLET |evArgl| + (CONS + (|objNew| (|objVal| |v|) + (|objMode| |v|)) + |evArgl|)))))) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (DO ((G167441 |argl| (CDR G167441)) (|arg| NIL) + (G167442 |evArgl| (CDR G167442)) (|evArg| NIL) + (G167443 |$FormalMapVariableList| (CDR G167443)) + (|var| NIL)) + ((OR (ATOM G167441) + (PROGN (SETQ |arg| (CAR G167441)) NIL) + (ATOM G167442) + (PROGN (SETQ |evArg| (CAR G167442)) NIL) + (ATOM G167443) + (PROGN (SETQ |var| (CAR G167443)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|argTypes| + (SPADLET |t| (CAR |argTypes|)) + (SPADLET |argTypes| (CDR |argTypes|)) + (SPADLET |val| + (COND + ((AND (PAIRP |t|) + (EQ (QCAR |t|) + '|Mapping|)) + |evArg|) + ('T + (|coerceInteractive| + |evArg| |t|))))) + ('T (SPADLET |val| |evArg|))) + (SPADLET |$env| + (|put| |var| '|value| |val| + |$env|)) + (COND + ((VECP |arg|) + (SPADLET |$env| + (|put| |var| '|name| + (|getUnname| |arg|) |$env|)))) + (COND + ((SPADLET |m| (|getMode| |arg|)) + (SPADLET |$env| + (|put| |var| '|mode| |m| + |$env|)))))))) + (SPADLET |val| (|interpMap| |opName| |tar|)) + (|removeBodyFromEnv| |opName|) + (|objValUnwrap| |val|)))))) ;interpMap(opName,tar) == ; -- call the interpreter recursively on map body @@ -2147,31 +2327,38 @@ ; c -- better be a triple (DEFUN |interpMap| (|opName| |tar|) - (PROG (|$genValue| |$interpMapTag| |$interpOnly| |$localVars| |$mapName| - |$mapTarget| |body| |savedTimerStack| |catchName| |c|) - (DECLARE (SPECIAL |$genValue| |$interpMapTag| |$interpOnly| |$localVars| - |$mapName| |$mapTarget|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$genValue| (QUOTE T)) - (SPADLET |$interpMapTag| NIL) - (SPADLET |$interpOnly| (QUOTE T)) - (SPADLET |$localVars| NIL) - (DO ((#0=#:G167481 (|get| |opName| (QUOTE |localVars|) |$e|) (CDR #0#)) - (|lvar| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |lvar| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |opName| |lvar|)))) - (SPADLET |$mapName| |opName|) - (SPADLET |$mapTarget| |tar|) - (SPADLET |body| (|get| |opName| (QUOTE |mapBody|) |$e|)) - (SPADLET |savedTimerStack| (COPY |$timedNameStack|)) - (SPADLET |catchName| (|mapCatchName| |$mapName|)) - (SPADLET |c| (CATCH |catchName| (|interpret1| |body| |tar| NIL))) - (DO () - ((NULL (NEQUAL |savedTimerStack| |$timedNameStack|)) NIL) - (SEQ (EXIT (|stopTimingProcess| (|peekTimedName|))))) - |c|))))) + (PROG (|$genValue| |$interpMapTag| |$interpOnly| |$localVars| + |$mapName| |$mapTarget| |body| |savedTimerStack| + |catchName| |c|) + (DECLARE (SPECIAL |$genValue| |$interpMapTag| |$interpOnly| + |$localVars| |$mapName| |$mapTarget| + |$timedNameStack| |$e|)) + (RETURN + (SEQ (PROGN + (SPADLET |$genValue| 'T) + (SPADLET |$interpMapTag| NIL) + (SPADLET |$interpOnly| 'T) + (SPADLET |$localVars| NIL) + (DO ((G167481 (|get| |opName| '|localVars| |$e|) + (CDR G167481)) + (|lvar| NIL)) + ((OR (ATOM G167481) + (PROGN (SETQ |lvar| (CAR G167481)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |opName| |lvar|)))) + (SPADLET |$mapName| |opName|) + (SPADLET |$mapTarget| |tar|) + (SPADLET |body| (|get| |opName| '|mapBody| |$e|)) + (SPADLET |savedTimerStack| (COPY |$timedNameStack|)) + (SPADLET |catchName| (|mapCatchName| |$mapName|)) + (SPADLET |c| + (CATCH |catchName| + (|interpret1| |body| |tar| NIL))) + (DO () + ((NULL (NEQUAL |savedTimerStack| |$timedNameStack|)) + NIL) + (SEQ (EXIT (|stopTimingProcess| (|peekTimedName|))))) + |c|))))) ;analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) == ; -- analyzes and compiles maps with declared signatures. argTypes @@ -2190,40 +2377,49 @@ ; CAR sig (DEFUN |analyzeDeclaredMap| (|op| |argTypes| |sig| |mapDef| |$mapList|) - (DECLARE (SPECIAL |$mapList|)) - (PROG (|opName| |mmS| |mmSig| |mm|) - (RETURN - (SEQ - (PROGN - (SPADLET |opName| (|getUnname| |op|)) - (SPADLET |$mapList| (CONS |opName| |$mapList|)) - (SPADLET |$mapTarget| (CAR |sig|)) - (COND - ((AND - (SPADLET |mmS| (|get| |opName| (QUOTE |localModemap|) |$e|)) - (SPADLET |mm| - (PROG (#0=#:G167521) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167529 NIL #0#) - (#2=#:G167530 |mmS| (CDR #2#)) - (|mm| NIL)) - ((OR #1# - (ATOM #2#) - (PROGN (SETQ |mm| (CAR #2#)) NIL) - (PROGN (PROGN (SPADLET |mmSig| (CDAR |mm|)) |mm|) NIL)) - #0#) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |mmSig| |sig|) (SETQ #0# (OR #0# |mm|))))))))))) - (|compileCoerceMap| |opName| |argTypes| |mm|)) - ((QUOTE T) - (|compileDeclaredMap| |opName| |sig| |mapDef|) - (COND - ((NEQUAL |argTypes| (CDR |sig|)) - (|analyzeDeclaredMap| |op| |argTypes| |sig| |mapDef| |$mapList|)) - ((QUOTE T) (CAR |sig|)))))))))) + (DECLARE (SPECIAL |$mapList|)) + (PROG (|opName| |mmS| |mmSig| |mm|) + (DECLARE (SPECIAL |$e| |$mapTarget|)) + (RETURN + (SEQ (PROGN + (SPADLET |opName| (|getUnname| |op|)) + (SPADLET |$mapList| (CONS |opName| |$mapList|)) + (SPADLET |$mapTarget| (CAR |sig|)) + (COND + ((AND (SPADLET |mmS| + (|get| |opName| '|localModemap| |$e|)) + (SPADLET |mm| + (PROG (G167521) + (SPADLET G167521 NIL) + (RETURN + (DO ((G167529 NIL G167521) + (G167530 |mmS| + (CDR G167530)) + (|mm| NIL)) + ((OR G167529 (ATOM G167530) + (PROGN + (SETQ |mm| (CAR G167530)) + NIL) + (PROGN + (PROGN + (SPADLET |mmSig| + (CDAR |mm|)) + |mm|) + NIL)) + G167521) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |mmSig| |sig|) + (SETQ G167521 + (OR G167521 |mm|))))))))))) + (|compileCoerceMap| |opName| |argTypes| |mm|)) + ('T (|compileDeclaredMap| |opName| |sig| |mapDef|) + (COND + ((NEQUAL |argTypes| (CDR |sig|)) + (|analyzeDeclaredMap| |op| |argTypes| |sig| |mapDef| + |$mapList|)) + ('T (CAR |sig|)))))))))) ;compileDeclaredMap(op,sig,mapDef) == ; -- Type analyzes and compiles a map with a declared signature. @@ -2245,52 +2441,66 @@ ; CAR sig (DEFUN |compileDeclaredMap| (|op| |sig| |mapDef|) - (PROG (|$localVars| |$freeVars| |$env| |parms| |body| |name| |val| - |isRecursive|) - (DECLARE (SPECIAL |$localVars| |$freeVars| |$env|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$localVars| NIL) - (SPADLET |$freeVars| NIL) - (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) - (SPADLET |parms| - (PROG (#0=#:G167555) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167561 |$FormalMapVariableList| (CDR #1#)) - (|var| NIL) - (#2=#:G167562 (CDR |sig|) (CDR #2#)) - (|m| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |var| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |m| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS |var| #0#)))))))) - (DO ((#3=#:G167575 (CDR |sig|) (CDR #3#)) - (|m| NIL) - (#4=#:G167576 |parms| (CDR #4#)) - (|var| NIL)) - ((OR (ATOM #3#) - (PROGN (SETQ |m| (CAR #3#)) NIL) - (ATOM #4#) - (PROGN (SETQ |var| (CAR #4#)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |$env| (|put| |var| (QUOTE |mode|) |m| |$env|))))) - (SPADLET |body| (|getMapBody| |op| |mapDef|)) - (DO ((#5=#:G167588 |parms| (CDR #5#)) (|lvar| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |lvar| (CAR #5#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) - (DO ((#6=#:G167597 (|getLocalVars| |op| |body|) (CDR #6#)) (|lvar| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |lvar| (CAR #6#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) - (SPADLET |name| (|makeLocalModemap| |op| |sig|)) - (SPADLET |val| (|compileBody| |body| (CAR |sig|))) - (SPADLET |isRecursive| (> (|depthOfRecursion| |op| |body|) 0)) - (|putMapCode| |op| (|objVal| |val|) |sig| |name| |parms| |isRecursive|) - (|genMapCode| |op| (|objVal| |val|) |sig| |name| |parms| |isRecursive|) - (CAR |sig|)))))) + (PROG (|$localVars| |$freeVars| |$env| |parms| |body| |name| |val| + |isRecursive|) + (DECLARE (SPECIAL |$localVars| |$freeVars| |$env| |$mapName| + |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |$localVars| NIL) + (SPADLET |$freeVars| NIL) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (SPADLET |parms| + (PROG (G167555) + (SPADLET G167555 NIL) + (RETURN + (DO ((G167561 |$FormalMapVariableList| + (CDR G167561)) + (|var| NIL) + (G167562 (CDR |sig|) (CDR G167562)) + (|m| NIL)) + ((OR (ATOM G167561) + (PROGN + (SETQ |var| (CAR G167561)) + NIL) + (ATOM G167562) + (PROGN + (SETQ |m| (CAR G167562)) + NIL)) + (NREVERSE0 G167555)) + (SEQ (EXIT (SETQ G167555 + (CONS |var| G167555)))))))) + (DO ((G167575 (CDR |sig|) (CDR G167575)) (|m| NIL) + (G167576 |parms| (CDR G167576)) (|var| NIL)) + ((OR (ATOM G167575) + (PROGN (SETQ |m| (CAR G167575)) NIL) + (ATOM G167576) + (PROGN (SETQ |var| (CAR G167576)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |$env| + (|put| |var| '|mode| |m| |$env|))))) + (SPADLET |body| (|getMapBody| |op| |mapDef|)) + (DO ((G167588 |parms| (CDR G167588)) (|lvar| NIL)) + ((OR (ATOM G167588) + (PROGN (SETQ |lvar| (CAR G167588)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (DO ((G167597 (|getLocalVars| |op| |body|) + (CDR G167597)) + (|lvar| NIL)) + ((OR (ATOM G167597) + (PROGN (SETQ |lvar| (CAR G167597)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (SPADLET |name| (|makeLocalModemap| |op| |sig|)) + (SPADLET |val| (|compileBody| |body| (CAR |sig|))) + (SPADLET |isRecursive| + (> (|depthOfRecursion| |op| |body|) 0)) + (|putMapCode| |op| (|objVal| |val|) |sig| |name| |parms| + |isRecursive|) + (|genMapCode| |op| (|objVal| |val|) |sig| |name| |parms| + |isRecursive|) + (CAR |sig|)))))) ;putMapCode(op,code,sig,name,parms,isRecursive) == ; -- saves the generated code and some other information about the @@ -2301,16 +2511,17 @@ ; op (DEFUN |putMapCode| (|op| |code| |sig| |name| |parms| |isRecursive|) - (PROG (|codeInfo| |allCode|) - (RETURN - (PROGN - (SPADLET |codeInfo| - (VECTOR |op| |code| |sig| |name| |parms| |isRecursive|)) - (SPADLET |allCode| - (CONS |codeInfo| (|get| |op| (QUOTE |generatedCode|) |$e|))) - (SPADLET |$e| - (|putHist| |op| (QUOTE |generatedCode|) |allCode| |$e|)) - |op|)))) + (PROG (|codeInfo| |allCode|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (PROGN + (SPADLET |codeInfo| + (VECTOR |op| |code| |sig| |name| |parms| + |isRecursive|)) + (SPADLET |allCode| + (CONS |codeInfo| (|get| |op| '|generatedCode| |$e|))) + (SPADLET |$e| (|putHist| |op| '|generatedCode| |allCode| |$e|)) + |op|)))) ;makeLocalModemap(op,sig) == ; -- create a local modemap for op with sig, and put it into $e @@ -2323,22 +2534,23 @@ ; newName (DEFUN |makeLocalModemap| (|op| |sig|) - (PROG (|currentMms| |newName| |newMm| |mms|) - (RETURN - (PROGN - (COND - ((SPADLET |currentMms| (|get| |op| (QUOTE |localModemap|) |$e|)) - (|untraceMapSubNames| (CONS (CADAR |currentMms|) NIL)))) - (SPADLET |newName| - (|makeInternalMapName| |op| - (SPADDIFFERENCE (|#| |sig|) 1) - (PLUS 1 (|#| |currentMms|)) - NIL)) - (SPADLET |newMm| - (CONS (CONS (QUOTE |local|) |sig|) (CONS |newName| (CONS NIL NIL)))) - (SPADLET |mms| (CONS |newMm| |currentMms|)) - (SPADLET |$e| (|putHist| |op| (QUOTE |localModemap|) |mms| |$e|)) - |newName|)))) + (PROG (|currentMms| |newName| |newMm| |mms|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (PROGN + (COND + ((SPADLET |currentMms| (|get| |op| '|localModemap| |$e|)) + (|untraceMapSubNames| (CONS (CADAR |currentMms|) NIL)))) + (SPADLET |newName| + (|makeInternalMapName| |op| + (SPADDIFFERENCE (|#| |sig|) 1) + (PLUS 1 (|#| |currentMms|)) NIL)) + (SPADLET |newMm| + (CONS (CONS '|local| |sig|) + (CONS |newName| (CONS NIL NIL)))) + (SPADLET |mms| (CONS |newMm| |currentMms|)) + (SPADLET |$e| (|putHist| |op| '|localModemap| |mms| |$e|)) + |newName|)))) ;genMapCode(op,body,sig,fnName,parms,isRecursive) == ; -- calls the lisp compiler on the body of a map @@ -2364,56 +2576,67 @@ ; wrapMapBodyWithCatch flattenCOND body,isRecursive) (DEFUN |genMapCode| (|op| |body| |sig| |fnName| |parms| |isRecursive|) - (PROG (|lmm| |n| |op0| |locals| |lets|) - (RETURN - (SEQ - (PROGN - (COND - ((SPADLET |lmm| (|get| |op| (QUOTE |localModemap|) |$InteractiveFrame|)) - (|untraceMapSubNames| (CONS (CADAR |lmm|) NIL)))) - (SPADLET |op0| - (COND - ((SPADLET |n| (|isSharpVarWithNum| |op|)) - (STRCONC "")) - ((QUOTE T) |op|))) - (COND - ((|get| |op| (QUOTE |isInterpreterRule|) |$e|) - (|sayKeyedMsg| (QUOTE S2IM0014) - (CONS |op0| - (CONS - (COND - ((PAIRP |sig|) (|prefix2String| (CAR |sig|))) - ((QUOTE T) (MAKESTRING "?"))) NIL)))) - ((QUOTE T) - (|sayKeyedMsg| (QUOTE S2IM0015) - (CONS |op0| (CONS (|formatSignature| |sig|) NIL))))) - (SPADLET |$whereCacheList| (CONS |op| |$whereCacheList|)) - (SPADLET |locals| (SETDIFFERENCE (COPY |$localVars|) |parms|)) - (COND - (|locals| - (SPADLET |lets| - (PROG (#0=#:G167646) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167651 |locals| (CDR #1#)) (|l| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |l| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (CONS - (QUOTE LET) - (CONS |l| - (CONS - (QUOTE (QUOTE UNINITIALIZED_VARIABLE)) - (CONS |op| NIL)))) - #0#)))))))) - (SPADLET |body| - (CONS (QUOTE PROGN) (APPEND |lets| (CONS |body| NIL)))))) - (|reportFunctionCompilation| |op| |fnName| |parms| - (|wrapMapBodyWithCatch| (|flattenCOND| |body|)) |isRecursive|)))))) - + (PROG (|lmm| |n| |op0| |locals| |lets|) + (DECLARE (SPECIAL |$localVars| |$whereCacheList| |$e| + |$InteractiveFrame|)) + (RETURN + (SEQ (PROGN + (COND + ((SPADLET |lmm| + (|get| |op| '|localModemap| + |$InteractiveFrame|)) + (|untraceMapSubNames| (CONS (CADAR |lmm|) NIL)))) + (SPADLET |op0| + (COND + ((SPADLET |n| (|isSharpVarWithNum| |op|)) + (STRCONC "")) + ('T |op|))) + (COND + ((|get| |op| '|isInterpreterRule| |$e|) + (|sayKeyedMsg| 'S2IM0014 + (CONS |op0| + (CONS (COND + ((PAIRP |sig|) + (|prefix2String| (CAR |sig|))) + ('T (MAKESTRING "?"))) + NIL)))) + ('T + (|sayKeyedMsg| 'S2IM0015 + (CONS |op0| (CONS (|formatSignature| |sig|) NIL))))) + (SPADLET |$whereCacheList| (CONS |op| |$whereCacheList|)) + (SPADLET |locals| + (SETDIFFERENCE (COPY |$localVars|) |parms|)) + (COND + (|locals| + (SPADLET |lets| + (PROG (G167646) + (SPADLET G167646 NIL) + (RETURN + (DO ((G167651 |locals| + (CDR G167651)) + (|l| NIL)) + ((OR (ATOM G167651) + (PROGN + (SETQ |l| (CAR G167651)) + NIL)) + (NREVERSE0 G167646)) + (SEQ (EXIT + (SETQ G167646 + (CONS + (CONS 'LET + (CONS |l| + (CONS + ''UNINITIALIZED_VARIABLE + (CONS |op| NIL)))) + G167646)))))))) + (SPADLET |body| + (CONS 'PROGN + (APPEND |lets| (CONS |body| NIL)))))) + (|reportFunctionCompilation| |op| |fnName| |parms| + (|wrapMapBodyWithCatch| (|flattenCOND| |body|)) + |isRecursive|)))))) + ;compileBody(body,target) == ; -- recursively calls the interpreter on the map body ; -- returns a triple with the LISP code for body in the value cell @@ -2424,16 +2647,17 @@ ; r := interpret1(body,target,nil) (DEFUN |compileBody| (|body| |target|) - (PROG (|$insideCompileBodyIfTrue| |$genValue| |$declaredMode| |$eval| |r|) - (DECLARE (SPECIAL |$insideCompileBodyIfTrue| |$genValue| |$declaredMode| - |$eval|)) - (RETURN - (PROGN - (SPADLET |$insideCompileBodyIfTrue| (QUOTE T)) - (SPADLET |$genValue| NIL) - (SPADLET |$declaredMode| |target|) - (SPADLET |$eval| (QUOTE T)) - (SPADLET |r| (|interpret1| |body| |target| NIL)))))) + (PROG (|$insideCompileBodyIfTrue| |$genValue| |$declaredMode| |$eval| + |r|) + (DECLARE (SPECIAL |$insideCompileBodyIfTrue| |$genValue| + |$declaredMode| |$eval|)) + (RETURN + (PROGN + (SPADLET |$insideCompileBodyIfTrue| 'T) + (SPADLET |$genValue| NIL) + (SPADLET |$declaredMode| |target|) + (SPADLET |$eval| 'T) + (SPADLET |r| (|interpret1| |body| |target| NIL)))))) ;compileCoerceMap(op,argTypes,mm) == ; -- compiles call to user-declared map where the arguments need @@ -2459,80 +2683,106 @@ ; CAR sig (DEFUN |compileCoerceMap| (|op| |argTypes| |mm|) - (PROG (|$insideCompileBodyIfTrue| |$genValue| |sig| |imp| |name| |argCode| - |parms| |minivectorName| |body|) - (DECLARE (SPECIAL |$insideCompileBodyIfTrue| |$genValue|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$insideCompileBodyIfTrue| (QUOTE T)) - (SPADLET |$genValue| NIL) - (SPADLET |sig| (CDAR |mm|)) - (SPADLET |imp| (CADR |mm|)) - (SPADLET |parms| - (PROG (#0=#:G167694) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167700 |$FormalMapVariableList| (CDR #1#)) - (|var| NIL) - (#2=#:G167701 (CDR |sig|) (CDR #2#)) - (|t| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |var| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |t| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS |var| #0#)))))))) - (SPADLET |name| (|makeLocalModemap| |op| (CONS (CAR |sig|) |argTypes|))) - (SPADLET |argCode| - (PROG (#3=#:G167716) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G167723 |argTypes| (CDR #4#)) - (|t1| NIL) - (#5=#:G167724 (CDR |sig|) (CDR #5#)) - (|t2| NIL) - (#6=#:G167725 |parms| (CDR #6#)) - (|arg| NIL)) - ((OR (ATOM #4#) - (PROGN (SETQ |t1| (CAR #4#)) NIL) - (ATOM #5#) - (PROGN (SETQ |t2| (CAR #5#)) NIL) - (ATOM #6#) - (PROGN (SETQ |arg| (CAR #6#)) NIL)) - (NREVERSE0 #3#)) - (SEQ - (EXIT - (SETQ #3# - (CONS - (|objVal| - (OR - (|coerceInteractive| (|objNew| |arg| |t1|) |t2|) - (|throwKeyedMsg| (QUOTE S2IC0001) - (CONS |arg| (CONS |$mapName| (CONS |t1| (CONS |t2| NIL))))))) - #3#)))))))) - (SPADLET |$insideCompileBodyIfTrue| NIL) - (SPADLET |parms| (APPEND |parms| (CONS (QUOTE |envArg|) NIL))) - (SPADLET |body| - (CONS (QUOTE SPADCALL) - (APPEND |argCode| - (CONS - (CONS (QUOTE LIST) - (CONS (CONS (QUOTE |function|) (CONS |imp| NIL)) NIL)) - NIL)))) - (SPADLET |minivectorName| (|makeInternalMapMinivectorName| |name|)) - (SPADLET |$minivectorNames| - (CONS (CONS |op| |minivectorName|) |$minivectorNames|)) - (SPADLET |body| (MSUBST |minivectorName| (QUOTE $$$) |body|)) - (COND - (|$compilingInputFile| - (SPADLET |$minivectorCode| - (APPEND |$minivectorCode| (CONS |minivectorName| NIL))))) - (SET |minivectorName| (LIST2REFVEC |$minivector|)) - (|compileInteractive| - (CONS |name| - (CONS (CONS (QUOTE LAMBDA) (CONS |parms| (CONS |body| NIL))) NIL))) - (CAR |sig|)))))) + (PROG (|$insideCompileBodyIfTrue| |$genValue| |sig| |imp| |name| + |argCode| |parms| |minivectorName| |body|) + (DECLARE (SPECIAL |$insideCompileBodyIfTrue| |$genValue| + |$minivector| |$minivectorCode| + |$compilingInputFile| |$minivectorNames| + |$mapName| |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |$insideCompileBodyIfTrue| 'T) + (SPADLET |$genValue| NIL) + (SPADLET |sig| (CDAR |mm|)) + (SPADLET |imp| (CADR |mm|)) + (SPADLET |parms| + (PROG (G167694) + (SPADLET G167694 NIL) + (RETURN + (DO ((G167700 |$FormalMapVariableList| + (CDR G167700)) + (|var| NIL) + (G167701 (CDR |sig|) (CDR G167701)) + (|t| NIL)) + ((OR (ATOM G167700) + (PROGN + (SETQ |var| (CAR G167700)) + NIL) + (ATOM G167701) + (PROGN + (SETQ |t| (CAR G167701)) + NIL)) + (NREVERSE0 G167694)) + (SEQ (EXIT (SETQ G167694 + (CONS |var| G167694)))))))) + (SPADLET |name| + (|makeLocalModemap| |op| + (CONS (CAR |sig|) |argTypes|))) + (SPADLET |argCode| + (PROG (G167716) + (SPADLET G167716 NIL) + (RETURN + (DO ((G167723 |argTypes| (CDR G167723)) + (|t1| NIL) + (G167724 (CDR |sig|) (CDR G167724)) + (|t2| NIL) + (G167725 |parms| (CDR G167725)) + (|arg| NIL)) + ((OR (ATOM G167723) + (PROGN + (SETQ |t1| (CAR G167723)) + NIL) + (ATOM G167724) + (PROGN + (SETQ |t2| (CAR G167724)) + NIL) + (ATOM G167725) + (PROGN + (SETQ |arg| (CAR G167725)) + NIL)) + (NREVERSE0 G167716)) + (SEQ (EXIT (SETQ G167716 + (CONS + (|objVal| + (OR + (|coerceInteractive| + (|objNew| |arg| |t1|) |t2|) + (|throwKeyedMsg| 'S2IC0001 + (CONS |arg| + (CONS |$mapName| + (CONS |t1| + (CONS |t2| NIL))))))) + G167716)))))))) + (SPADLET |$insideCompileBodyIfTrue| NIL) + (SPADLET |parms| (APPEND |parms| (CONS '|envArg| NIL))) + (SPADLET |body| + (CONS 'SPADCALL + (APPEND |argCode| + (CONS + (CONS 'LIST + (CONS + (CONS '|function| + (CONS |imp| NIL)) + NIL)) + NIL)))) + (SPADLET |minivectorName| + (|makeInternalMapMinivectorName| |name|)) + (SPADLET |$minivectorNames| + (CONS (CONS |op| |minivectorName|) + |$minivectorNames|)) + (SPADLET |body| (MSUBST |minivectorName| '$$$ |body|)) + (COND + (|$compilingInputFile| + (SPADLET |$minivectorCode| + (APPEND |$minivectorCode| + (CONS |minivectorName| NIL))))) + (SET |minivectorName| (LIST2REFVEC |$minivector|)) + (|compileInteractive| + (CONS |name| + (CONS (CONS 'LAMBDA + (CONS |parms| (CONS |body| NIL))) + NIL))) + (CAR |sig|)))))) ;depthOfRecursion(opName,body) == ; -- returns the "depth" of recursive calls of opName in body @@ -2560,49 +2810,57 @@ ; '"unknown function form"]) (DEFUN |mapRecurDepth| (|opName| |opList| |body|) - (PROG (|op| |argl| |argc| |obj| |ISTMP#1| |mapDef|) - (RETURN - (SEQ - (COND - ((ATOM |body|) 0) - ((AND (PAIRP |body|) - (PROGN - (SPADLET |op| (QCAR |body|)) - (SPADLET |argl| (QCDR |body|)) - (QUOTE T))) - (SPADLET |argc| - (COND - ((ATOM |argl|) 0) - (|argl| - (PROG (#0=#:G167773) - (SPADLET #0# -999999) - (RETURN - (DO ((#1=#:G167778 |argl| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) #0#) - (SEQ - (EXIT - (SETQ #0# - (MAX #0# (|mapRecurDepth| |opName| |opList| |x|))))))))) - ((QUOTE T) 0))) - (COND - ((|member| |op| |opList|) |argc|) - ((BOOT-EQUAL |op| |opName|) (PLUS 1 |argc|)) - ((AND (SPADLET |obj| (|get| |op| (QUOTE |value|) |$e|)) - (PROGN - (SPADLET |ISTMP#1| (|objVal| |obj|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) - (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) (QUOTE T))))) - (PLUS - (|mapRecurDepth| |opName| - (CONS |op| |opList|) - (|getMapBody| |op| |mapDef|)) - |argc|)) - ((QUOTE T) |argc|))) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "mapRecurDepth" (CONS "unknown function form" NIL))))))))) + (PROG (|op| |argl| |argc| |obj| |ISTMP#1| |mapDef|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (SEQ (COND + ((ATOM |body|) 0) + ((AND (PAIRP |body|) + (PROGN + (SPADLET |op| (QCAR |body|)) + (SPADLET |argl| (QCDR |body|)) + 'T)) + (SPADLET |argc| + (COND + ((ATOM |argl|) 0) + (|argl| (PROG (G167773) + (SPADLET G167773 -999999) + (RETURN + (DO + ((G167778 |argl| + (CDR G167778)) + (|x| NIL)) + ((OR (ATOM G167778) + (PROGN + (SETQ |x| (CAR G167778)) + NIL)) + G167773) + (SEQ + (EXIT + (SETQ G167773 + (MAX G167773 + (|mapRecurDepth| |opName| + |opList| |x|))))))))) + ('T 0))) + (COND + ((|member| |op| |opList|) |argc|) + ((BOOT-EQUAL |op| |opName|) (PLUS 1 |argc|)) + ((AND (SPADLET |obj| (|get| |op| '|value| |$e|)) + (PROGN + (SPADLET |ISTMP#1| (|objVal| |obj|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'MAP) + (PROGN + (SPADLET |mapDef| (QCDR |ISTMP#1|)) + 'T)))) + (PLUS (|mapRecurDepth| |opName| (CONS |op| |opList|) + (|getMapBody| |op| |mapDef|)) + |argc|)) + ('T |argc|))) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS "mapRecurDepth" + (CONS "unknown function form" NIL))))))))) ;analyzeUndeclaredMap(op,argTypes,mapDef,$mapList) == ; -- Computes the signature of the map named op, and compiles the body @@ -2622,56 +2880,66 @@ ; analyzeRecursiveMap(op,argTypes,body,parms,n) (DEFUN |analyzeUndeclaredMap| (|op| |argTypes| |mapDef| |$mapList|) - (DECLARE (SPECIAL |$mapList|)) - (PROG (|$freeVars| |$localVars| |$env| |parms| |body| |n|) - (DECLARE (SPECIAL |$freeVars| |$localVars| |$env|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$freeVars| NIL) - (SPADLET |$localVars| NIL) - (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) - (SPADLET |$mapList| (CONS |op| |$mapList|)) - (SPADLET |parms| - (PROG (#0=#:G167801) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167807 |$FormalMapVariableList| (CDR #1#)) - (|var| NIL) - (#2=#:G167808 |argTypes| (CDR #2#)) - (|m| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |var| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |m| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS |var| #0#)))))))) - (DO ((#3=#:G167823 |argTypes| (CDR #3#)) - (|m| NIL) - (#4=#:G167824 |parms| (CDR #4#)) - (|var| NIL)) - ((OR (ATOM #3#) - (PROGN (SETQ |m| (CAR #3#)) NIL) - (ATOM #4#) - (PROGN (SETQ |var| (CAR #4#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (|put| |var| (QUOTE |autoDeclare|) (QUOTE T) |$env|) - (|put| |var| (QUOTE |mode|) |m| |$env|))))) - (SPADLET |body| (|getMapBody| |op| |mapDef|)) - (DO ((#5=#:G167836 |parms| (CDR #5#)) (|lvar| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |lvar| (CAR #5#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) - (DO ((#6=#:G167845 (|getLocalVars| |op| |body|) (CDR #6#)) (|lvar| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |lvar| (CAR #6#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) - (COND - ((EQL (SPADLET |n| (|depthOfRecursion| |op| |body|)) 0) - (|analyzeNonRecursiveMap| |op| |argTypes| |body| |parms|)) - ((QUOTE T) - (|analyzeRecursiveMap| |op| |argTypes| |body| |parms| |n|)))))))) + (DECLARE (SPECIAL |$mapList|)) + (PROG (|$freeVars| |$localVars| |$env| |parms| |body| |n|) + (DECLARE (SPECIAL |$freeVars| |$localVars| |$env| |$mapName| + |$mapList| |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |$freeVars| NIL) + (SPADLET |$localVars| NIL) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (SPADLET |$mapList| (CONS |op| |$mapList|)) + (SPADLET |parms| + (PROG (G167801) + (SPADLET G167801 NIL) + (RETURN + (DO ((G167807 |$FormalMapVariableList| + (CDR G167807)) + (|var| NIL) + (G167808 |argTypes| (CDR G167808)) + (|m| NIL)) + ((OR (ATOM G167807) + (PROGN + (SETQ |var| (CAR G167807)) + NIL) + (ATOM G167808) + (PROGN + (SETQ |m| (CAR G167808)) + NIL)) + (NREVERSE0 G167801)) + (SEQ (EXIT (SETQ G167801 + (CONS |var| G167801)))))))) + (DO ((G167823 |argTypes| (CDR G167823)) (|m| NIL) + (G167824 |parms| (CDR G167824)) (|var| NIL)) + ((OR (ATOM G167823) + (PROGN (SETQ |m| (CAR G167823)) NIL) + (ATOM G167824) + (PROGN (SETQ |var| (CAR G167824)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|put| |var| '|autoDeclare| 'T |$env|) + (|put| |var| '|mode| |m| |$env|))))) + (SPADLET |body| (|getMapBody| |op| |mapDef|)) + (DO ((G167836 |parms| (CDR G167836)) (|lvar| NIL)) + ((OR (ATOM G167836) + (PROGN (SETQ |lvar| (CAR G167836)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (DO ((G167845 (|getLocalVars| |op| |body|) + (CDR G167845)) + (|lvar| NIL)) + ((OR (ATOM G167845) + (PROGN (SETQ |lvar| (CAR G167845)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (COND + ((EQL (SPADLET |n| (|depthOfRecursion| |op| |body|)) 0) + (|analyzeNonRecursiveMap| |op| |argTypes| |body| + |parms|)) + ('T + (|analyzeRecursiveMap| |op| |argTypes| |body| |parms| + |n|)))))))) ;analyzeNonRecursiveMap(op,argTypes,body,parms) == ; -- analyze and compile a non-recursive map definition @@ -2690,35 +2958,44 @@ ; objMode(T) (DEFUN |analyzeNonRecursiveMap| (|op| |argTypes| |body| |parms|) - (PROG (|b| |t| T$ |sig| |name|) - (RETURN - (SEQ - (PROGN - (SPADLET T$ (|compileBody| |body| |$mapTarget|)) - (COND - ((> |$mapThrowCount| 0) - (SPADLET |t| (|objMode| T$)) - (SPADLET |b| - (PROG (#0=#:G167872) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G167878 NIL (NULL #0#)) - (#2=#:G167879 |$mapReturnTypes| (CDR #2#)) - (|rt| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |rt| (CAR #2#)) NIL)) - #0#) - (SEQ (EXIT (SETQ #0# (AND #0# (BOOT-EQUAL |t| |rt|))))))))) - (COND - ((NULL |b|) - (PROGN - (SPADLET |t| (|resolveTypeListAny| (CONS |t| |$mapReturnTypes|))) - (COND ((NULL |$mapTarget|) (SPADLET |$mapTarget| |t|))) - (SPADLET T$ (|compileBody| |body| |$mapTarget|))))))) - (SPADLET |sig| (CONS (|objMode| T$) |argTypes|)) - (SPADLET |name| (|makeLocalModemap| |op| |sig|)) - (|putMapCode| |op| (|objVal| T$) |sig| |name| |parms| NIL) - (|genMapCode| |op| (|objVal| T$) |sig| |name| |parms| NIL) - (|objMode| T$)))))) + (PROG (|b| |t| T$ |sig| |name|) + (DECLARE (SPECIAL |$mapTarget| |$mapReturnTypes| |$mapThrowCount|)) + (RETURN + (SEQ (PROGN + (SPADLET T$ (|compileBody| |body| |$mapTarget|)) + (COND + ((> |$mapThrowCount| 0) (SPADLET |t| (|objMode| T$)) + (SPADLET |b| + (PROG (G167872) + (SPADLET G167872 'T) + (RETURN + (DO ((G167878 NIL (NULL G167872)) + (G167879 |$mapReturnTypes| + (CDR G167879)) + (|rt| NIL)) + ((OR G167878 (ATOM G167879) + (PROGN + (SETQ |rt| (CAR G167879)) + NIL)) + G167872) + (SEQ (EXIT + (SETQ G167872 + (AND G167872 + (BOOT-EQUAL |t| |rt|))))))))) + (COND + ((NULL |b|) + (PROGN + (SPADLET |t| + (|resolveTypeListAny| + (CONS |t| |$mapReturnTypes|))) + (COND + ((NULL |$mapTarget|) (SPADLET |$mapTarget| |t|))) + (SPADLET T$ (|compileBody| |body| |$mapTarget|))))))) + (SPADLET |sig| (CONS (|objMode| T$) |argTypes|)) + (SPADLET |name| (|makeLocalModemap| |op| |sig|)) + (|putMapCode| |op| (|objVal| T$) |sig| |name| |parms| NIL) + (|genMapCode| |op| (|objVal| T$) |sig| |name| |parms| NIL) + (|objMode| T$)))))) ;analyzeRecursiveMap(op,argTypes,body,parms,n) == ; -- analyze and compile a non-recursive map definition @@ -2740,37 +3017,43 @@ ; tar (DEFUN |analyzeRecursiveMap| (|op| |argTypes| |body| |parms| |n|) - (PROG (|localMapInfo| |sig| |name| |code| |sigChanged| |tar|) - (RETURN - (SEQ - (PROGN - (SPADLET |localMapInfo| (|saveDependentMapInfo| |op| (CDR |$mapList|))) - (SPADLET |tar| - (CATCH (QUOTE |interpreter|) - (|analyzeNonRecur| |op| |body| |$localVars|))) - (DO ((|i| 0 (QSADD1 |i|)) (#0=#:G167912 NIL (NULL |sigChanged|))) - ((OR (QSGREATERP |i| |n|) #0#) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |sigChanged| NIL) - (SPADLET |name| - (|makeLocalModemap| |op| (SPADLET |sig| (CONS |tar| |argTypes|)))) - (SPADLET |code| (|compileBody| |body| |$mapTarget|)) - (COND - ((NEQUAL (|objMode| |code|) |tar|) - (PROGN - (SPADLET |sigChanged| (QUOTE T)) - (SPADLET |tar| (|objMode| |code|)) - (|restoreDependentMapInfo| |op| - (CDR |$mapList|) - |localMapInfo|)))))))) - (COND - (|sigChanged| (|throwKeyedMsg| (QUOTE S2IM0011) (CONS |op| NIL))) - ((QUOTE T) - (|putMapCode| |op| (|objVal| |code|) |sig| |name| |parms| (QUOTE T)) - (|genMapCode| |op| (|objVal| |code|) |sig| |name| |parms| (QUOTE T)) - |tar|))))))) + (PROG (|localMapInfo| |sig| |name| |code| |sigChanged| |tar|) + (DECLARE (SPECIAL |$mapList| |$mapTarget| |$localVars|)) + (RETURN + (SEQ (PROGN + (SPADLET |localMapInfo| + (|saveDependentMapInfo| |op| (CDR |$mapList|))) + (SPADLET |tar| + (CATCH '|interpreter| + (|analyzeNonRecur| |op| |body| |$localVars|))) + (DO ((|i| 0 (QSADD1 |i|)) + (G167912 NIL (NULL |sigChanged|))) + ((OR (QSGREATERP |i| |n|) G167912) NIL) + (SEQ (EXIT (PROGN + (SPADLET |sigChanged| NIL) + (SPADLET |name| + (|makeLocalModemap| |op| + (SPADLET |sig| + (CONS |tar| |argTypes|)))) + (SPADLET |code| + (|compileBody| |body| + |$mapTarget|)) + (COND + ((NEQUAL (|objMode| |code|) |tar|) + (PROGN + (SPADLET |sigChanged| 'T) + (SPADLET |tar| (|objMode| |code|)) + (|restoreDependentMapInfo| |op| + (CDR |$mapList|) |localMapInfo|)))))))) + (COND + (|sigChanged| + (|throwKeyedMsg| 'S2IM0011 (CONS |op| NIL))) + ('T + (|putMapCode| |op| (|objVal| |code|) |sig| |name| + |parms| 'T) + (|genMapCode| |op| (|objVal| |code|) |sig| |name| + |parms| 'T) + |tar|))))))) ;saveDependentMapInfo(op,opList) == ; not (op in opList) => @@ -2784,39 +3067,43 @@ ; nil (DEFUN |saveDependentMapInfo| (|op| |opList|) - (PROG (|lmml| |dep1| |dep2| |LETTMP#1| |lmml'| |gcl'| |lmms| |gcl|) - (RETURN - (SEQ - (COND - ((NULL (|member| |op| |opList|)) - (SPADLET |lmml| - (CONS (CONS |op| (|get| |op| (QUOTE |localModemap|) |$e|)) NIL)) - (SPADLET |gcl| - (CONS (CONS |op| (|get| |op| (QUOTE |generatedCode|) |$e|)) NIL)) - (DO ((#0=#:G167952 (|getFlag| (QUOTE |$dependencies|)) (CDR #0#)) - (#1=#:G167936 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |dep1| (CAR #1#)) - (SPADLET |dep2| (CADR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |dep1| |op|) - (PROGN - (SPADLET |LETTMP#1| - (|saveDependentMapInfo| |dep2| (CONS |op| |opList|))) - (SPADLET |lmml'| (CAR |LETTMP#1|)) - (SPADLET |gcl'| (CDR |LETTMP#1|)) - (SPADLET |lmms| (NCONC |lmml'| |lmml|)) - (SPADLET |gcl| (NCONC |gcl'| |gcl|)))))))) - (CONS |lmms| |gcl|)) - ((QUOTE T) NIL)))))) + (PROG (|lmml| |dep1| |dep2| |LETTMP#1| |lmml'| |gcl'| |lmms| |gcl|) + (DECLARE (SPECIAL |$dependencies| |$e|)) + (RETURN + (SEQ (COND + ((NULL (|member| |op| |opList|)) + (SPADLET |lmml| + (CONS (CONS |op| + (|get| |op| '|localModemap| |$e|)) + NIL)) + (SPADLET |gcl| + (CONS (CONS |op| + (|get| |op| '|generatedCode| |$e|)) + NIL)) + (DO ((G167952 (|getFlag| '|$dependencies|) + (CDR G167952)) + (G167936 NIL)) + ((OR (ATOM G167952) + (PROGN (SETQ G167936 (CAR G167952)) NIL) + (PROGN + (PROGN + (SPADLET |dep1| (CAR G167936)) + (SPADLET |dep2| (CADR G167936)) + G167936) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |dep1| |op|) + (PROGN + (SPADLET |LETTMP#1| + (|saveDependentMapInfo| |dep2| + (CONS |op| |opList|))) + (SPADLET |lmml'| (CAR |LETTMP#1|)) + (SPADLET |gcl'| (CDR |LETTMP#1|)) + (SPADLET |lmms| (NCONC |lmml'| |lmml|)) + (SPADLET |gcl| (NCONC |gcl'| |gcl|)))))))) + (CONS |lmms| |gcl|)) + ('T NIL)))))) ;restoreDependentMapInfo(op, opList, [lmml,:gcl]) == ; not (op in opList) => @@ -2826,41 +3113,49 @@ ; for [op, :gc] in gcl repeat ; $e := putHist(op,'generatedCode,gc,$e) -(DEFUN |restoreDependentMapInfo| (|op| |opList| #0=#:G167980) - (PROG (|lmml| |gcl| |lmm| |gc|) - (RETURN - (SEQ - (PROGN - (SPADLET |lmml| (CAR #0#)) - (SPADLET |gcl| (CDR #0#)) - (COND - ((NULL (|member| |op| |opList|)) - (PROGN - (|clearDependentMaps| |op| |opList|) - (DO ((#1=#:G167999 |lmml| (CDR #1#)) (#2=#:G167971 NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ #2# (CAR #1#)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAR #2#)) - (SPADLET |lmm| (CDR #2#)) - #2#) - NIL)) - NIL) - (SEQ - (EXIT - (SPADLET |$e| (|putHist| |op| (QUOTE |localModemap|) |lmm| |$e|))))) - (DO ((#3=#:G168010 |gcl| (CDR #3#)) (#4=#:G167975 NIL)) - ((OR (ATOM #3#) - (PROGN (SETQ #4# (CAR #3#)) NIL) - (PROGN - (PROGN (SPADLET |op| (CAR #4#)) (SPADLET |gc| (CDR #4#)) #4#) - NIL)) - NIL) - (SEQ - (EXIT - (SPADLET |$e| - (|putHist| |op| (QUOTE |generatedCode|) |gc| |$e|))))))))))))) +(DEFUN |restoreDependentMapInfo| (|op| |opList| G167980) + (PROG (|lmml| |gcl| |lmm| |gc|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (SEQ (PROGN + (SPADLET |lmml| (CAR G167980)) + (SPADLET |gcl| (CDR G167980)) + (COND + ((NULL (|member| |op| |opList|)) + (PROGN + (|clearDependentMaps| |op| |opList|) + (DO ((G167999 |lmml| (CDR G167999)) + (G167971 NIL)) + ((OR (ATOM G167999) + (PROGN + (SETQ G167971 (CAR G167999)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G167971)) + (SPADLET |lmm| (CDR G167971)) + G167971) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |$e| + (|putHist| |op| '|localModemap| + |lmm| |$e|))))) + (DO ((G168010 |gcl| (CDR G168010)) + (G167975 NIL)) + ((OR (ATOM G168010) + (PROGN + (SETQ G167975 (CAR G168010)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G167975)) + (SPADLET |gc| (CDR G167975)) + G167975) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |$e| + (|putHist| |op| + '|generatedCode| |gc| |$e|))))))))))))) ;clearDependentMaps(op,opList) == ; -- clears the local modemaps of all the maps that depend on op @@ -2871,31 +3166,36 @@ ; clearDependentMaps(dep2,[op,:opList]) (DEFUN |clearDependentMaps| (|op| |opList|) - (PROG (|dep1| |dep2|) - (RETURN - (SEQ - (COND - ((NULL (|member| |op| |opList|)) - (EXIT - (PROGN - (SPADLET |$e| (|putHist| |op| (QUOTE |localModemap|) NIL |$e|)) - (SPADLET |$e| (|putHist| |op| (QUOTE |generatedCode|) NIL |$e|)) - (DO ((#0=#:G168038 (|getFlag| (QUOTE |$dependencies|)) (CDR #0#)) - (#1=#:G168028 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |dep1| (CAR #1#)) - (SPADLET |dep2| (CADR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |dep1| |op|) - (|clearDependentMaps| |dep2| (CONS |op| |opList|))))))))))))))) + (PROG (|dep1| |dep2|) + (DECLARE (SPECIAL |$dependencies| |$e|)) + (RETURN + (SEQ (COND + ((NULL (|member| |op| |opList|)) + (EXIT (PROGN + (SPADLET |$e| + (|putHist| |op| '|localModemap| NIL + |$e|)) + (SPADLET |$e| + (|putHist| |op| '|generatedCode| NIL + |$e|)) + (DO ((G168038 (|getFlag| '|$dependencies|) + (CDR G168038)) + (G168028 NIL)) + ((OR (ATOM G168038) + (PROGN + (SETQ G168028 (CAR G168038)) + NIL) + (PROGN + (PROGN + (SPADLET |dep1| (CAR G168028)) + (SPADLET |dep2| (CADR G168028)) + G168028) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |dep1| |op|) + (|clearDependentMaps| |dep2| + (CONS |op| |opList|))))))))))))))) ;analyzeNonRecur(op,body,$localVars) == ; -- type analyze the non-recursive part of a map body @@ -2904,16 +3204,20 @@ ; objMode(compileBody(nrp,$mapTarget)) (DEFUN |analyzeNonRecur| (|op| |body| |$localVars|) - (DECLARE (SPECIAL |$localVars|)) - (PROG (|nrp|) - (RETURN - (SEQ - (PROGN - (SPADLET |nrp| (|nonRecursivePart| |op| |body|)) - (DO ((#0=#:G168056 (|findLocalVars| |op| |nrp|) (CDR #0#)) (|lvar| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |lvar| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) - (|objMode| (|compileBody| |nrp| |$mapTarget|))))))) + (DECLARE (SPECIAL |$localVars|)) + (PROG (|nrp|) + (DECLARE (SPECIAL |$mapTarget| |$mapName|)) + (RETURN + (SEQ (PROGN + (SPADLET |nrp| (|nonRecursivePart| |op| |body|)) + (DO ((G168056 (|findLocalVars| |op| |nrp|) + (CDR G168056)) + (|lvar| NIL)) + ((OR (ATOM G168056) + (PROGN (SETQ |lvar| (CAR G168056)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (|objMode| (|compileBody| |nrp| |$mapTarget|))))))) ;nonRecursivePart(opName, funBody) == ; -- takes funBody, which is the parse tree of the definition of @@ -2924,15 +3228,17 @@ ; throwKeyedMsg("S2IM0012",[opName]) (DEFUN |nonRecursivePart| (|opName| |funBody|) - (PROG (|body| |nrp|) - (RETURN - (PROGN - (SPADLET |body| (|expandRecursiveBody| (CONS |opName| NIL) |funBody|)) - (COND - ((NEQUAL (SPADLET |nrp| (|nonRecursivePart1| |opName| |body|)) - (QUOTE |noMapVal|)) - |nrp|) - ((QUOTE T) (|throwKeyedMsg| (QUOTE S2IM0012) (CONS |opName| NIL)))))))) + (PROG (|body| |nrp|) + (RETURN + (PROGN + (SPADLET |body| + (|expandRecursiveBody| (CONS |opName| NIL) |funBody|)) + (COND + ((NEQUAL (SPADLET |nrp| + (|nonRecursivePart1| |opName| |body|)) + '|noMapVal|) + |nrp|) + ('T (|throwKeyedMsg| 'S2IM0012 (CONS |opName| NIL)))))))) ;expandRecursiveBody(alreadyExpanded, body) == ; -- replaces calls to other maps with their bodies @@ -2953,82 +3259,93 @@ ; '"unknown form of function body"]) (DEFUN |expandRecursiveBody| (|alreadyExpanded| |body|) - (PROG (|op| |argl| |obj| |ISTMP#1| |mapDef| |newBody|) - (RETURN - (SEQ - (COND - ((ATOM |body|) - (COND - ((AND - (SPADLET |obj| (|get| |body| (QUOTE |value|) |$e|)) - (PROGN - (SPADLET |ISTMP#1| (|objVal| |obj|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) - (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) (QUOTE T)))) - (EQL (|numMapArgs| |mapDef|) 0)) - (|getMapBody| |body| |mapDef|)) - ((QUOTE T) |body|))) - ((AND (PAIRP |body|) - (PROGN - (SPADLET |op| (QCAR |body|)) - (SPADLET |argl| (QCDR |body|)) - (QUOTE T))) - (COND - ((NULL (|member| |op| |alreadyExpanded|)) - (COND - ((AND (SPADLET |obj| (|get| |op| (QUOTE |value|) |$e|)) - (PROGN - (SPADLET |ISTMP#1| (|objVal| |obj|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) - (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |newBody| (|getMapBody| |op| |mapDef|)) - (DO ((#0=#:G168093 |argl| (CDR #0#)) - (|arg| NIL) - (#1=#:G168094 |$FormalMapVariableList| (CDR #1#)) - (|var| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |arg| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |var| (CAR #1#)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |newBody| (MSUBST |arg| |var| |newBody|))))) - (|expandRecursiveBody| (CONS |op| |alreadyExpanded|) |newBody|)) - ((QUOTE T) - (CONS |op| - (PROG (#2=#:G168107) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G168112 |argl| (CDR #3#)) (|arg| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |arg| (CAR #3#)) NIL)) - (NREVERSE0 #2#)) - (SEQ - (EXIT - (SETQ #2# - (CONS - (|expandRecursiveBody| |alreadyExpanded| |arg|) - #2#))))))))))) - ((QUOTE T) - (CONS |op| - (PROG (#4=#:G168122) - (SPADLET #4# NIL) - (RETURN - (DO ((#5=#:G168127 |argl| (CDR #5#)) (|arg| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |arg| (CAR #5#)) NIL)) - (NREVERSE0 #4#)) - (SEQ - (EXIT - (SETQ #4# - (CONS - (|expandRecursiveBody| |alreadyExpanded| |arg|) - #4#))))))))))) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "expandRecursiveBody" - (CONS "unknown form of function body" NIL))))))))) + (PROG (|op| |argl| |obj| |ISTMP#1| |mapDef| |newBody|) + (DECLARE (SPECIAL |$FormalMapVariableList| |$e|)) + (RETURN + (SEQ (COND + ((ATOM |body|) + (COND + ((AND (SPADLET |obj| (|get| |body| '|value| |$e|)) + (PROGN + (SPADLET |ISTMP#1| (|objVal| |obj|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'MAP) + (PROGN + (SPADLET |mapDef| (QCDR |ISTMP#1|)) + 'T))) + (EQL (|numMapArgs| |mapDef|) 0)) + (|getMapBody| |body| |mapDef|)) + ('T |body|))) + ((AND (PAIRP |body|) + (PROGN + (SPADLET |op| (QCAR |body|)) + (SPADLET |argl| (QCDR |body|)) + 'T)) + (COND + ((NULL (|member| |op| |alreadyExpanded|)) + (COND + ((AND (SPADLET |obj| (|get| |op| '|value| |$e|)) + (PROGN + (SPADLET |ISTMP#1| (|objVal| |obj|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'MAP) + (PROGN + (SPADLET |mapDef| (QCDR |ISTMP#1|)) + 'T)))) + (SPADLET |newBody| (|getMapBody| |op| |mapDef|)) + (DO ((G168093 |argl| (CDR G168093)) (|arg| NIL) + (G168094 |$FormalMapVariableList| + (CDR G168094)) + (|var| NIL)) + ((OR (ATOM G168093) + (PROGN (SETQ |arg| (CAR G168093)) NIL) + (ATOM G168094) + (PROGN (SETQ |var| (CAR G168094)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |newBody| + (MSUBST |arg| |var| + |newBody|))))) + (|expandRecursiveBody| + (CONS |op| |alreadyExpanded|) |newBody|)) + ('T + (CONS |op| + (PROG (G168107) + (SPADLET G168107 NIL) + (RETURN + (DO ((G168112 |argl| (CDR G168112)) + (|arg| NIL)) + ((OR (ATOM G168112) + (PROGN + (SETQ |arg| (CAR G168112)) + NIL)) + (NREVERSE0 G168107)) + (SEQ (EXIT + (SETQ G168107 + (CONS + (|expandRecursiveBody| + |alreadyExpanded| |arg|) + G168107))))))))))) + ('T + (CONS |op| + (PROG (G168122) + (SPADLET G168122 NIL) + (RETURN + (DO ((G168127 |argl| (CDR G168127)) + (|arg| NIL)) + ((OR (ATOM G168127) + (PROGN + (SETQ |arg| (CAR G168127)) + NIL)) + (NREVERSE0 G168122)) + (SEQ (EXIT (SETQ G168122 + (CONS + (|expandRecursiveBody| + |alreadyExpanded| |arg|) + G168122))))))))))) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS "expandRecursiveBody" + (CONS "unknown form of function body" NIL))))))))) ;nonRecursivePart1(opName, funBody) == ; -- returns a function body which contains only the parts of funBody @@ -3052,71 +3369,73 @@ ; funBody (DEFUN |nonRecursivePart1| (|opName| |funBody|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c| |nra| |nrb| |nrc| - |op| |argl| |args|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |funBody|) - (EQ (QCAR |funBody|) (QUOTE IF)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |funBody|)) - (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|)) (QUOTE T))))))))) - (SPADLET |nra| (|nonRecursivePart1| |opName| |a|)) - (COND - ((BOOT-EQUAL |nra| (QUOTE |noMapVal|)) (QUOTE |noMapVal|)) - ((QUOTE T) - (SPADLET |nrb| (|nonRecursivePart1| |opName| |b|)) - (SPADLET |nrc| (|nonRecursivePart1| |opName| |c|)) - (COND - ((NULL (|member| |nrb| (QUOTE (|noMapVal| |noBranch|)))) - (CONS (QUOTE IF) (CONS |nra| (CONS |nrb| (CONS |nrc| NIL))))) - ((NULL (|member| |nrc| (QUOTE (|noMapVal| |noBranch|)))) - (CONS - (QUOTE IF) - (CONS - (CONS (QUOTE |not|) (CONS |nra| NIL)) - (CONS |nrc| (CONS |nrb| NIL))))) - ((QUOTE T) (QUOTE |noMapVal|)))))) - ((NULL (|containsOp| |funBody| (QUOTE IF))) - (COND - ((|notCalled| |opName| |funBody|) |funBody|) - ((QUOTE T) (QUOTE |noMapVal|)))) - ((AND (PAIRP |funBody|) - (PROGN - (SPADLET |op| (QCAR |funBody|)) - (SPADLET |argl| (QCDR |funBody|)) - (QUOTE T))) - (COND - ((BOOT-EQUAL |op| |opName|) (QUOTE |noMapVal|)) - ((QUOTE T) - (SPADLET |args| - (PROG (#0=#:G168193) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168198 |argl| (CDR #1#)) (|arg| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |arg| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|nonRecursivePart1| |opName| |arg|) #0#)))))))) - (COND - ((MEMQ (QUOTE |noMapVal|) |args|) (QUOTE |noMapVal|)) - ((QUOTE T) (CONS |op| |args|)))))) - ((QUOTE T) |funBody|)))))) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c| |nra| |nrb| |nrc| + |op| |argl| |args|) + (RETURN + (SEQ (COND + ((AND (PAIRP |funBody|) (EQ (QCAR |funBody|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |funBody|)) + (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)))))))) + (SPADLET |nra| (|nonRecursivePart1| |opName| |a|)) + (COND + ((BOOT-EQUAL |nra| '|noMapVal|) '|noMapVal|) + ('T (SPADLET |nrb| (|nonRecursivePart1| |opName| |b|)) + (SPADLET |nrc| (|nonRecursivePart1| |opName| |c|)) + (COND + ((NULL (|member| |nrb| '(|noMapVal| |noBranch|))) + (CONS 'IF + (CONS |nra| (CONS |nrb| (CONS |nrc| NIL))))) + ((NULL (|member| |nrc| '(|noMapVal| |noBranch|))) + (CONS 'IF + (CONS (CONS '|not| (CONS |nra| NIL)) + (CONS |nrc| (CONS |nrb| NIL))))) + ('T '|noMapVal|))))) + ((NULL (|containsOp| |funBody| 'IF)) + (COND + ((|notCalled| |opName| |funBody|) |funBody|) + ('T '|noMapVal|))) + ((AND (PAIRP |funBody|) + (PROGN + (SPADLET |op| (QCAR |funBody|)) + (SPADLET |argl| (QCDR |funBody|)) + 'T)) + (COND + ((BOOT-EQUAL |op| |opName|) '|noMapVal|) + ('T + (SPADLET |args| + (PROG (G168193) + (SPADLET G168193 NIL) + (RETURN + (DO ((G168198 |argl| (CDR G168198)) + (|arg| NIL)) + ((OR (ATOM G168198) + (PROGN + (SETQ |arg| (CAR G168198)) + NIL)) + (NREVERSE0 G168193)) + (SEQ (EXIT + (SETQ G168193 + (CONS + (|nonRecursivePart1| |opName| + |arg|) + G168193)))))))) + (COND + ((MEMQ '|noMapVal| |args|) '|noMapVal|) + ('T (CONS |op| |args|)))))) + ('T |funBody|)))))) ;containsOp(body,op) == ; -- true IFF body contains an op statement @@ -3125,21 +3444,24 @@ ; false (DEFUN |containsOp| (|body| |op|) - (PROG (|argl|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |body|) (EQUAL (QCAR |body|) |op|)) (QUOTE T)) - ((AND (PAIRP |body|) (PROGN (SPADLET |argl| (QCDR |body|)) (QUOTE T))) - (PROG (#0=#:G168221) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168227 NIL #0#) - (#2=#:G168228 |argl| (CDR #2#)) - (|arg| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |arg| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (OR #0# (|containsOp| |arg| |op|))))))))) - ((QUOTE T) NIL)))))) + (PROG (|argl|) + (RETURN + (SEQ (COND + ((AND (PAIRP |body|) (EQUAL (QCAR |body|) |op|)) 'T) + ((AND (PAIRP |body|) + (PROGN (SPADLET |argl| (QCDR |body|)) 'T)) + (PROG (G168221) + (SPADLET G168221 NIL) + (RETURN + (DO ((G168227 NIL G168221) + (G168228 |argl| (CDR G168228)) (|arg| NIL)) + ((OR G168227 (ATOM G168228) + (PROGN (SETQ |arg| (CAR G168228)) NIL)) + G168221) + (SEQ (EXIT (SETQ G168221 + (OR G168221 + (|containsOp| |arg| |op|))))))))) + ('T NIL)))))) ;notCalled(opName,form) == ; -- returns true if opName is not called in the form @@ -3151,58 +3473,59 @@ ; '"unknown form of function body"]) (DEFUN |notCalled| (|opName| |form|) - (PROG (|op| |argl|) - (RETURN - (SEQ - (COND - ((ATOM |form|) (QUOTE T)) - ((AND (PAIRP |form|) - (PROGN - (SPADLET |op| (QCAR |form|)) - (SPADLET |argl| (QCDR |form|)) - (QUOTE T))) - (COND - ((BOOT-EQUAL |op| |opName|) NIL) - ((QUOTE T) - (PROG (#0=#:G168245) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G168251 NIL (NULL #0#)) - (#2=#:G168252 |argl| (CDR #2#)) - (|x| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (AND #0# (|notCalled| |opName| |x|))))))))))) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "notCalled" (CONS "unknown form of function body" NIL))))))))) + (PROG (|op| |argl|) + (RETURN + (SEQ (COND + ((ATOM |form|) 'T) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |argl| (QCDR |form|)) + 'T)) + (COND + ((BOOT-EQUAL |op| |opName|) NIL) + ('T + (PROG (G168245) + (SPADLET G168245 'T) + (RETURN + (DO ((G168251 NIL (NULL G168245)) + (G168252 |argl| (CDR G168252)) (|x| NIL)) + ((OR G168251 (ATOM G168252) + (PROGN (SETQ |x| (CAR G168252)) NIL)) + G168245) + (SEQ (EXIT (SETQ G168245 + (AND G168245 + (|notCalled| |opName| |x|))))))))))) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS "notCalled" + (CONS "unknown form of function body" NIL))))))))) ;mapDefsWithCorrectArgCount(n, mapDef) == ; [def for def in mapDef | (numArgs CAR def) = n] (DEFUN |mapDefsWithCorrectArgCount| (|n| |mapDef|) - (PROG NIL - (RETURN - (SEQ - (PROG (#0=#:G168270) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168276 |mapDef| (CDR #1#)) (|def| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |def| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (|numArgs| (CAR |def|)) |n|) - (SETQ #0# (CONS |def| #0#))))))))))))) + (PROG () + (RETURN + (SEQ (PROG (G168270) + (SPADLET G168270 NIL) + (RETURN + (DO ((G168276 |mapDef| (CDR G168276)) (|def| NIL)) + ((OR (ATOM G168276) + (PROGN (SETQ |def| (CAR G168276)) NIL)) + (NREVERSE0 G168270)) + (SEQ (EXIT (COND + ((BOOT-EQUAL (|numArgs| (CAR |def|)) |n|) + (SETQ G168270 (CONS |def| G168270))))))))))))) ;numMapArgs(mapDef is [[args,:.],:.]) == ; -- returns the number of arguemnts to the map whose body is mapDef ; numArgs args (DEFUN |numMapArgs| (|mapDef|) - (PROG (|args|) - (RETURN - (PROGN - (SPADLET |args| (CAAR |mapDef|)) (|numArgs| |args|))))) + (PROG (|args|) + (RETURN + (PROGN (SPADLET |args| (CAAR |mapDef|)) (|numArgs| |args|))))) ;numArgs args == ; args is ['_|,a,:.] => numArgs a @@ -3211,23 +3534,20 @@ ; 1 (DEFUN |numArgs| (|args|) - (PROG (|ISTMP#1| |a| |argl|) - (RETURN - (COND - ((AND (PAIRP |args|) - (EQ (QCAR |args|) (QUOTE |\||)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |args|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|numArgs| |a|)) - ((AND (PAIRP |args|) - (EQ (QCAR |args|) (QUOTE |Tuple|)) - (PROGN (SPADLET |argl| (QCDR |args|)) (QUOTE T))) - (|#| |argl|)) - ((NULL |args|) 0) - ((QUOTE T) 1))))) + (PROG (|ISTMP#1| |a| |argl|) + (RETURN + (COND + ((AND (PAIRP |args|) (EQ (QCAR |args|) '|\||) + (PROGN + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (|numArgs| |a|)) + ((AND (PAIRP |args|) (EQ (QCAR |args|) '|Tuple|) + (PROGN (SPADLET |argl| (QCDR |args|)) 'T)) + (|#| |argl|)) + ((NULL |args|) 0) + ('T 1))))) ;combineMapParts(mapTail) == ; -- transforms a piece-wise function definition into an if-then-else @@ -3241,46 +3561,50 @@ ; '"unknown function form"]) (DEFUN |combineMapParts| (|mapTail|) - (PROG (|ISTMP#1| |cond| |part| |restMap| |args|) - (RETURN - (SEQ - (COND - ((NULL |mapTail|) (QUOTE |noMapVal|)) - ((AND (PAIRP |mapTail|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |mapTail|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |cond| (QCAR |ISTMP#1|)) - (SPADLET |part| (QCDR |ISTMP#1|)) - (QUOTE T)))) - (PROGN (SPADLET |restMap| (QCDR |mapTail|)) (QUOTE T))) - (COND - ((OR - (|isSharpVarWithNum| |cond|) - (AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |Tuple|)) - (PROGN (SPADLET |args| (QCDR |cond|)) (QUOTE T)) - (PROG (#0=#:G168317) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G168323 NIL (NULL #0#)) - (#2=#:G168324 |args| (CDR #2#)) - (|arg| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |arg| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (AND #0# (|isSharpVarWithNum| |arg|))))))))) - (NULL |cond|)) - |part|) - ((QUOTE T) - (CONS - (QUOTE IF) - (CONS - (|mkMapPred| |cond|) - (CONS |part| (CONS (|combineMapParts| |restMap|) NIL))))))) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "combineMapParts" (CONS "unknown function form" NIL))))))))) + (PROG (|ISTMP#1| |cond| |part| |restMap| |args|) + (RETURN + (SEQ (COND + ((NULL |mapTail|) '|noMapVal|) + ((AND (PAIRP |mapTail|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |mapTail|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cond| (QCAR |ISTMP#1|)) + (SPADLET |part| (QCDR |ISTMP#1|)) + 'T))) + (PROGN (SPADLET |restMap| (QCDR |mapTail|)) 'T)) + (COND + ((OR (|isSharpVarWithNum| |cond|) + (AND (PAIRP |cond|) (EQ (QCAR |cond|) '|Tuple|) + (PROGN (SPADLET |args| (QCDR |cond|)) 'T) + (PROG (G168317) + (SPADLET G168317 'T) + (RETURN + (DO ((G168323 NIL (NULL G168317)) + (G168324 |args| (CDR G168324)) + (|arg| NIL)) + ((OR G168323 (ATOM G168324) + (PROGN + (SETQ |arg| (CAR G168324)) + NIL)) + G168317) + (SEQ (EXIT + (SETQ G168317 + (AND G168317 + (|isSharpVarWithNum| |arg|))))))))) + (NULL |cond|)) + |part|) + ('T + (CONS 'IF + (CONS (|mkMapPred| |cond|) + (CONS |part| + (CONS (|combineMapParts| |restMap|) + NIL))))))) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS "combineMapParts" + (CONS "unknown function form" NIL))))))))) ;mkMapPred cond == ; -- create the predicate on map arguments, derived from "when" clauses @@ -3290,29 +3614,25 @@ ; mkValCheck(cond,1) (DEFUN |mkMapPred| (|cond|) - (PROG (|ISTMP#1| |args| |ISTMP#2| |pred| |vals|) - (RETURN - (COND - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |\||)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (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 |pred| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|mapPredTran| |pred|)) - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |Tuple|)) - (PROGN (SPADLET |vals| (QCDR |cond|)) (QUOTE T))) - (|mkValueCheck| |vals| 1)) - ((QUOTE T) - (|mkValCheck| |cond| 1)))))) + (PROG (|ISTMP#1| |args| |ISTMP#2| |pred| |vals|) + (RETURN + (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|\||) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (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 |pred| (QCAR |ISTMP#2|)) + 'T)))))) + (|mapPredTran| |pred|)) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|Tuple|) + (PROGN (SPADLET |vals| (QCDR |cond|)) 'T)) + (|mkValueCheck| |vals| 1)) + ('T (|mkValCheck| |cond| 1)))))) ;mkValueCheck(vals,i) == ; -- creates predicate for specific value check (i.e f 1 == 1) @@ -3320,19 +3640,17 @@ ; ['and,mkValCheck(first vals,i),mkValueCheck(rest vals,i+1)] (DEFUN |mkValueCheck| (|vals| |i|) - (PROG (|val|) - (RETURN - (COND - ((AND (PAIRP |vals|) - (EQ (QCDR |vals|) NIL) - (PROGN (SPADLET |val| (QCAR |vals|)) (QUOTE T))) - (|mkValCheck| |val| |i|)) - ((QUOTE T) - (CONS - (QUOTE |and|) - (CONS - (|mkValCheck| (CAR |vals|) |i|) - (CONS (|mkValueCheck| (CDR |vals|) (PLUS |i| 1)) NIL)))))))) + (PROG (|val|) + (RETURN + (COND + ((AND (PAIRP |vals|) (EQ (QCDR |vals|) NIL) + (PROGN (SPADLET |val| (QCAR |vals|)) 'T)) + (|mkValCheck| |val| |i|)) + ('T + (CONS '|and| + (CONS (|mkValCheck| (CAR |vals|) |i|) + (CONS (|mkValueCheck| (CDR |vals|) (PLUS |i| 1)) + NIL)))))))) ;mkValCheck(val,i) == ; -- create equality check for map predicates @@ -3340,16 +3658,16 @@ ; ['_=,mkSharpVar i,val] (DEFUN |mkValCheck| (|val| |i|) - (COND - ((|isSharpVarWithNum| |val|) (QUOTE |true|)) - ((QUOTE T) (CONS (QUOTE =) (CONS (|mkSharpVar| |i|) (CONS |val| NIL)))))) + (COND + ((|isSharpVarWithNum| |val|) '|true|) + ('T (CONS '= (CONS (|mkSharpVar| |i|) (CONS |val| NIL)))))) ;mkSharpVar i == ; -- create #i ; INTERN CONCAT('"#",STRINGIMAGE i) (DEFUN |mkSharpVar| (|i|) - (INTERN (CONCAT (MAKESTRING "#") (STRINGIMAGE |i|)))) + (INTERN (CONCAT (MAKESTRING "#") (STRINGIMAGE |i|)))) ;mapPredTran pred == ; -- transforms "x in i..j" to "x>=i and x<=j" @@ -3360,72 +3678,64 @@ ; pred (DEFUN |mapPredTran| (|pred|) - (PROG (|ISTMP#1| |var| |ISTMP#2| |ISTMP#3| |ISTMP#4| |lb| |ISTMP#5| |ub|) - (RETURN - (COND - ((AND (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE |in|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |var| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) + (PROG (|ISTMP#1| |var| |ISTMP#2| |ISTMP#3| |ISTMP#4| |lb| |ISTMP#5| + |ub|) + (RETURN + (COND + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) '|in|) (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) (QUOTE SEGMENT)) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN (SPADLET |lb| (QCAR |ISTMP#4|)) (QUOTE T))))))))))) - (|mkLessOrEqual| |lb| |var|)) - ((AND (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE |in|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |var| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + (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|) 'SEGMENT) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |lb| (QCAR |ISTMP#4|)) + 'T)))))))))) + (|mkLessOrEqual| |lb| |var|)) + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) '|in|) (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) (QUOTE SEGMENT)) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |lb| (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| (QCDR |ISTMP#4|)) - (AND - (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |ub| (QCAR |ISTMP#5|)) - (QUOTE T))))))))))))) - (COND - ((NULL |ub|) (|mkLessOrEqual| |lb| |var|)) - ((QUOTE T) - (CONS - (QUOTE |and|) - (CONS - (|mkLessOrEqual| |lb| |var|) - (CONS (|mkLessOrEqual| |var| |ub|) NIL)))))) - ((QUOTE T) |pred|))))) + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + (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|) 'SEGMENT) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |lb| (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |ub| + (QCAR |ISTMP#5|)) + 'T)))))))))))) + (COND + ((NULL |ub|) (|mkLessOrEqual| |lb| |var|)) + ('T + (CONS '|and| + (CONS (|mkLessOrEqual| |lb| |var|) + (CONS (|mkLessOrEqual| |var| |ub|) NIL)))))) + ('T |pred|))))) ;findLocalVars(op,form) == ; -- analyzes form for local and free variables, and returns the list @@ -3434,7 +3744,8 @@ ; $localVars (DEFUN |findLocalVars| (|op| |form|) - (PROGN (|findLocalVars1| |op| |form|) |$localVars|)) + (DECLARE (SPECIAL |$localVars|)) + (PROGN (|findLocalVars1| |op| |form|) |$localVars|)) ;findLocalVars1(op,form) == ; -- sets the two lists $localVars and $freeVars @@ -3473,145 +3784,152 @@ ; keyedSystemError("S2IM0020",[op]) (DEFUN |findLocalVars1| (|op| |form|) - (PROG (|b| |vars| |vals| |pat| |a| |l| |pattern| |oper| |ISTMP#1| |ISTMP#2| - |body| |itrl| |y| |argl|) - (RETURN - (SEQ - (COND - ((ATOM |form|) - (COND - ((OR (NULL (IDENTP |form|)) (|isSharpVarWithNum| |form|)) NIL) - ((OR (|isLocalVar| |form|) (|isFreeVar| |form|)) NIL) - ((QUOTE T) (|mkFreeVar| |$mapName| |form|)))) - ((AND (PAIRP |form|) - (EQ (QCAR |form|) (QUOTE |local|)) - (PROGN (SPADLET |vars| (QCDR |form|)) (QUOTE T))) - (DO ((#0=#:G168587 |vars| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (COND ((ATOM |x|) (EXIT (|mkLocalVar| |op| |x|)))))))) - ((AND (PAIRP |form|) - (EQ (QCAR |form|) (QUOTE |free|)) - (PROGN (SPADLET |vars| (QCDR |form|)) (QUOTE T))) - (DO ((#1=#:G168596 |vars| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) NIL) - (SEQ (EXIT (COND ((ATOM |x|) (EXIT (|mkFreeVar| |op| |x|)))))))) - ((AND (PAIRP |form|) - (EQ (QCAR |form|) (QUOTE LET)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (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|)) (QUOTE T))))))) - (COND - ((AND (PAIRP |a|) - (EQ (QCAR |a|) (QUOTE |Tuple|)) - (PROGN - (SPADLET |vars| (QCDR |a|)) - (QUOTE T)) - (PAIRP |b|) - (EQ (QCAR |b|) (QUOTE |Tuple|)) - (PROGN (SPADLET |vals| (QCDR |b|)) (QUOTE T))) - (DO ((#2=#:G168606 |vars| (CDR #2#)) - (|var| NIL) - (#3=#:G168607 |vals| (CDR #3#)) - (|val| NIL)) - ((OR (ATOM #2#) - (PROGN (SETQ |var| (CAR #2#)) NIL) - (ATOM #3#) - (PROGN (SETQ |val| (CAR #3#)) NIL)) - NIL) - (SEQ - (EXIT - (|findLocalVars1| |op| - (CONS (QUOTE LET) (CONS |var| (CONS |val| NIL)))))))) - ((AND (PAIRP |a|) - (EQ (QCAR |a|) (QUOTE |construct|)) - (PROGN (SPADLET |pat| (QCDR |a|)) (QUOTE T))) - (DO ((#4=#:G168619 (|listOfVariables| |pat|) (CDR #4#)) (|var| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |var| (CAR #4#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |op| |var|)))) (|findLocalVars1| |op| |b|)) - ((OR (ATOM |a|) - (AND - (PAIRP |a|) - (EQ (QCAR |a|) (QUOTE |:|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (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))))))) - (|mkLocalVar| |op| |a|) (|findLocalVars1| |op| |b|)) - ((QUOTE T) - (|findLocalVars| |op| |b|) - (DO ((#5=#:G168628 |a| (CDR #5#)) (|x| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) NIL) - (SEQ (EXIT (|findLocalVars1| |op| |x|))))))) - ((AND (PAIRP |form|) - (EQ (QCAR |form|) (QUOTE |:|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (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)))))) - (|mkLocalVar| |op| |a|)) - ((AND (PAIRP |form|) - (EQ (QCAR |form|) (QUOTE |is|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |l| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |pattern| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (PROGN - (|findLocalVars1| |op| |l|) - (DO ((#6=#:G168637 (|listOfVariables| (CDR |pattern|)) (CDR #6#)) - (|var| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |var| (CAR #6#)) NIL)) NIL) - (SEQ (EXIT (|mkLocalVar| |op| |var|)))))) - ((AND (PAIRP |form|) - (PROGN - (SPADLET |oper| (QCAR |form|)) - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T)) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |body| (QCAR |ISTMP#2|)) - (SPADLET |itrl| (QCDR |ISTMP#2|)) - (QUOTE T)) - (PROGN (SPADLET |itrl| (NREVERSE |itrl|)) (QUOTE T)))) - (MEMQ |oper| (QUOTE (REPEAT COLLECT)))) - (|findLocalsInLoop| |op| |itrl| |body|)) - ((AND - (PAIRP |form|) - (PROGN - (SPADLET |y| (QCAR |form|)) - (SPADLET |argl| (QCDR |form|)) - (QUOTE T))) - (COND - ((EQ |y| (QUOTE |Record|)) NIL) - ((QUOTE T) - (DO ((#7=#:G168646 |argl| (CDR #7#)) (|x| NIL)) - ((OR (ATOM #7#) (PROGN (SETQ |x| (CAR #7#)) NIL)) NIL) - (SEQ (EXIT (|findLocalVars1| |op| |x|))))))) - ((QUOTE T) (|keyedSystemError| (QUOTE S2IM0020) (CONS |op| NIL)))))))) + (PROG (|b| |vars| |vals| |pat| |a| |l| |pattern| |oper| |ISTMP#1| + |ISTMP#2| |body| |itrl| |y| |argl|) + (DECLARE (SPECIAL |$mapName|)) + (RETURN + (SEQ (COND + ((ATOM |form|) + (COND + ((OR (NULL (IDENTP |form|)) + (|isSharpVarWithNum| |form|)) + NIL) + ((OR (|isLocalVar| |form|) (|isFreeVar| |form|)) NIL) + ('T (|mkFreeVar| |$mapName| |form|)))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|local|) + (PROGN (SPADLET |vars| (QCDR |form|)) 'T)) + (DO ((G168587 |vars| (CDR G168587)) (|x| NIL)) + ((OR (ATOM G168587) + (PROGN (SETQ |x| (CAR G168587)) NIL)) + NIL) + (SEQ (EXIT (COND + ((ATOM |x|) + (EXIT (|mkLocalVar| |op| |x|)))))))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|free|) + (PROGN (SPADLET |vars| (QCDR |form|)) 'T)) + (DO ((G168596 |vars| (CDR G168596)) (|x| NIL)) + ((OR (ATOM G168596) + (PROGN (SETQ |x| (CAR G168596)) NIL)) + NIL) + (SEQ (EXIT (COND + ((ATOM |x|) (EXIT (|mkFreeVar| |op| |x|)))))))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (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|) '|Tuple|) + (PROGN (SPADLET |vars| (QCDR |a|)) 'T) + (PAIRP |b|) (EQ (QCAR |b|) '|Tuple|) + (PROGN (SPADLET |vals| (QCDR |b|)) 'T)) + (DO ((G168606 |vars| (CDR G168606)) (|var| NIL) + (G168607 |vals| (CDR G168607)) (|val| NIL)) + ((OR (ATOM G168606) + (PROGN (SETQ |var| (CAR G168606)) NIL) + (ATOM G168607) + (PROGN (SETQ |val| (CAR G168607)) NIL)) + NIL) + (SEQ (EXIT (|findLocalVars1| |op| + (CONS 'LET + (CONS |var| (CONS |val| NIL)))))))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|construct|) + (PROGN (SPADLET |pat| (QCDR |a|)) 'T)) + (DO ((G168619 (|listOfVariables| |pat|) + (CDR G168619)) + (|var| NIL)) + ((OR (ATOM G168619) + (PROGN (SETQ |var| (CAR G168619)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |op| |var|)))) + (|findLocalVars1| |op| |b|)) + ((OR (ATOM |a|) + (AND (PAIRP |a|) (EQ (QCAR |a|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (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))))))) + (|mkLocalVar| |op| |a|) (|findLocalVars1| |op| |b|)) + ('T (|findLocalVars| |op| |b|) + (DO ((G168628 |a| (CDR G168628)) (|x| NIL)) + ((OR (ATOM G168628) + (PROGN (SETQ |x| (CAR G168628)) NIL)) + NIL) + (SEQ (EXIT (|findLocalVars1| |op| |x|))))))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (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)))))) + (|mkLocalVar| |op| |a|)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|is|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |l| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |pattern| (QCAR |ISTMP#2|)) + 'T)))))) + (PROGN + (|findLocalVars1| |op| |l|) + (DO ((G168637 (|listOfVariables| (CDR |pattern|)) + (CDR G168637)) + (|var| NIL)) + ((OR (ATOM G168637) + (PROGN (SETQ |var| (CAR G168637)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |op| |var|)))))) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |oper| (QCAR |form|)) + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + (SPADLET |itrl| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |itrl| (NREVERSE |itrl|)) + 'T))) + (MEMQ |oper| '(REPEAT COLLECT))) + (|findLocalsInLoop| |op| |itrl| |body|)) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |y| (QCAR |form|)) + (SPADLET |argl| (QCDR |form|)) + 'T)) + (COND + ((EQ |y| '|Record|) NIL) + ('T + (DO ((G168646 |argl| (CDR G168646)) (|x| NIL)) + ((OR (ATOM G168646) + (PROGN (SETQ |x| (CAR G168646)) NIL)) + NIL) + (SEQ (EXIT (|findLocalVars1| |op| |x|))))))) + ('T (|keyedSystemError| 'S2IM0020 (CONS |op| NIL)))))))) ;findLocalsInLoop(op,itrl,body) == ; for it in itrl repeat @@ -3631,98 +3949,113 @@ ; findLocalVars1(op,b) (DEFUN |findLocalsInLoop| (|op| |itrl| |body|) - (PROG (|lower| |ISTMP#3| |step| |upperList| |index| |ISTMP#2| |s| - |pred| |ISTMP#1| |b|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G168789 |itrl| (CDR #0#)) (|it| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |it| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |it|) - (EQ (QCAR |it|) (QUOTE STEP)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |index| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |lower| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |step| (QCAR |ISTMP#3|)) - (SPADLET |upperList| (QCDR |ISTMP#3|)) - (QUOTE T))))))))) - (|mkLocalVar| |op| |index|) - (|findLocalVars1| |op| |lower|) - (DO ((#1=#:G168798 |upperList| (CDR #1#)) (|up| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |up| (CAR #1#)) NIL)) NIL) - (SEQ (EXIT (|findLocalVars1| |op| |up|))))) - ((AND (PAIRP |it|) - (EQ (QCAR |it|) (QUOTE IN)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |index| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |s| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|mkLocalVar| |op| |index|)) - ((QUOTE T) - (|findLocalVars1| |op| |s|) - (COND - ((AND - (PAIRP |it|) - (EQ (QCAR |it|) (QUOTE WHILE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|findLocalVars1| |op| |b|)) - ((AND - (PAIRP |it|) - (EQ (QCAR |it|) (QUOTE |\||)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |pred| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|findLocalVars1| |op| |pred|)))))))) - (|findLocalVars1| |op| |body|) - (SEQ - (DO ((#2=#:G168812 |itrl| (CDR #2#)) (|it| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |it| (CAR #2#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |it|) - (PROGN - (SPADLET |op| (QCAR |it|)) - (SPADLET |ISTMP#1| (QCDR |it|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) (QUOTE T)))) - (|member| |op| (QUOTE (UNTIL)))) - (EXIT (|findLocalVars1| |op| |b|))))))))))))) + (PROG (|lower| |ISTMP#3| |step| |upperList| |index| |ISTMP#2| |s| + |pred| |ISTMP#1| |b|) + (RETURN + (SEQ (PROGN + (DO ((G168789 |itrl| (CDR G168789)) (|it| NIL)) + ((OR (ATOM G168789) + (PROGN (SETQ |it| (CAR G168789)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| + (QCAR |ISTMP#3|)) + (SPADLET |upperList| + (QCDR |ISTMP#3|)) + 'T)))))))) + (|mkLocalVar| |op| |index|) + (|findLocalVars1| |op| |lower|) + (DO ((G168798 |upperList| + (CDR G168798)) + (|up| NIL)) + ((OR (ATOM G168798) + (PROGN + (SETQ |up| (CAR G168798)) + NIL)) + NIL) + (SEQ (EXIT (|findLocalVars1| |op| |up|))))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (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)))))) + (|mkLocalVar| |op| |index|)) + ('T (|findLocalVars1| |op| |s|) + (COND + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#1|)) + 'T)))) + (|findLocalVars1| |op| |b|)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) '|\||) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (|findLocalVars1| |op| |pred|)))))))) + (|findLocalVars1| |op| |body|) + (SEQ (DO ((G168812 |itrl| (CDR G168812)) (|it| NIL)) + ((OR (ATOM G168812) + (PROGN (SETQ |it| (CAR G168812)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |it|) + (PROGN + (SPADLET |op| (QCAR |it|)) + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#1|)) + 'T))) + (|member| |op| '(UNTIL))) + (EXIT (|findLocalVars1| |op| |b|))))))))))))) ;isLocalVar(var) == MEMBER(var,$localVars) -(DEFUN |isLocalVar| (|var|) (|member| |var| |$localVars|)) +(DEFUN |isLocalVar| (|var|) + (DECLARE (SPECIAL |$localVars|)) + (|member| |var| |$localVars|)) ;mkLocalVar(op,var) == ; -- add var to the local variable list @@ -3730,20 +4063,24 @@ ; $localVars:= insert(var,$localVars) (DEFUN |mkLocalVar| (|op| |var|) - (COND - ((|isFreeVar| |var|) |$localVars|) - ((QUOTE T) (SPADLET |$localVars| (|insert| |var| |$localVars|))))) + (DECLARE (SPECIAL |$localVars|) (ignore |op|)) + (COND + ((|isFreeVar| |var|) |$localVars|) + ('T (SPADLET |$localVars| (|insert| |var| |$localVars|))))) ;isFreeVar(var) == MEMBER(var,$freeVars) -(DEFUN |isFreeVar| (|var|) (|member| |var| |$freeVars|)) +(DEFUN |isFreeVar| (|var|) + (DECLARE (SPECIAL |$freeVars|)) + (|member| |var| |$freeVars|)) ;mkFreeVar(op,var) == ; -- op here for symmetry with mkLocalVar ; $freeVars:= insert(var,$freeVars) (DEFUN |mkFreeVar| (|op| |var|) - (SPADLET |$freeVars| (|insert| |var| |$freeVars|))) + (DECLARE (SPECIAL |$freeVars|) (ignore |op|)) + (SPADLET |$freeVars| (|insert| |var| |$freeVars|))) ;listOfVariables pat == ; -- return a list of the variables in pat, which is an "is" pattern @@ -3754,43 +4091,47 @@ ; nil (DEFUN |listOfVariables| (|pat|) - (PROG (|ISTMP#1| |var|) - (RETURN - (SEQ - (COND - ((IDENTP |pat|) - (COND - ((BOOT-EQUAL |pat| (INTERN "." "BOOT")) NIL) - ((QUOTE T) (CONS |pat| NIL)))) - ((OR - (AND (PAIRP |pat|) - (EQ (QCAR |pat|) (QUOTE |:|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pat|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |var| (QCAR |ISTMP#1|)) (QUOTE T))))) - (AND (PAIRP |pat|) - (EQ (QCAR |pat|) (QUOTE =)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pat|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |var| (QCAR |ISTMP#1|)) (QUOTE T)))))) - (COND - ((BOOT-EQUAL |var| (INTERN "." "BOOT")) NIL) - ((QUOTE T) (CONS |var| NIL)))) - ((PAIRP |pat|) - (REMDUP - (PROG (#0=#:G168865) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168870 |pat| (CDR #1#)) (|p| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |p| (CAR #1#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (APPEND #0# (|listOfVariables| |p|)))))))))) - ((QUOTE T) NIL)))))) + (PROG (|ISTMP#1| |var|) + (RETURN + (SEQ (COND + ((IDENTP |pat|) + (COND + ((BOOT-EQUAL |pat| (INTERN "." "BOOT")) NIL) + ('T (CONS |pat| NIL)))) + ((OR (AND (PAIRP |pat|) (EQ (QCAR |pat|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T)))) + (AND (PAIRP |pat|) (EQ (QCAR |pat|) '=) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T))))) + (COND + ((BOOT-EQUAL |var| (INTERN "." "BOOT")) NIL) + ('T (CONS |var| NIL)))) + ((PAIRP |pat|) + (REMDUP (PROG (G168865) + (SPADLET G168865 NIL) + (RETURN + (DO ((G168870 |pat| (CDR G168870)) + (|p| NIL)) + ((OR (ATOM G168870) + (PROGN + (SETQ |p| (CAR G168870)) + NIL)) + G168865) + (SEQ (EXIT (SETQ G168865 + (APPEND G168865 + (|listOfVariables| |p|)))))))))) + ('T NIL)))))) ;getMapBody(op,mapDef) == ; -- looks in $e for a map body; if not found it computes then stores it @@ -3798,7 +4139,8 @@ ; combineMapParts mapDef (DEFUN |getMapBody| (|op| |mapDef|) - (OR (|get| |op| (QUOTE |mapBody|) |$e|) (|combineMapParts| |mapDef|))) + (DECLARE (SPECIAL |$e|)) + (OR (|get| |op| '|mapBody| |$e|) (|combineMapParts| |mapDef|))) ;-- $e:= putHist(op,'mapBody,body:= combineMapParts mapDef,$e) ;-- body @@ -3896,16 +4238,17 @@ arguments of this local modemap, f;1 will be invoked. ; lv (DEFUN |getLocalVars| (|op| |body|) - (PROG (|lv|) - (RETURN - (OR - (|get| |op| (QUOTE |localVars|) |$e|) - (PROGN - (SPADLET |$e| - (|putHist| |op| - (QUOTE |localVars|) - (SPADLET |lv| (|findLocalVars| |op| |body|)) |$e|)) - |lv|))))) + (PROG (|lv|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (OR (|get| |op| '|localVars| |$e|) + (PROGN + (SPADLET |$e| + (|putHist| |op| '|localVars| + (SPADLET |lv| (|findLocalVars| |op| |body|)) + |$e|)) + |lv|))))) + @ \eject