--- /dev/null
+<PACKAGE "MAPANA">
+
+<ENTRY MAPPER-AN MAPRET-STOP-ANA MAPLEAVE-ANA MENTROPY MAUX MAUX1 MTUPLE MBAD
+ MOPT MOPT2 MARGS-ANA MNORM>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC" "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]> (TUPCNT TT NSTR) FIX
+ (MPSTRS L-V D-V) <SPECIAL LIST> (R?) <SPECIAL <OR ATOM FALSE>>
+ (STATE) <SPECIAL FIX> (SEGFX) <SPECIAL <LIST [REST NODE]>>
+ (MNOD) <SPECIAL NODE> (OV) SYMTAB
+ (FRET FSTOP MRTYP RETYPS) <SPECIAL ANY> (VALSPCD) <SPECIAL LIST>
+ (ASSU L-D) LIST (SBRL) <OR UVECTOR 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>>)>
+ <PUT .MNOD ,STACKS <* <SET NSTR <- <LENGTH .K> 2>> 2>>
+ <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)
+ <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 ((CNT <+ .NSTR 1>) (B <BINDING-STRUCTURE .ITRNOD>))
+ #DECL ((B) <LIST [REST SYMTAB]> (CNT) FIX)
+ <COND (<L? <SET CNT <- .CNT 1>> 0> <RETURN>)>
+ <PUT <1 .B> ,CODE-SYM 3>
+ <PUT <1 .B> ,USED-AT-ALL T>
+ <SET B <REST .B>>>
+ <REPEAT ((BNDS <REST <BINDING-STRUCTURE .ITRNOD> <+ .NSTR 1>>))
+ <COND (<EMPTY? .BNDS>
+ <AND <NOT <EMPTY? .K>>
+ <MESSAGE ERROR
+ "MAPF FUNC TAKES TOO FEW ARGS. "
+ .ITRNOD>>
+ <RETURN>)>
+ <AND <APPLY <NTH ,MAPANALS <CODE-SYM <1 .BNDS>>>
+ <1 .BNDS>
+ <COND (<NOT <EMPTY? .K>> <1 .K>)>>
+ <SET BNDS <REST .BNDS>>>
+ <OR <EMPTY? .K> <SET K <REST .K>>>>
+ <PUT .ITRNOD ,VSPCD (())>
+ <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OV .VERBOSE))
+ #DECL ((STMPS SHTMPS) FIX)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
+ <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>
+ <PUT .MNOD
+ ,SIDE-EFFECTS
+ (!<SIDE-EFFECTS .ITRNOD> !<SIDE-EFFECTS .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> '![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)
+ <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> '![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)
+ #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE>)
+ <COND (.STRUC <MESSAGE ERROR "TOO MANY ARGS TOO MAPF FCN ">)
+ (ELSE <NORM-BAN .SYM>)>
+ T>
+
+<DEFINE MAUX1 (SYM STRUC)
+ #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE>)
+ <COND (.STRUC <MESSAGE ERROR "TOO MANY ARGS TO MAPF FCN ">)>
+ T>
+
+<DEFINE MNORM (SYM STRUC "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD N)
+ #DECL ((SYM) SYMTAB (STRUC) <OR NODE FALSE> (VARTBL) <SPECIAL SYMTAB>
+ (MNOD N) NODE)
+ <COND (.STRUC
+ <PUT .SYM ,PURE-SYM <>> ;"Tell VARANA to allocate me."
+ <OR <SET TEM
+ <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE .STRUC> ALL .R?>
+ <1 <DECL-SYM .SYM>>>>
+ <MESSAGE ERROR "BAD MAP FUNC ARG " <NAME-SYM .SYM>>>
+ <COND (.R? <SET TEM <TYPE-AND .TEM '<STRUCTURED ANY>>>)>
+ <COND (<N=? .TEM <1 <DECL-SYM .SYM>>>
+ <PUT .SYM ,CURRENT-TYPE .TEM>)>
+ <PUT .SYM ,COMPOSIT-TYPE .TEM>)
+ (ELSE <MESSAGE ERROR "TOO FEW MAPF ARGS FOR FCN ">)>
+ T>
+
+<DEFINE MOPT (SYM STRUC "AUX" (VARTBL <NEXT-SYM .SYM>))
+ #DECL ((SYM) SYMTAB (VARTBL) <SPECIAL SYMTAB> (STRUC) <OR FALSE NODE>)
+ <COND (.STRUC <PUT .SYM ,INIT-SYM <>> <MNORM .SYM .STRUC>)
+ (ELSE <NORM-BAN .SYM>)>
+ T>
+
+<DEFINE MBAD (SYM STRUC) <MESSAGE ERROR "BAD ARG DECL IN MAP FCN " <NAME-SYM .SYM>>>
+
+<DEFINE MOPT2 (SYM STRUC) <COND (.STRUC <MNORM .SYM .STRUC>)> T>
+\\f
+
+<DEFINE MTUPLE (SYM STRUC
+ "AUX" (VARTBL <NEXT-SYM .SYM>)
+ (ATYP
+ <GET-ELE-TYPE <1 <DECL-SYM .SYM>>
+ <SET TUPCNT <+ .TUPCNT 1>>>))
+ <COND (.STRUC
+ <COND (.R?
+ <SET TEM <EANA .STRUC STRUCTURED .NAME>>
+ <==? <STRUCTYP .TEM> <STRUCTYP .ATYP>>)
+ (ELSE
+ <OR <TYPE-OK? <GET-ELE-TYPE <EANA .STRUC STRUCTURED .NAME>
+ ALL>
+ .ATYP>
+ <MESSAGE ERROR "BAD MAP FCN ARG " <NAME-SYM .SYM>>>)>
+ <>)
+ (ELSE T)>>
+
+<DEFINE MENTROPY (N R) T>
+
+<SETG MAPANALS
+ [,MENTROPY
+ ,MAUX
+ ,MAUX1
+ ,MTUPLE
+ ,MBAD
+ ,MOPT
+ ,MOPT
+ ,MOPT2
+ ,MOPT2
+ ,MBAD
+ ,MENTROPY
+ ,MNORM
+ ,MNORM]>
+
+"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)
+ <COND (<ASSIGNED? MNOD>
+ <ARGCHK .LN '(0 1) MAPLEAVE>
+ <COND (<0? .LN>
+ <PUT .N
+ ,KIDS
+ <SET K (<NODE1 ,QUOTE-CODE .N ATOM T ()>)>>)>
+ <SET TEM <EANA <1 .K> .MRTYP MAPLEAVE>>
+ <SET VALSPCD <ORUPC .VARTBL .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)
+ <PROG ()
+ <OR <ASSIGNED? MNOD> <RETURN <SUBR-C-AN .NOD .R>>>
+ <SET ITRNOD <2 <KIDS .MNOD>>>
+ <OR <NODE-NAME <1 <KIDS .MNOD>>>
+ <MESSAGE ERROR " NOTHING TO MAPSTOP/RET TO " .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>>
+ <COND (<ASSIGNED? STATE> <SET STATE 5>)
+ (ELSE <SET SEGFX (.N !.SEGFX)>)>
+ <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 .VARTBL .VALSPCD>>
+ <SET FSTOP <>>)>
+ <PUT <2 <KIDS .MNOD>>
+ ,ACCUM-TYPE
+ <TYPE-MERGE <ACCUM-TYPE <2 <KIDS .MNOD>>> .TYP>>
+ <PUT .NOD ,STACKS <* .ARGS 2>>
+ <PUT .NOD ,NODE-TYPE ,MAPRET-STOP-CODE>>
+ NO-RETURN>
+
+<PUT ,MAPLEAVE ANALYSIS ,MAPLEAVE-ANA>
+
+<PUT ,MAPRET ANALYSIS ,MAPRET-STOP-ANA>
+
+<PUT ,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>>>
+ <TYPE? ,.TT SUBR>
+ .TT>>
+
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff