--- /dev/null
+<PACKAGE "STRANA">
+
+<ENTRY LENGTH-ANA EMPTY?-ANA LENGTH?-ANA NTH-ANA REST-ANA PUT-ANA PUTREST-ANA
+ MEMQ-ANA NTH-REST-ANA>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
+
+"Structure hackers for the compiler (analyzers)"
+
+<DEFINE LNTH-MT-ANA (NOD RTYP COD
+ "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM (WHO ())
+ (WHON
+ <AND <OR <AND <==? .COD ,LNTH-CODE>
+ <ASSIGNED? GLN>
+ <ANCEST .GLN <PARENT .NOD>>>
+ <AND <==? .PRED <PARENT .NOD>>
+ <==? .COD ,MT-CODE>>>
+ .NOD>))
+ #DECL ((NOD) NODE (LN COD) FIX (K) <LIST [REST NODE]>
+ (WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR NODE FALSE>>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK .LN 1 <NODE-NAME .NOD>>
+ <SET TEM <EANA <1 .K> STRUCTURED <NODE-NAME .NOD>>>
+ <COND (<SET TEM <STRUCTYP .TEM>> <PUT .NOD ,NODE-TYPE .COD>)
+ (ELSE
+ <COND (.VERBOSE
+ <ADDVMESS .NOD
+ ("Not open compiled because type is: "
+ <RESULT-TYPE <1 .K>>)>)>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
+ <COND (<==? .COD ,MT-CODE>
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
+ #DECL ((L) <LIST <OR FALSE ATOM> SYMTAB>
+ (SYM) SYMTAB)
+ '<SET TRUTH
+ <ADD-TYPE-LIST .SYM
+ '<STRUCTURED [REST
+ <NOT ANY>]>
+ .TRUTH
+ .FLG
+ <REST .L 2>>>
+ <SET UNTRUTH
+ <ADD-TYPE-LIST
+ .SYM
+ '<STRUCTURED ANY>
+ .UNTRUTH
+ .FLG
+ <REST .L 2>>>
+ T>
+ .WHO>)
+ (ELSE <SET GLE .WHO>)>
+ <TYPE-OK? <COND (<==? <NODE-SUBR .NOD> ,LENGTH> <FORM FIX (0 ,PLUSINF)>)
+ (ELSE '<OR FALSE ATOM>)>
+ .RTYP>>
+
+<DEFINE ANCEST (N1 N2)
+ #DECL ((N1 N2) NODE)
+ <REPEAT ()
+ <COND (<==? .N1 .N2> <RETURN>)>
+ <OR <==? <NODE-TYPE .N2> ,SET-CODE> <RETURN <>>>
+ <COND (<TYPE? <PARENT .N2> NODE> <SET N2 <PARENT .N2>>)
+ (ELSE <RETURN <>>)>>>
+
+<DEFINE LENGTH-ANA (N R) <LNTH-MT-ANA .N .R ,LNTH-CODE>>
+
+<PUT ,LENGTH ANALYSIS ,LENGTH-ANA>
+
+<DEFINE EMPTY?-ANA (N R) <LNTH-MT-ANA .N .R ,MT-CODE>>
+
+<PUT ,EMPTY? ANALYSIS ,EMPTY?-ANA>
+
+<DEFINE LENGTH?-ANA (NOD RTYP
+ "AUX" (K <KIDS .NOD>) TEM (WHO ())
+ (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON) <SPECIAL ANY>
+ (WHO) <SPECIAL LIST>)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 LENGTH?>
+ <SET TEM <EANA <1 .K> STRUCTURED LENGTH?>>
+ <SET WHON <>>
+ <EANA <2 .K> FIX LENGTH?>
+ <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> ;"Constant 2d arg?"
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
+ #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
+ <SET UNTRUTH
+ <ADD-TYPE-LIST .SYM
+ <FORM STRUCTURED
+ [<NODE-NAME <2 .K>> ANY]>
+ .TRUTH
+ .FLG
+ <REST .L 2>>>>
+ .WHO>)>
+ <COND (<SET TEM <STRUCTYP .TEM>>
+ <PUT .NOD ,NODE-TYPE ,LENGTH?-CODE>)
+ (ELSE
+ <COND (.VERBOSE
+ <ADDVMESS .NOD
+ ("Not open compiled because type is: "
+ <RESULT-TYPE <1 .K>>)>)>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+ <TYPE-OK? <FORM OR <FORM FIX
+ (0
+ <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <NODE-NAME .NOD>)
+ (ELSE ,PLUSINF)>)>
+ FALSE>
+ .RTYP>)>>
+
+<PUT ,LENGTH? ANALYSIS ,LENGTH?-ANA>
+
+<DEFINE NTH-REST-ANA (NOD RTYP COD
+ "OPTIONAL" (TF <>)
+ "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TS VAL TPS
+ (RV <OR .TF <==? <NODE-NAME .NOD> INTH>>)
+ (SVWHO ())
+ (NM <COND (.RV NTH) (ELSE <NODE-NAME .NOD>)>) XX
+ (OWHON <AND <==? .WHON <PARENT .NOD>> .NOD>) NUMB)
+ #DECL ((COD NUMB LN) FIX (NOD WHON PRED) NODE (K) <LIST [REST NODE]>
+ (WHO SVWHO) LIST)
+ <SET VAL
+ <PROG ((WHO ()) (WHON <>))
+ #DECL ((WHON) <SPECIAL ANY> (WHO) <SPECIAL LIST>)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <COND (<1? .LN>
+ <PUT .NOD
+ ,KIDS
+ <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
+ (ELSE <ARGCHK .LN 2 <NODE-NAME .NOD>>)>
+ <COND (.RV
+ <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>
+ <SET WHON .NOD>
+ <SET TS <EANA <1 .K> STRUCTURED .NM>>)
+ (ELSE
+ <SET WHON .NOD>
+ <SET TS <EANA <1 .K> STRUCTURED .NM>>
+ <SET WHON <>>
+ <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>)>
+ <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <==? <ISTYPE? .TF> OFFSET>>
+ <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
+ <PUT <1 .K> ,RESULT-TYPE .TS>)>
+ <SET TPS <STRUCTYP .TS>>
+ <COND (<AND .TPS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+ <SET SVWHO .WHO>)>
+ <COND
+ (<AND .TPS
+ <OR <==? <ISTYPE? .TF> FIX>
+ <AND <==? <ISTYPE? .TF> OFFSET>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
+ <N==? <ISTYPE? .TS> TEMPLATE>
+ <OR <NOT <==? .TPS TEMPLATE>>
+ <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <ISTYPE? .TS>>>>
+ <PUT .NOD ,NODE-TYPE .COD>)
+ (ELSE
+ <AND <==? .COD ,NTH-CODE> <PUT .NOD ,NODE-NAME NTH>>
+ <COND (.VERBOSE
+ <ADDVMESS .NOD ("Not open compiled because type is: " .TS)>)>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+ <TYPE-OK?
+ <GET-ELE-TYPE
+ .TS
+ <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <SET NUMB
+ <COND (<==? <ISTYPE? .TF> OFFSET>
+ <INDEX <NODE-NAME <2 .K>>>)
+ (ELSE <NODE-NAME <2 .K>>)>>)
+ (ELSE ALL)>
+ <==? <NODE-SUBR .NOD> ,REST>>
+ .RTYP>)>>>
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>) (FL <1 .L>) T1 T2)
+ #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
+ <SET XX (.NM .NUMB !<REST .L 2>)>
+ <SET-CURRENT-TYPE
+ .SYM
+ <TYPE-AND <GET-CURRENT-TYPE .SYM> <TYPE-NTH-REST .VAL .XX>>>
+ <COND (.OWHON <SET WHO ((.FL .SYM !.XX) !.WHO)>)>
+ <COND (<AND <==? .PRED <PARENT .NOD>>
+ <SET T1 <TYPE-OK? .VAL FALSE>>
+ <SET T2 <TYPE-OK? .VAL '<NOT FALSE>>>>
+ <SET TRUTH <ADD-TYPE-LIST .SYM .T2 .TRUTH .FL .XX>>
+ <SET UNTRUTH
+ <ADD-TYPE-LIST .SYM .T1 .UNTRUTH .FL .XX>>)>>
+ .SVWHO>
+ <COND (<AND <==? .TPS LIST>
+ <OR <==? <NODE-TYPE <1 .K>> ,LVAL-CODE>
+ <==? <NODE-TYPE <1 .K>> ,SET-CODE>>
+ <LOOK-FOR .NOD <1 .K> <2 .K> <==? <NODE-SUBR .NOD> ,REST>>>
+ <PUT .NOD ,NODE-TYPE ,ALL-REST-CODE>)
+ (<AND <==? .TPS LIST>
+ <==? .COD ,REST-CODE>
+ <GASSIGNED? PUT-SAME-CODE>
+ <==? <NODE-TYPE <1 .K>> ,PUTR-CODE>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <==? .NUMB 1>>
+ <PUT .NOD ,NODE-TYPE ,PUTR-CODE>)>
+ .VAL>
+
+<DEFINE LOOK-FOR (MN N1 N RFLG "AUX" TT K (S ()) (SS (() () ())))
+ #DECL ((S) <LIST [REST NODE]> (N MN N1) NODE (TT) <OR FALSE NODE>
+ (K) <LIST [REST NODE]>)
+ <REPEAT ()
+ <COND (<==? <NODE-TYPE .N1> ,LVAL-CODE>
+ <SET S (.N1 !.S)>
+ <RETURN>)
+ (<==? <NODE-TYPE .N1> ,SET-CODE>
+ <SET S (.N1 !.S)>
+ <SET N1 <2 <KIDS .N1>>>)
+ (ELSE <RETURN>)>>
+ <AND <OR <AND .RFLG
+ <SET TT <SET-SEARCH .N ,ARITH-CODE .S .SS>>
+ <==? <NODE-SUBR <SET N .TT>> ,->
+ <==? <LENGTH <SET K <KIDS .N>>> 2>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <==? <NODE-NAME <2 .K>> 1>
+ <SET N <1 .K>>>
+ <NOT .RFLG>>
+ <SET TT <SET-SEARCH .N ,LNTH-CODE .S <REST .SS>>>
+ <SET TT
+ <SET-SEARCH <1 <KIDS .TT>> ,LVAL-CODE .S <REST .SS 2>>>
+ <SMEMQ <NODE-NAME .TT> .S>
+ <PUT .MN ,TYPE-INFO .SS>>>
+
+<DEFINE SET-SEARCH (N C S SS "AUX" (L ()))
+ #DECL ((N) NODE (C) FIX (S) <LIST [REST NODE]> (L SS) LIST)
+ <REPEAT ()
+ <COND (<==? .C <NODE-TYPE .N>> <PUT .SS 1 .L> <RETURN .N>)>
+ <COND (<OR <N==? <NODE-TYPE .N> ,SET-CODE>
+ <SMEMQ <NODE-NAME .N> .S>>
+ <RETURN <>>)>
+ <SET L (.N !.L)>
+ <SET N <2 <KIDS .N>>>>>
+
+<DEFINE SMEMQ (SYM L)
+ #DECL ((SYM) SYMTAB (L) LIST)
+ <MAPR <>
+ <FUNCTION (LL "AUX" (N <1 .LL>))
+ #DECL ((N) NODE)
+ <COND (<==? <NODE-NAME .N> .SYM> <MAPLEAVE .LL>)>>
+ .L>>
+
+<DEFINE NTH-ANA (N R) <NTH-REST-ANA .N .R ,NTH-CODE>>
+
+<PUT ,NTH ANALYSIS ,NTH-ANA>
+
+<DEFINE REST-ANA (N R) <NTH-REST-ANA .N .R ,REST-CODE>>
+
+<PUT ,REST ANALYSIS ,REST-ANA>
+
+<DEFINE PUT-ANA (NOD RTYP
+ "OPTIONAL" (TF <>)
+ "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) (TS ANY) TV (TPS <>) VAL
+ (SVWHO ()) WHICH NS TVO TEM (P ()) TFF NUMB
+ (RV <OR .TF <==? <NODE-NAME .NOD> IPUT>>)
+ (NM <COND (.RV PUT) (ELSE <NODE-NAME .NOD>)>))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN NUMB) FIX (WHO P SVWHO) LIST)
+ <SET VAL
+ <PROG ((WHO ()) (WHON <>))
+ #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR FALSE NODE>>)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (<==? .LN 2>
+ <EANA <1 .K> ANY <NODE-NAME .NOD>>
+ <EANA <2 .K> ANY <NODE-NAME .NOD>>
+ <COND (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
+ <ADDVMESS .NOD ("PUT being used to remove association.")>)>
+ <PUT .NOD ,NODE-TYPE ,IREMAS-CODE>)
+ (ELSE
+ <ARGCHK .LN 3 <NODE-NAME .NOD>>
+ <COND (.RV
+ <SET WHON <>>
+ <OR .TF <SET TF <SET TFF <ANA <2 .K> ANY>>>>
+ <SET WHON .NOD>
+ <SET TS <ANA <1 .K> <OR <AND .TF STRUCTURED> ANY>>>
+ <SET WHON <>>)
+ (ELSE
+ <SET WHON .NOD>
+ <SET TS <ANA <1 .K> ANY>>
+ <SET WHON <>>
+ <OR .TF <SET TFF <SET TF <ANA <2 .K> ANY>>>>)>
+ <SET TV <ANA <3 .K> ANY>>
+ <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <==? <ISTYPE? .TF> OFFSET>>
+ <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
+ <PUT <1 .K> ,RESULT-TYPE .TS>)>
+ <AND <TYPE-OK? .TS '<NOT STRUCTURED>> <SET TS <>>>
+ <OR <AND <OR <==? <ISTYPE? .TF> FIX>
+ <AND <==? <ISTYPE? .TF> OFFSET>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
+ <==? <NODE-SUBR .NOD> ,PUT>>
+ <SET TF <>>>
+ <SET NS
+ <COND (<AND .TF .TS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+ <SET WHICH
+ <COND (<==? <ISTYPE? .TF> FIX> <NODE-NAME <2 .K>>)
+ (ELSE <INDEX <NODE-NAME <2 .K>>>)>>
+ <FORM STRUCTURED
+ !<COND (<1? .WHICH> (.TV))
+ (ELSE ([<- .WHICH 1> ANY] .TV))>>)
+ (ELSE <SET WHICH ALL> '<STRUCTURED [REST ANY]>)>>
+ <COND
+ (<AND .TS .TF <NOT <EMPTY? .WHO>>>
+ <SET NS
+ <MAPF ,TYPE-MERGE
+ <FUNCTION (L "AUX" (S <2 .L>) (ND <1 <DECL-SYM .S>>))
+ #DECL ((L) <LIST ANY SYMTAB> (S) SYMTAB)
+ <SET ND <DECL-DOWN .ND !<REST .L 2>>>
+ <OR <TYPE-OK? .ND .NS> <MESSAGE ERROR "BAD ARG TO PUT" .NOD>>
+ <SET ND
+ <TYPE-AND
+ <TYPE-AND
+ <GET-ELE-TYPE .ND .WHICH <> .TV>
+ <TOP-TYPE <DECL-DOWN <GET-CURRENT-TYPE .S> !<REST .L 2>>>>
+ .ND>>>
+ .WHO>>
+ <SET TV <TYPE-AND .TV <GET-ELE-TYPE .NS .WHICH>>>)
+ (<NOT <EMPTY? .WHO>> <SET TV ANY>)>
+ <AND .TS
+ <PUT <1 .K> ,RESULT-TYPE <SET TS <TYPE-AND <TOP-TYPE .NS> .TS>>>>
+ <COND (.TS
+ <SET TVO <GET-ELE-TYPE .TS .WHICH>>
+ <SET TS <GET-ELE-TYPE .TS .WHICH <> .TV>>)>
+ <COND (<AND .TS .TF <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+ <SET SVWHO .WHO>)>
+ <COND (<AND .TS .TF>
+ <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>)>
+ <COND
+ (<AND .TS
+ .TF
+ <SET TPS <STRUCTYP .TS>>
+ <OR <==? <ISTYPE? .TF> FIX> <==? <ISTYPE? .TF> OFFSET>>
+ <N==? <ISTYPE? .TS> TEMPLATE>
+ <OR <NOT <==? .TPS TEMPLATE>>
+ <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <ISTYPE? .TS>>>
+ <OR <NOT <==? .TPS LIST>>
+ <0? <SET TEM <DEFERN .TV>>>
+ <AND <==? .TEM 1> <1? <DEFERN .TVO>>>>>
+ <PUT .NOD ,NODE-TYPE ,PUT-CODE>
+ <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <MESSAGE ERROR " ATTEMPT TO MUNG QUOTED OBJECT " .NOD>)>)
+ (ELSE
+ <COND
+ (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
+ <ADDVMESS
+ .NOD
+ <COND
+ (.TF
+ <COND (<==? .TPS LIST> ("Not open compiled because of defer."))
+ (ELSE ("Not open compiled because type is: " .TS))>)
+ (<NOT <TYPE-OK? .TFF FIX>>
+ ("PUT used for association manipulation."))
+ (ELSE
+ ("PUT maybe structure or association. Type of 1st arg is: "
+ .TS
+ " and that of 2d arg is: "
+ .TFF))>>)>
+ <PUT .NOD ,NODE-TYPE ,IPUT-CODE>)>)>
+ <PUT-FLUSH <OR .TPS ALL>>
+ <TYPE-OK? <COND (.TS .TS) (ELSE ANY)> .RTYP>>>
+ <COND
+ (<==? <NODE-TYPE .NOD> ,PUT-CODE>
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>))
+ #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
+ <SET-CURRENT-TYPE
+ .SYM
+ <PUT-TYPE-HACK <GET-CURRENT-TYPE .SYM>
+ .TS
+ <LPR <REST .L 2>>
+ .WHICH
+ 0>>>
+ .SVWHO>)>
+ <COND (<AND <==? <NODE-TYPE .NOD> ,PUT-CODE>
+ <GASSIGNED? PUT-SAME-CODE>
+ <MEMQ .TPS '![LIST VECTOR UVECTOR TUPLE!]>
+ <MAPF <>
+ <FUNCTION (N)
+ <COND (<AND <G=? <LENGTH .N>
+ <INDEX ,SIDE-EFFECTS>>
+ <SIDE-EFFECTS .N>>
+ <MAPLEAVE <>>)
+ (ELSE T)>>
+ .K>
+ <MEMQ <NODE-TYPE <3 .K>> ,HACK-NODES>
+ <==? <ISTYPE? <RESULT-TYPE <3 .K>>> FIX>
+ <NOT <EMPTY? <SET TEM <KIDS <3 .K>>>>>
+ <NOT <OR <==? <NODE-SUBR <3 .K>> ,/>
+ <AND <==? <NODE-SUBR <3 .K>> ,->
+ <NOT <AND <==? <LENGTH .TEM> 2>
+ <==? <NODE-NAME <2 .TEM>> 1>>>>>>
+ <MAPR <>
+ <FUNCTION (L "AUX" (N <1 .L>))
+ <COND (<AND <==? <NODE-TYPE .N> ,NTH-CODE>
+ <SAME-OBJ <1 .K> <1 <KIDS .N>>>
+ <SAME-OBJ <2 .K> <2 <KIDS .N>>>>
+ <COND (<NOT <EMPTY? .P>>
+ <PUTREST .P <REST .L>>
+ <SET TEM (.N !.TEM)>)>
+ <MAPLEAVE>)>
+ <SET P .L>
+ <>>
+ .TEM>>
+ <PUT <3 .K> ,KIDS .TEM>
+ <PUT .NOD ,NODE-TYPE ,PUT-SAME-CODE>)>
+ .VAL>
+
+<DEFINE PUT-TYPE-HACK (TY TS L WHICH EX)
+ #DECL ((L) <LIST [REST FIX ATOM]>)
+ <COND (<EMPTY? .L> .TS)
+ (<AND <EMPTY? <REST .L 2>> <==? <2 .L> REST>>
+ <GET-ELE-TYPE
+ .TY
+ <+ <1 .L> .WHICH>
+ <>
+ <PUT-TYPE-HACK <GET-ELE-TYPE .TS .WHICH>
+ .TS
+ <REST .L 2>
+ .WHICH
+ 0>>)
+ (<==? <2 .L> REST>
+ <PUT-TYPE-HACK .TY .TS <REST .L 2> .WHICH <1 .L>>)
+ (ELSE
+ <GET-ELE-TYPE
+ .TY
+ <+ <1 .L> .EX>
+ <>
+ <PUT-TYPE-HACK <GET-ELE-TYPE .TY <+ <1 .L> .EX>>
+ .TS
+ <REST .L 2>
+ .WHICH
+ 0>>)>>
+
+<DEFINE LPR (L)
+ #DECL ((L) LIST)
+ <COND (<EMPTY? .L> .L) (ELSE (!<LPR <REST .L>> <1 .L>))>>
+
+<SETG HACK-NODES ![,ABS-CODE ,ARITH-CODE!]>
+
+<PUT ,PUT ANALYSIS ,PUT-ANA>
+
+<PUT ,PUTPROP ANALYSIS ,PUT-ANA>
+
+<DEFINE SAME-OBJ (N1 N2)
+ #DECL ((N1 N2) NODE)
+ <COND (<==? <NODE-TYPE .N1> <NODE-TYPE .N2>>
+ <COND (<MEMQ <NODE-TYPE .N1> ,SNODES>
+ <==? <NODE-NAME .N1> <NODE-NAME .N2>>)
+ (ELSE
+ <MAPF <>
+ <FUNCTION (N3 N4)
+ <COND (<SAME-OBJ .N3 .N4>)
+ (ELSE <MAPLEAVE <>>)>>
+ <KIDS .N1>
+ <KIDS .N2>>)>)>>
+
+<DEFINE DECL-DOWN ("TUPLE" TUP "AUX" (ND <1 .TUP>) (LN <- <LENGTH .TUP> 1>))
+ #DECL ((TUP) TUPLE (LN) FIX)
+ <REPEAT ()
+ <COND (<L? .LN 2> <RETURN .ND>)
+ (ELSE
+ <SET ND
+ <GET-ELE-TYPE
+ .ND
+ <NTH .TUP <+ .LN 1>>
+ <==? <NTH .TUP .LN> REST>>>)>
+ <SET LN <- .LN 2>>>>
+
+<DEFINE DECL-UP (NX L)
+ #DECL ((L) LIST)
+ <REPEAT ((FIRST T) (NUM 0))
+ #DECL ((NUM) FIX (L) LIST)
+ <COND (<EMPTY? .L> <RETURN .NX>)>
+ <COND (<==? <1 .L> NTH>
+ <SET NX
+ <FORM STRUCTURED
+ !<COND (<0? <SET NUM <+ .NUM <2 .L> -1>>> ())
+ (<1? .NUM> (ANY))
+ (ELSE ([.NUM ANY]))>
+ .NX>>
+ <SET NUM 0>
+ <SET FIRST <>>)
+ (.FIRST <SET NX <REST-DECL .NX <2 .L>>>)
+ (ELSE <SET NUM <+ .NUM <2 .L>>>)>
+ <SET L <REST .L 2>>>>
+
+<DEFINE PUTREST-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) T1 T2)
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
+ <COND (<==? <NODE-SUBR .NOD> ,REST> <REST-ANA .NOD .RTYP>)
+ (<SEGFLUSH .NOD .RTYP>
+ <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
+ <TYPE-OK? '<PRIMTYPE LIST> .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 PUTREST>
+ <SET T1 <EANA <1 .K> '<PRIMTYPE LIST> PUTREST>>
+ <SET T2 <EANA <2 .K> '<PRIMTYPE LIST> PUTREST>>
+ <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <MESSAGE ERROR " ATTEMPT TO MUNG QUOTED OBJECT " .NOD>)>
+ <PUT .NOD ,NODE-TYPE ,PUTR-CODE>
+ <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
+ <TYPE-OK? .T1 .RTYP>)>>
+
+<PUT ,PUTREST ANALYSIS ,PUTREST-ANA>
+
+<DEFINE MEMQ-ANA (N R "AUX" (K <KIDS .N>) TYP VTYP STYP ETY)
+ #DECL ((N) NODE (K) <LIST [REST NODE]>)
+ <COND
+ (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 MEMQ>
+ <SET VTYP <EANA <1 .K> ANY MEMQ>>
+ <SET TYP <EANA <2 .K> STRUCTURED MEMQ>>
+ <COND (<NOT <TYPE-OK? .VTYP <SET ETY <GET-ELE-TYPE .TYP ALL>>>>
+ <MESSAGE WARNING "MEMQ NEVER TRUE " .N>)>
+ <COND (<AND <SET STYP <STRUCTYP .TYP>> <N==? .STYP TEMPLATE>>
+ <PUT .N ,NODE-TYPE ,MEMQ-CODE>)
+ (ELSE
+ <COND (.VERBOSE <ADDVMESS .N ("Not open compiled because type is: "
+ .TYP)>)>
+ <PUT .N ,NODE-TYPE ,ISUBR-CODE>)>
+ <TYPE-OK? <TYPE-MERGE FALSE
+ <COND (<AND .ETY <N==? .ETY ANY>>
+ <FORM <COND (.STYP) (STRUCTURED)>
+ [REST .ETY]>)
+ (.STYP)
+ (STRUCTURED)>>
+ .R>)>>
+
+<PUT ,MEMQ ANALYSIS ,MEMQ-ANA>
+
+<ENDPACKAGE>
+
+\ 3\ 3
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff