debug.l (6999B)
1 # 26mar08abu 2 # (c) Software Lab. Alexander Burger 3 4 # Browsing 5 (de more ("M" "Foo") 6 (let *Dbg NIL 7 (default "Foo" print) 8 (if (pair "M") 9 ("Foo" (pop '"M")) 10 ("Foo" (type "M")) 11 (setq 12 "Foo" (list '(X) (list 'pp 'X (lit "M"))) 13 "M" (mapcar car (filter pair (val "M"))) ) ) 14 (loop 15 (T (atom "M") (prinl)) 16 (T (line) T) 17 ("Foo" (pop '"M")) ) ) ) 18 19 (de depth (Idx) 20 (if (atom Idx) 21 0 22 (inc 23 (max 24 (depth (cadr Idx)) 25 (depth (cddr Idx)) ) ) ) ) 26 27 (de what (S) 28 (let *Dbg NIL 29 (ifn S 30 (all) 31 (setq S (chop S)) 32 (filter 33 '(("X") (match S (chop "X"))) 34 (all) ) ) ) ) 35 36 37 (de who ("X" . "*Prg") 38 (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) 39 (make (mapc "who" (all))) ) ) 40 41 (de "who" ("Y") 42 (unless (memq "Y" "Who") 43 (push '"Who" "Y") 44 (ifn (= `(char "+") (char "Y")) 45 (and (pair (val "Y")) ("nest" @) (link "Y")) 46 (for "Z" (val "Y") 47 (if (atom "Z") 48 (and ("match" "Z") (link "Y")) 49 (when ("nest" (cdr "Z")) 50 (link (cons (car "Z") "Y")) ) ) ) 51 (maps 52 '(("Z") 53 (if (atom "Z") 54 (and ("match" "Z") (link "Y")) 55 (when ("nest" (car "Z")) 56 (link (cons (cdr "Z") "Y")) ) ) ) 57 "Y" ) ) ) ) 58 59 (de "nest" ("Y") 60 ("nst1" "Y") 61 ("nst2" "Y") ) 62 63 (de "nst1" ("Y") 64 (let "Z" (setq "Y" (strip "Y")) 65 (loop 66 (T (atom "Y") (and (sym? "Y") ("who" "Y"))) 67 (and (sym? (car "Y")) ("who" (car "Y"))) 68 (and (pair (car "Y")) ("nst1" @)) 69 (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) 70 71 (de "nst2" ("Y") 72 (let "Z" (setq "Y" (strip "Y")) 73 (loop 74 (T (atom "Y") ("match" "Y")) 75 (T (or ("match" (car "Y")) ("nst2" (car "Y"))) 76 T ) 77 (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) 78 79 (de "match" ("D") 80 (and 81 (cond 82 ((str? "X") (and (str? "D") (= "X" "D"))) 83 ((sym? "X") (== "X" "D")) 84 (T (match "X" "D")) ) 85 (or (not "*Prg") (run "*Prg")) ) ) 86 87 88 (de can (X) 89 (let *Dbg NIL 90 (mapcan 91 '(("Y") 92 (and 93 (= `(char "+") (char "Y")) 94 (asoq X (val "Y")) 95 (cons (cons X "Y")) ) ) 96 (all) ) ) ) 97 98 99 # Class dependencies 100 (de dep ("C") 101 (let *Dbg NIL 102 (dep1 0 "C") 103 (dep2 3 "C") 104 "C" ) ) 105 106 (de dep1 (N "C") 107 (for "X" (type "C") 108 (dep1 (+ 3 N) "X") ) 109 (space N) 110 (println "C") ) 111 112 (de dep2 (N "C") 113 (for "X" (all) 114 (when 115 (and 116 (= `(char "+") (char "X")) 117 (memq "C" (type "X")) ) 118 (space N) 119 (println "X") 120 (dep2 (+ 3 N) "X") ) ) ) 121 122 # Single-Stepping 123 (de _dbg (Lst) 124 (or 125 (atom (car Lst)) 126 (num? (caar Lst)) 127 (flg? (caar Lst)) 128 (== '! (caar Lst)) 129 (set Lst (cons '! (car Lst))) ) ) 130 131 (de _dbg2 (Lst) 132 (map 133 '((L) 134 (if (and (pair (car L)) (flg? (caar L))) 135 (map _dbg (cdar L)) 136 (_dbg L) ) ) 137 Lst ) ) 138 139 (de dbg (Lst) 140 (when (pair Lst) 141 (case (pop 'Lst) 142 (case 143 (_dbg Lst) 144 (for L (cdr Lst) 145 (map _dbg (cdr L)) ) ) 146 (state 147 (_dbg Lst) 148 (for L (cdr Lst) 149 (map _dbg (cddar L)) 150 (map _dbg (cdr L)) ) ) 151 ((cond nond) 152 (for L Lst 153 (map _dbg L) ) ) 154 (quote 155 (when (fun? Lst) 156 (map _dbg (cdr Lst)) ) ) 157 ((job use let let? recur) 158 (map _dbg (cdr Lst)) ) 159 (loop 160 (_dbg2 Lst) ) 161 ((bind do) 162 (_dbg Lst) 163 (_dbg2 (cdr Lst)) ) 164 (for 165 (and (pair (car Lst)) (map _dbg (cdar Lst))) 166 (_dbg2 (cdr Lst)) ) 167 (T (map _dbg Lst)) ) 168 T ) ) 169 170 (de d () (let *Dbg NIL (dbg ^))) 171 172 (de debug ("X" C) 173 (ifn (traced? "X" C) 174 (let *Dbg NIL 175 (when (pair "X") 176 (setq C (cdr "X") "X" (car "X")) ) 177 (or 178 (dbg (if C (method "X" C) (getd "X"))) 179 (quit "Can't debug" "X") ) ) 180 (untrace "X" C) 181 (debug "X" C) 182 (trace "X" C) ) ) 183 184 (de ubg (Lst) 185 (when (pair Lst) 186 (map 187 '((L) 188 (when (pair (car L)) 189 (when (== '! (caar L)) 190 (set L (cdar L)) ) 191 (ubg (car L)) ) ) 192 Lst ) 193 T ) ) 194 195 (de u () (let *Dbg NIL (ubg ^))) 196 197 (de unbug ("X" C) 198 (let *Dbg NIL 199 (when (pair "X") 200 (setq C (cdr "X") "X" (car "X")) ) 201 (or 202 (ubg (if C (method "X" C) (getd "X"))) 203 (quit "Can't unbug" "X") ) ) ) 204 205 # Tracing 206 (de traced? ("X" C) 207 (setq "X" 208 (if C 209 (method "X" C) 210 (getd "X") ) ) 211 (and 212 (pair "X") 213 (pair (cadr "X")) 214 (== '$ (caadr "X")) ) ) 215 216 # Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B)) 217 (de trace ("X" C) 218 (let *Dbg NIL 219 (when (pair "X") 220 (setq C (cdr "X") "X" (car "X")) ) 221 (if C 222 (unless (traced? "X" C) 223 (or (method "X" C) (quit "Can't trace" "X")) 224 (con @ 225 (cons 226 (conc 227 (list '$ (cons "X" C) (car @)) 228 (cdr @) ) ) ) ) 229 (unless (traced? "X") 230 (and (sym? (getd "X")) (quit "Can't trace" "X")) 231 (and (num? (getd "X")) (expr "X")) 232 (set "X" 233 (list 234 (car (getd "X")) 235 (conc (list '$ "X") (getd "X")) ) ) ) ) 236 "X" ) ) 237 238 # Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B) 239 (de untrace ("X" C) 240 (let *Dbg NIL 241 (when (pair "X") 242 (setq C (cdr "X") "X" (car "X")) ) 243 (if C 244 (when (traced? "X" C) 245 (con 246 (method "X" C) 247 (cdddr (cadr (method "X" C))) ) ) 248 (when (traced? "X") 249 (let X (set "X" (cddr (cadr (getd "X")))) 250 (and 251 (== '@ (pop 'X)) 252 (= 1 (length X)) 253 (= 2 (length (car X))) 254 (== 'pass (caar X)) 255 (sym? (cdadr X)) 256 (subr "X") ) ) ) ) 257 "X" ) ) 258 259 (de *NoTrace 260 @ @@ @@@ 261 pp show more led 262 what who can dep d e debug u unbug trace untrace ) 263 264 (de traceAll (Excl) 265 (let *Dbg NIL 266 (for "X" (all) 267 (or 268 (memq "X" Excl) 269 (memq "X" *NoTrace) 270 (= `(char "*") (char "X")) 271 (cond 272 ((= `(char "+") (char "X")) 273 (mapc trace 274 (mapcan 275 '(("Y") 276 (and 277 (pair "Y") 278 (fun? (cdr "Y")) 279 (list (cons (car "Y") "X")) ) ) 280 (val "X") ) ) ) 281 ((pair (getd "X")) 282 (trace "X") ) ) ) ) ) ) 283 284 # vi:et:ts=3:sw=3