1 /* j/6/ut_burn.c 2 ** 3 */ 4 #include "all.h" 5 6 7 /* logic 8 */ 9 static u3_noun 10 _burn_in(u3_noun van, u3_noun sut, u3_noun gil); 11 12 static u3_noun _burn_fork(u3_noun van,u3_noun yed,u3_noun gil)13 _burn_fork(u3_noun van, 14 u3_noun yed, 15 u3_noun gil) 16 { 17 if ( u3_nul == yed ) { 18 return u3_nul; 19 } else { 20 u3_noun dis = _burn_in(van, u3h(yed), gil); 21 u3_noun mor = _burn_fork(van, u3t(yed), gil); 22 23 if ( u3_nul == dis ) return mor; 24 if ( u3_nul == mor ) return dis; 25 { 26 u3_noun u_dis = u3t(dis); 27 u3_noun u_mor = u3t(mor); 28 29 if ( u3du(u_dis) == u3du(u_mor) ) { 30 if ( c3y == u3qc_gor(u_mor, u_dis) ) { 31 u3z(dis); 32 return mor; 33 } else { 34 u3z(mor); 35 return dis; 36 } 37 } else { 38 if ( c3y == u3ud(u_dis) ) { 39 u3z(mor); 40 return dis; 41 } 42 else { 43 u3z(dis); 44 return mor; 45 } 46 } 47 } 48 } 49 } 50 51 static u3_noun _burn_in(u3_noun van,u3_noun sut,u3_noun gil)52 _burn_in(u3_noun van, 53 u3_noun sut, 54 u3_noun gil) 55 { 56 u3_noun p_sut, q_sut, pq_sut, qq_sut, rq_sut, sq_sut, psq_sut, qsq_sut; 57 58 if ( c3n == u3du(sut) ) switch ( sut ) { 59 default: return u3m_bail(c3__fail); 60 61 case c3__noun: return u3nc(u3_nul, 0); 62 case c3__void: { 63 return u3_nul; 64 } 65 } 66 else switch ( u3h(sut) ) { 67 default: return u3m_bail(c3__fail); 68 69 case c3__atom: u3x_cell(u3t(sut), &p_sut, &q_sut); 70 { 71 if ( c3y == u3du(q_sut) ) { 72 return u3nc(u3_nul, u3k(u3t(q_sut))); 73 } else { 74 return u3nc(u3_nul, 0); 75 } 76 } 77 case c3__cell: u3x_cell(u3t(sut), &p_sut, &q_sut); 78 { 79 u3_noun hed = _burn_in(van, p_sut, gil); 80 81 if ( u3_nul == hed ) { 82 return u3_nul; 83 } 84 else { 85 u3_noun tal = _burn_in(van, q_sut, gil); 86 87 if ( u3_nul == tal ) { 88 u3z(hed); 89 return u3_nul; 90 } 91 else { 92 u3_noun ret = u3nt(u3_nul, u3k(u3t(hed)), u3k(u3t(tal))); 93 94 u3z(hed); 95 u3z(tal); 96 return ret; 97 } 98 } 99 } 100 case c3__core: u3x_cell(u3t(sut), &p_sut, &q_sut); 101 u3x_qual(q_sut, &pq_sut, &qq_sut, &rq_sut, &sq_sut); 102 u3x_cell(sq_sut, &psq_sut, &qsq_sut); 103 { 104 u3_noun pay = _burn_in(van, p_sut, gil); 105 106 if ( u3_nul == pay ) { 107 return u3_nul; 108 } 109 else { 110 u3_noun ret = u3nt(u3_nul, u3k(psq_sut), u3k(u3t(pay))); 111 112 u3z(pay); 113 return ret; 114 } 115 } 116 case c3__help: 117 case c3__face: u3x_cell(u3t(sut), &p_sut, &q_sut); 118 { 119 return _burn_in(van, q_sut, gil); 120 } 121 case c3__fork: p_sut = u3t(sut); 122 { 123 u3_noun yed = u3qdi_tap(p_sut); 124 u3_noun ret = _burn_fork(van, yed, gil); 125 126 u3z(yed); 127 return ret; 128 } 129 case c3__hold: 130 { 131 if ( (c3y == u3qdi_has(gil, sut)) ) { 132 return u3_nul; 133 } 134 else { 135 u3_noun zoc = u3qdi_put(gil, sut); 136 u3_noun fop = u3qfu_repo(van, sut); 137 u3_noun pro = _burn_in(van, fop, zoc); 138 139 u3z(fop); 140 u3z(zoc); 141 142 return pro; 143 } 144 } 145 } 146 } 147 148 static u3_noun _cqfu_burn(u3_noun van,u3_noun sut)149 _cqfu_burn(u3_noun van, 150 u3_noun sut) 151 { 152 u3_noun unt = _burn_in(van, sut, u3_nul); 153 154 if ( u3_nul == unt ) { 155 return u3m_error("burn"); 156 } 157 else { 158 u3_noun ret = u3k(u3t(unt)); 159 160 u3z(unt); 161 return ret; 162 } 163 } 164 165 u3_noun u3qfu_burn(u3_noun van,u3_noun sut)166 u3qfu_burn(u3_noun van, 167 u3_noun sut) 168 { 169 c3_m fun_m = 144 + c3__burn + ((!!u3r_at(u3qfu_van_vet, van)) << 8); 170 u3_noun pro = u3z_find(fun_m, sut); 171 172 if ( u3_none != pro ) { 173 return pro; 174 } 175 else { 176 pro = _cqfu_burn(van, sut); 177 178 return u3z_save(fun_m, sut, pro); 179 } 180 } 181 182 u3_noun u3wfu_burn(u3_noun cor)183 u3wfu_burn(u3_noun cor) 184 { 185 u3_noun sut; 186 187 if ( u3_none == (sut = u3r_at(u3x_sam, cor)) ) { 188 return u3m_bail(c3__fail); 189 } else { 190 return u3qfu_burn(cor, sut); 191 } 192 } 193