--- /dev/null
+
+<PACKAGE "MAPANA">
+
+<ENTRY MAPPER-AN
+ MAPRET-STOP-ANA
+ MAPLEAVE-ANA
+ MENTROPY
+ MAUX
+ MAUX1
+ MTUPLE
+ MBAD
+ MOPT
+ MOPT2
+ MNORM
+ MARGS-ANA>
+
+<USE "COMPDEC" "SYMANA" "CHKDCL" "CARANA" "ADVMESS">
+
+<SETG SPECIAL-MAPF-R-SUBRS [,LIST ,+ ,* ,MAX ,MIN]>
+
+<DEFINE MAPPER-AN (MNOD MRTYP
+ "AUX" (K <KIDS .MNOD>) TT ITRNOD FAP T TF (MPSTRS ())
+ (R? <==? <NODE-SUBR .MNOD> ,MAPR>) (TUPCNT 1)
+ (RETYPS NO-RETURN) TEM ASSU L-D L-V D-V VALSPCD SBR
+ (SBRL <>) (SEGFX ()) FINTYPE STATE (FRET T) (FSTOP T)
+ (OV .VARTBL) NSTR (CHF <>))
+ #DECL ((FAP ITRNOD) NODE (K) <LIST [REST NODE]> (TT NSTR) FIX
+ (MPSTRS L-V D-V) <SPECIAL LIST> (R?) <SPECIAL <OR ATOM FALSE>>
+ (STATE TUPCNT) <SPECIAL FIX> (SEGFX) <SPECIAL <LIST [REST NODE]>>
+ (MNOD) <SPECIAL NODE> (OV) <SPECIAL SYMTAB>
+ (FRET FSTOP MRTYP RETYPS) <SPECIAL ANY> (VALSPCD) <SPECIAL LIST>
+ (ASSU L-D) LIST (SBRL) <OR VECTOR FALSE>)
+ <SET TF <EANA <SET FAP <1 .K>> ANY <NODE-NAME .MNOD>>>
+ <COND (<AND <SET SBR <SUBAP? .FAP>>
+ <SET SBRL <MEMQ ,.SBR ,SPECIAL-MAPF-R-SUBRS>>>
+ <PUT .FAP ,NODE-TYPE ,MFIRST-CODE>
+ <COND (<N==? ,.SBR ,LIST>
+ <SET FINTYPE '<OR FIX FLOAT>>
+ <SET STATE 1>)
+ (ELSE <SET FINTYPE LIST>)>
+ <PUT .FAP ,NODE-SUBR <LENGTH .SBRL>>)>
+ <SET ITRNOD <2 .K>>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<L? <MINL <RESULT-TYPE .N>> 1> <SET CHF T>)>>
+ <REST .K 2>>
+ <COND
+ (<==? <SET TT <NODE-TYPE .ITRNOD>> ,MFCN-CODE>
+ <PUT .ITRNOD ,SIDE-EFFECTS <>>
+ <MAPF <>
+ <FUNCTION (N "AUX" RT R)
+ #DECL ((N) NODE)
+ <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+ <==? <NODE-TYPE .N> ,SEG-CODE>>
+ <SET RT <EANA <1 <KIDS .N>> STRUCTURED <NODE-NAME .MNOD>>>
+ <SET RT <GET-ELE-TYPE .RT ALL>>
+ <COND (<NOT <TYPE-OK? .RT STRUCTURED>>
+ <COMPILE-ERROR "MAPF/R on non structured object(s)"
+ .MNOD>)>)
+ (ELSE <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>)>
+ <COND (<AND .VERBOSE
+ <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
+ <ADDVMESS
+ .MNOD
+ ("Non-specific structure for MAPF/R: "
+ .N
+ " type is: "
+ .RT)>)>>
+ <SET K <REST .K 2>>>
+ <SET L-D <SAVE-L-D-STATE .VARTBL>>
+ <PROG ((HTMPS 0) (TMPS 0) (VARTBL <SYMTAB .ITRNOD>) (KK .K) (LL .LIFE)
+ (OVV .VERBOSE))
+ #DECL ((HTMPS TMPS) <SPECIAL FIX> (VARTBL) <SPECIAL SYMTAB>
+ (KK) <LIST [REST NODE]>)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
+ <SET LIFE .LL>
+ <SET L-V ()>
+ <SET FSTOP T>
+ <RESET-VARS .VARTBL .OV>
+ <MUNG-L-D-STATE .VARTBL>
+ <SET K .KK>
+ <SET RETYPS NO-RETURN>
+ <SET ASSU <BUILD-TYPE-LIST .OV>>
+ <SET VALSPCD <BUILD-TYPE-LIST .OV>>
+ <REPEAT ((BNDS <BINDING-STRUCTURE .ITRNOD>) (TUPF <>) (LAST-SEG <>)
+ (SKIPF <>))
+ <COND (<EMPTY? .BNDS>
+ <COND (<AND <NOT .LAST-SEG> <NOT <EMPTY? .K>>>
+ <COMPILE-ERROR
+"MAPF/R function takes too few args "
+ .ITRNOD>)>
+ <RETURN>)>
+ <COND (<==? <CODE-SYM <1 .BNDS>> ,ARGL-TUPLE> <SET TUPF T>)>
+ <COND (<AND <NOT <EMPTY? .K>>
+ <OR <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
+ <==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>>>
+ <COND (<EMPTY? <REST .K>> <SET LAST-SEG 1>)>
+ <COND (<NOT <OR .LAST-SEG .TUPF>> <SET SKIPF T>)>)>
+ <COND (<OR <MANAL-DISP <1 .BNDS>
+ <COND (<NOT <EMPTY? .K>> <1 .K>)>
+ .SKIPF
+ .LAST-SEG>
+ .TUPF>
+ <SET BNDS <REST .BNDS>>)>
+ <COND (<AND <NOT <EMPTY? .BNDS>>
+ <SPEC-SYM <1 .BNDS>>>
+ <PUT .ITRNOD ,SPCS-X T>)>
+ <COND (.LAST-SEG <SET LAST-SEG <+ .LAST-SEG 1>>)>
+ <COND (<AND <NOT .LAST-SEG> <NOT <EMPTY? .K>>>
+ <SET K <REST .K>>)>>
+ <PUT .ITRNOD ,VSPCD (())>
+ <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OVV .VERBOSE))
+ #DECL ((STMPS SHTMPS) FIX)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
+ <SET LIFE .LL>
+ <SET FRET T>
+ <SET TMPS .STMPS>
+ <SET HTMPS .SHTMPS>
+ <PUT .ITRNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
+ <PUT .ITRNOD ,ACCUM-TYPE NO-RETURN>
+ <SET TEM <SEQ-AN <KIDS .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>
+ <OR <NOT <AGND .ITRNOD>>
+ <ASSUM-OK? <ASSUM .ITRNOD> <AGND .ITRNOD>>
+ <AGAIN>>>
+ <COND (<N==? .TEM NO-RETURN>
+ <COND (<NOT .FRET>
+ <SET L-V <MSAVE-L-D-STATE .L-V .OV>>
+ <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .ITRNOD>>>)
+ (ELSE <SET L-V <SAVE-L-D-STATE .OV>>)>)
+ (<N==? <ACCUM-TYPE .ITRNOD> NO-RETURN>
+ <ASSERT-TYPES <VSPCD .ITRNOD>>)>
+ <SET VALSPCD <ORUPC .OV .VALSPCD>>
+ <OR <ASSUM-OK? .ASSU <BUILD-TYPE-LIST .VARTBL>> <AGAIN>>
+ <PUT .ITRNOD ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .ITRNOD>>>
+ <PUT .ITRNOD
+ ,RESULT-TYPE
+ <TYPE-OK? <ACCUM-TYPE .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>>
+ <ASSERT-TYPES .VALSPCD>
+ <COND (<ASSIGNED? STATE>
+ <FIX-STATE <ACCUM-TYPE .ITRNOD> .ITRNOD>
+ <COND (<G? .STATE 4>
+ <SET SBRL <>>
+ <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
+ <SET FINTYPE '<OR FIX FLOAT>>)
+ (ELSE
+ <SET FINTYPE <NTH '[FIX FLOAT FLOAT] <- .STATE 1>>>)>)>
+ <SAVE-SURVIVORS .L-D .LIFE T>
+ <SAVE-SURVIVORS .L-V .LIFE>
+ <SET D-V
+ <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+ (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+ <FREST-L-D-STATE .D-V>
+ <SET LIFE <KILL-REM .LIFE .OV>>
+ <COND (.SBRL <MUNG-SEGS .SEGFX>)>
+ <COND (<SIDE-EFFECTS .ITRNOD>
+ <UPDATE-SIDE-EFFECTS .ITRNOD .MNOD>)>
+ <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
+ <==? <NODE-NAME .FAP> #FALSE ()>>
+ <TYPE-OK? <COND (.CHF <TYPE-MERGE FALSE .TEM .RETYPS>)
+ (ELSE <TYPE-OK? <TYPE-MERGE .TEM .RETYPS> .MRTYP>)>
+ .MRTYP>)
+ (<ASSIGNED? FINTYPE>
+ <COND (<==? .FINTYPE LIST>
+ <TYPE-OK? <TYPE-MERGE <FORM LIST
+ [REST <RESULT-TYPE .ITRNOD>]>
+ .RETYPS>
+ .MRTYP>)
+ (ELSE <TYPE-OK? <TYPE-MERGE .FINTYPE .RETYPS> .MRTYP>)>)
+ (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
+ <MEMQ <NODE-NAME .FAP> '[TUPLE VECTOR UVECTOR]>>
+ <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
+ <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
+ (ELSE <TYPE-OK? <TYPE-MERGE <APPLTYP .FAP> .RETYPS> .MRTYP>)>)
+ (ELSE
+ <COND (<N==? .TT ,MPSBR-CODE>
+ <EANA .ITRNOD APPLICABLE <NODE-NAME .MNOD>>)>
+ <MAPF <>
+ <FUNCTION (N "AUX" RT R)
+ #DECL ((N) NODE)
+ <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+ <==? <NODE-TYPE .N> ,SEG-CODE>>
+ <SET RT <EANA <1 <KIDS .N>> STRUCTURED <NODE-NAME .MNOD>>>
+ <SET RT <GET-ELE-TYPE .RT ALL>>)
+ (ELSE <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>)>
+ <COND (<AND .VERBOSE
+ <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
+ <ADDVMESS
+ .MNOD
+ ("Non-specific structure for MAPF/R: "
+ .N
+ " type is: "
+ .RT)>)>>
+ <SET MPSTRS <REST .K 2>>>
+ <COND (<==? .TT ,MPSBR-CODE>
+ <SET TEM <EANA <1 <KIDS .ITRNOD>> ANY <NODE-NAME .MNOD>>>
+ <COND (.CHF <SET TEM <TYPE-MERGE .TEM FALSE>>)>)
+ (ELSE <SET TEM ANY>)>
+ <COND (<ASSIGNED? STATE>
+ <FIX-STATE .TEM <1 <KIDS .ITRNOD>>>
+ <COND (<G? .STATE 4>
+ <SET SBRL <>>
+ <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
+ <SET FINTYPE '<OR FIX FLOAT>>)
+ (ELSE
+ <SET FINTYPE <NTH '[FIX FLOAT FLOAT] <- .STATE 1>>>)>)>
+ <COND (.SBRL <MUNG-SEGS .SEGFX>)>
+ <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
+ <==? <NODE-NAME .FAP> #FALSE ()>>
+ <TYPE-OK? .TEM .MRTYP>)
+ (<ASSIGNED? FINTYPE>
+ <COND (<==? .FINTYPE LIST>
+ <TYPE-OK? <FORM LIST [REST .TEM]> .MRTYP>)
+ (ELSE <TYPE-OK? .FINTYPE .MRTYP>)>)
+ (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
+ <MEMQ <NODE-NAME .FAP> '[TUPLE VECTOR UVECTOR]>>
+ <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
+ <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
+ (ELSE <TYPE-OK? <APPLTYP .FAP> .MRTYP>)>)>>
+
+\\f
+
+<DEFINE FIX-STATE (TEM N "AUX" TT (SG <MEMQ <NODE-TYPE .N> ,SEG-CODES>))
+ #DECL ((STATE TT) FIX (N) NODE)
+ <SET TT
+ <COND (<==? .TEM FIX> 1)
+ (<==? .TEM FLOAT> 2)
+ (<NOT <TYPE-OK? .TEM FLOAT>>
+ <PUT .N
+ ,RESULT-TYPE
+ <COND (.SG
+ <TYPE-MERGE '<STRUCTURED [REST FIX]>
+ <RESULT-TYPE .N>>)
+ (ELSE FIX)>>
+ 1)
+ (<NOT <TYPE-OK? .TEM FIX>>
+ <PUT .N
+ ,RESULT-TYPE
+ <COND (.SG
+ <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
+ <RESULT-TYPE .N>>)
+ (ELSE FLOAT)>>
+ 2)
+ (ELSE 3)>>
+ <SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
+
+<SETG SEG-CODES [,SEG-CODE ,SEGMENT-CODE]>
+
+<DEFINE MUNG-SEGS (SEGS)
+ #DECL ((SEGS) <LIST [REST NODE]>)
+ <MAPF <>
+ <FUNCTION (N) #DECL ((N) NODE) <PUT .N ,NODE-TYPE ,SEG-CODE>>
+ .SEGS>>
+
+<DEFINE MARGS-ANA (N R "AUX" (MK .MPSTRS) (NN <NODE-NAME .N>))
+ #DECL ((N) NODE (NN) FIX (MK) <LIST [REST NODE]>)
+ <SET R
+ <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE <NTH .MK .NN>> ALL .R?> .R>>
+ <COND (.R? <TYPE-OK? .R '<STRUCTURED ANY>>) (ELSE .R)>>
+
+<DEFINE MAUX (SYM STRUC SKIPF LAST-SEG)
+ #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE> (MNOD) NODE)
+ <COND (<AND .STRUC <NOT .SKIPF> <NOT .LAST-SEG>>
+ <COMPILE-ERROR "MAPF/R function takes too many args "
+ <2 <KIDS .MNOD>>>)
+ (ELSE <NORM-BAN .SYM>)>
+ T>
+
+<DEFINE MAUX1 (SYM STRUC SKIPF LAST-SEG)
+ #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE> (MNOD) NODE)
+ <COND (<AND .STRUC <NOT .SKIPF> <NOT .LAST-SEG>>
+ <COMPILE-ERROR "MAPF/R function takes too many args "
+ <2 <KIDS .MNOD>>>)>
+ <PUT .SYM
+ ,COMPOSIT-TYPE
+ <COND (.ANALY-OK NO-RETURN) (ELSE <DECL-SYM .SYM>)>>
+ <PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN) (ELSE ANY)>>
+ T>
+
+<DEFINE MNORM (SYM STRUC SKIPF LAST-SEG
+ "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD N TYP)
+ #DECL ((SYM) SYMTAB (STRUC) <OR NODE FALSE> (VARTBL) <SPECIAL SYMTAB>
+ (MNOD N) NODE)
+ <COND (<AND .STRUC <NOT .SKIPF>>
+ <COND (.LAST-SEG
+ <SET TYP
+ <GET-ELE-TYPE
+ <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>
+ .LAST-SEG>>)
+ (ELSE <SET TYP <EANA .STRUC ANY MAPF/R>>)>
+ <COND (<NOT <SET TEM
+ <TYPE-OK? <GET-ELE-TYPE .TYP ALL .R?>
+ <DECL-SYM .SYM>>>>
+ <COMPILE-ERROR "MAPF/R structure violates arg DECL "
+ <NAME-SYM .SYM>
+ " "
+ <DECL-SYM .SYM>
+ .STRUC>)>
+ <COND (.R? <SET TEM <TYPE-AND .TEM '<STRUCTURED ANY>>>)>
+ <COND (<N=? .TEM <DECL-SYM .SYM>>
+ <PUT .SYM ,CURRENT-TYPE .TEM>)>
+ <PUT .SYM ,COMPOSIT-TYPE .TEM>)
+ (<NOT .SKIPF>
+ <COMPILE-ERROR "Too fewa argumens MAPF/R function" .MNOD>)>
+ T>
+
+<DEFINE MOPT (SYM STRUC SKIPF LAST-SEG "AUX" (VARTBL <NEXT-SYM .SYM>))
+ #DECL ((SYM) SYMTAB (VARTBL) <SPECIAL SYMTAB> (STRUC) <OR FALSE NODE>)
+ <COND (.STRUC
+ <PUT .SYM ,INIT-SYM <>>
+ <MNORM .SYM .STRUC .SKIPF .LAST-SEG>)>
+ <COND (<OR <NOT .STRUC> .SKIPF .LAST-SEG> <NORM-BAN .SYM>)>
+ T>
+
+<DEFINE MBAD (SYM STRUC SKIPF LAST-SEG)
+ <COMPILE-ERROR "Unrecognized arg decl in MAPF/R function "
+ <NAME-SYM .SYM>>>
+
+<DEFINE MOPT2 (SYM STRUC SKIPF LAST-SEG)
+ <COND (.STRUC <MNORM .SYM .STRUC .SKIPF .LAST-SEG>)>
+ T>
+
+\\f
+
+<DEFINE MTUPLE (SYM STRUC SKIPF LAST-SEG
+ "AUX" (VARTBL <NEXT-SYM .SYM>) TYP
+ (ATYP
+ <GET-ELE-TYPE <DECL-SYM .SYM>
+ <COND (.LAST-SEG ALL)
+ (ELSE <SET TUPCNT <+ .TUPCNT 1>>)>>)
+ TEM)
+ #DECL ((VARTBL) <SPECIAL ANY> (TUPCNT) FIX)
+ <COND
+ (<AND .STRUC <NOT .SKIPF>>
+ <COND (.R?
+ <COND (<NOT <COND (.LAST-SEG
+ <SET TEM
+ <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>>
+ <==? <STRUCTYP <GET-ELE-TYPE .TEM ALL>>
+ <STRUCTYP .ATYP>>)
+ (ELSE
+ <SET TEM <EANA .STRUC STRUCTURED MAPF/R>>
+ <==? <STRUCTYP .TEM> <STRUCTYP .ATYP>>)>>
+ <COMPILE-ERROR "Bad argument to MAPF/R function "
+ <NAME-SYM .SYM>
+ .MNOD>)>)
+ (.LAST-SEG
+ <SET TEM <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>>
+ <COND (<NOT <TYPE-OK? <GET-ELE-TYPE <GET-ELE-TYPE .TEM ALL>
+ ALL>
+ .ATYP>>
+ <COMPILE-ERROR "Bad argument to MAPF/R function "
+ <NAME-SYM .SYM>
+ .MNOD>)>)
+ (<AND .STRUC .SKIPF> <ANA .STRUC ANY>)
+ (<NOT .SKIPF>
+ <COND (<NOT <TYPE-OK? <GET-ELE-TYPE <EANA .STRUC STRUCTURED MAPF/R>
+ ALL>
+ .ATYP>>
+ <COMPILE-ERROR "Bad argument to MAPF/R function "
+ <NAME-SYM .SYM>
+ .MNOD>)>)>
+ <>)
+ (ELSE T)>>
+
+<DEFINE MENTROPY (N R "OPT" X Y) T>
+
+<DEFINE MANAL-DISP (SYM NOD SKIPF LAST-SEG "AUX" (COD <CODE-SYM .SYM>))
+ <CASE ,==?
+ .COD
+ (,ARGL-ACT <MENTROPY .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-IAUX <MAUX .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-AUX <MAUX1 .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-TUPLE <MTUPLE .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-ARGS <MBAD .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-QIOPT <MOPT .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-IOPT <MOPT .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-QOPT <MOPT2 .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-OPT <MOPT2 .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-CALL <MBAD .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-BIND <MENTROPY .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-QUOTE <MNORM .SYM .NOD .SKIPF .LAST-SEG>)
+ (,ARGL-ARG <MNORM .SYM .NOD .SKIPF .LAST-SEG>)>>
+
+"Additional SUBR analyzers associated with MAP hackers."
+
+<DEFINE MAPLEAVE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) TEM)
+ #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
+ <SET RET-OR-AGAIN T>
+ <COND (<ASSIGNED? MNOD>
+ <ARGCHK .LN '(0 1) MAPLEAVE .N>
+ <COND (<0? .LN>
+ <PUT .N
+ ,KIDS
+ <SET K (<NODE1 ,QUOTE-CODE .N ATOM T ()>)>>)>
+ <SET TEM <EANA <1 .K> .MRTYP MAPLEAVE>>
+ <SET VALSPCD <ORUPC .OV .VALSPCD>>
+ <SET D-V
+ <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+ (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+ <SET FSTOP <>>
+ <SET RETYPS <TYPE-MERGE .RETYPS .TEM>>
+ <PUT .N ,NODE-TYPE ,MAPLEAVE-CODE>)
+ (ELSE <SUBR-C-AN .N .R>)>
+ NO-RETURN>
+
+\\f
+
+<DEFINE MAPRET-STOP-ANA (NOD R "AUX" (ARGS 0) (TYP NO-RETURN) TYP1 ITRNOD)
+ #DECL ((MNOD NOD ITRNOD) NODE (ARGS) FIX)
+ <SET RET-OR-AGAIN T>
+ <PROG ()
+ <OR <ASSIGNED? MNOD> <RETURN <SUBR-C-AN .NOD .R>>>
+ <PUT <SET ITRNOD <2 <KIDS .MNOD>>> ,ACTIVATED T>
+ ;"So frame will be built"
+ <COND (<NOT <NODE-NAME <1 <KIDS .MNOD>>>>
+ <COMPILE-ERROR "MAPRET/STOP with no final function." .MNOD>)>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND
+ (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+ <==? <NODE-TYPE .N> ,SEG-CODE>>
+ <SET TYP1
+ <EANA <1 <KIDS .N>>
+ <COND (<ASSIGNED? STATE>
+ '<STRUCTURED [REST <OR FIX FLOAT>]>)
+ (ELSE STRUCTURED)>
+ SEGMENT>>
+ <SET TYP <TYPE-MERGE .TYP <GET-ELE-TYPE .TYP1 ALL>>>
+ <PUT .NOD ,SEGS T>)
+ (ELSE
+ <SET ARGS <+ .ARGS 1>>
+ <SET TYP
+ <TYPE-MERGE
+ .TYP
+ <EANA .N
+ <COND (<ASSIGNED? STATE> '<OR FIX FLOAT>)
+ (ELSE ANY)>
+ <NODE-NAME .NOD>>>>)>>
+ <KIDS .NOD>>
+ <AND <ASSIGNED? STATE> <N==? .TYP NO-RETURN> <FIX-STATE .TYP .NOD>>
+ <COND (<==? <NODE-SUBR .NOD> ,MAPRET>
+ <SET L-V
+ <COND (.FRET <SAVE-L-D-STATE .VARTBL>)
+ (ELSE <MSAVE-L-D-STATE .L-V .VARTBL>)>>
+ <PUT .ITRNOD
+ ,VSPCD
+ <COND (.FRET <BUILD-TYPE-LIST .VARTBL>)
+ (ELSE <ORUPC .VARTBL <VSPCD .ITRNOD>>)>>
+ <SET FRET <>>)
+ (ELSE
+ <SET D-V
+ <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+ (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+ <SET VALSPCD <ORUPC .OV .VALSPCD>>
+ <SET FSTOP <>>)>
+ <PUT <2 <KIDS .MNOD>>
+ ,ACCUM-TYPE
+ <TYPE-MERGE <ACCUM-TYPE <2 <KIDS .MNOD>>> .TYP>>
+ <PUT .NOD ,NODE-TYPE ,MAPRET-STOP-CODE>>
+ NO-RETURN>
+
+<COND (<GASSIGNED? MAPLEAVE-ANA>
+ <PUTPROP ,MAPLEAVE ANALYSIS ,MAPLEAVE-ANA>
+ <PUTPROP ,MAPRET ANALYSIS ,MAPRET-STOP-ANA>
+ <PUTPROP ,MAPSTOP ANALYSIS ,MAPRET-STOP-ANA>)>
+
+<DEFINE SUBAP? (NOD "AUX" TT (COD 0))
+ #DECL ((COD) FIX (NOD) NODE)
+ <AND <OR <==? <SET COD <NODE-TYPE .NOD>> ,FGVAL-CODE>
+ <==? .COD ,GVAL-CODE>
+ <==? .COD ,MFIRST-CODE>>
+ <==? <NODE-TYPE <SET NOD <1 <KIDS .NOD>>>> ,QUOTE-CODE>
+ <GASSIGNED? <SET TT <NODE-NAME .NOD>>>
+ .TT>>
+
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff