debug.l (11299B)
1 # 31jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 # Prompt 5 (when symbols 6 (de *Prompt 7 (unless (== (symbols) 'pico) (symbols)) ) ) 8 9 # Browsing 10 (de doc (Sym Browser) 11 (call (or Browser (sys "BROWSER") 'w3m) 12 (pack 13 "file:" 14 (and (= `(char '/) (char (path "@"))) "//") 15 (path "@doc/ref") 16 (if Sym 17 (let (L (chop Sym) C (car L)) 18 (and 19 (member C '("*" "+")) 20 (cadr L) 21 (setq C @) ) 22 (cond 23 ((>= "Z" C "A")) 24 ((>= "z" C "a") (setq C (uppc C))) 25 (T (setq C "_")) ) 26 (pack C ".html#" Sym) ) 27 ".html" ) ) ) ) 28 29 (de more ("M" "Fun") 30 (let *Dbg NIL 31 (if (pair "M") 32 ((default "Fun" print) (pop '"M")) 33 (println (type "M")) 34 (setq 35 "Fun" (list '(X) (list 'pp 'X (lit "M"))) 36 "M" (mapcar car (filter pair (val "M"))) ) ) 37 (loop 38 (flush) 39 (T (atom "M") (prinl)) 40 (T (line) T) 41 ("Fun" (pop '"M")) ) ) ) 42 43 (de what (S) 44 (let *Dbg NIL 45 (setq S (chop S)) 46 (filter 47 '(("X") (match S (chop "X"))) 48 (all) ) ) ) 49 50 51 (de who ("X" . "*Prg") 52 (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) 53 (make (mapc "who" (all))) ) ) 54 55 (de "who" ("Y") 56 (unless (or (ext? "Y") (memq "Y" "Who")) 57 (push '"Who" "Y") 58 (ifn (= `(char "+") (char "Y")) 59 (and (pair (val "Y")) ("nest" @) (link "Y")) 60 (for "Z" (pair (val "Y")) 61 (if (atom "Z") 62 (and ("match" "Z") (link "Y")) 63 (when ("nest" (cdr "Z")) 64 (link (cons (car "Z") "Y")) ) ) ) 65 (maps 66 '(("Z") 67 (if (atom "Z") 68 (and ("match" "Z") (link "Y")) 69 (when ("nest" (car "Z")) 70 (link (cons (cdr "Z") "Y")) ) ) ) 71 "Y" ) ) ) ) 72 73 (de "nest" ("Y") 74 ("nst1" "Y") 75 ("nst2" "Y") ) 76 77 (de "nst1" ("Y") 78 (let "Z" (setq "Y" (strip "Y")) 79 (loop 80 (T (atom "Y") (and (sym? "Y") ("who" "Y"))) 81 (and (sym? (car "Y")) ("who" (car "Y"))) 82 (and (pair (car "Y")) ("nst1" @)) 83 (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) 84 85 (de "nst2" ("Y") 86 (let "Z" (setq "Y" (strip "Y")) 87 (loop 88 (T (atom "Y") ("match" "Y")) 89 (T (or ("match" (car "Y")) ("nst2" (car "Y"))) 90 T ) 91 (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) 92 93 (de "match" ("D") 94 (and 95 (cond 96 ((str? "X") (and (str? "D") (= "X" "D"))) 97 ((sym? "X") (== "X" "D")) 98 (T (match "X" "D")) ) 99 (or 100 (not "*Prg") 101 (let *Dbg (up 2 *Dbg) (run "*Prg")) ) ) ) 102 103 104 (de can (X) 105 (let *Dbg NIL 106 (extract 107 '(("Y") 108 (and 109 (= `(char "+") (char "Y")) 110 (asoq X (val "Y")) 111 (cons X "Y") ) ) 112 (all) ) ) ) 113 114 # Class dependencies 115 (de dep ("C") 116 (let *Dbg NIL 117 (dep1 0 "C") 118 (dep2 3 "C") 119 "C" ) ) 120 121 (de dep1 (N "C") 122 (for "X" (type "C") 123 (dep1 (+ 3 N) "X") ) 124 (space N) 125 (println "C") ) 126 127 (de dep2 (N "C") 128 (for "X" (all) 129 (when 130 (and 131 (= `(char "+") (char "X")) 132 (memq "C" (type "X")) ) 133 (space N) 134 (println "X") 135 (dep2 (+ 3 N) "X") ) ) ) 136 137 # Inherited methods 138 (de methods (Obj) 139 (make 140 (let Mark NIL 141 (recur (Obj) 142 (for X (val Obj) 143 (nond 144 ((pair X) (recurse X)) 145 ((memq (car X) Mark) 146 (link (cons (car X) Obj)) 147 (push 'Mark (car X)) ) ) ) ) ) ) ) 148 149 # Source code 150 (off "*Ed") 151 152 (in "@lib/map" 153 (while (read) 154 (let Sym @ 155 (if (get Sym '*Dbg) 156 (set @ (read)) 157 (put Sym '*Dbg (cons (read))) ) ) ) ) 158 159 (de _ed ("Ed" . "Prg") 160 (ifn "X" 161 (eval 162 (out (pil "editor") 163 (println (cons 'load "Ed")) ) ) 164 (when (pair "X") 165 (setq C (cdr "X") "X" (car "X")) ) 166 (when 167 (setq "*Ed" 168 (if C 169 (get C '*Dbg -1 "X") 170 (get "X" '*Dbg 1) ) ) 171 (out (tmp "tags") 172 (let D (pack (pwd) "/") 173 (for Lst 174 (group # (file (line . sym) (line . sym) ..) 175 (extract 176 '((This) 177 (when (: *Dbg) 178 (cons (path (cdar @)) (caar @) This) ) ) 179 (all) ) ) 180 (let Tags 181 (in (car Lst) 182 (let (Line 1 Ofs 0) 183 (mapcar 184 '((X) 185 (do (- (car X) Line) 186 (inc 'Ofs (inc (size (line T)))) ) 187 (pack 188 `(pack "^J" (char 127)) 189 (cdr X) 190 (char 1) 191 (setq Line (car X)) 192 "," 193 Ofs ) ) 194 (sort (cdr Lst)) ) ) ) 195 (prinl 196 "^L^J" 197 (unless (= `(char "/") (char (car Lst))) D) 198 (car Lst) 199 "," 200 (sum size Tags) 201 Tags ) ) ) ) ) 202 (run "Prg") ) ) 203 "X" ) 204 205 (de vi ("X" C) 206 (_ed 207 '("@lib/led.l" "@lib/edit.l") 208 (call "vim" 209 (pack "+set tags=" (tmp "tags") ",./tags") 210 "+set isk=33-34,36-38,42-90,92,94-95,97-125" 211 (pack "+" (car "*Ed")) 212 (path (cdr "*Ed")) ) ) ) 213 214 # Emacs interface (Thorsten Jolitz) 215 # Note: 216 # As 'tags-table-list' is set here, do not also set `tags-file-name' 217 # make sure, tsm.el and picolisp.el are loaded (in that order) and put 218 # the edited .l file in picolisp mode (M-x picolisp-mode) 219 (de em ("X" C) 220 (_ed 221 '("@lib/eled.l" "@lib/eedit.l") 222 (call "emacsclient" 223 "-a" NIL 224 "-e" 225 (pack 226 "(let ((tmp-tags \"" (tmp "tags") "\")" 227 "(src-tags (expand-file-name \"" (path "@src64/tags") 228 "\")))" 229 "(setq tags-table-list " 230 "(append `(,tmp-tags) `(,src-tags) tags-table-list))" 231 "(mapc (lambda (F)" 232 "(unless (file-exists-p (expand-file-name F))" 233 "(setq tags-table-list (delete F tags-table-list))))" 234 "tags-table-list)" 235 "(delete-dups tags-table-list)" 236 "(setq tags-table-list (delete \"\" tags-table-list))" 237 "(setq tags-file-name nil)" 238 " )" ) ) 239 (call "emacsclient" 240 "-c" 241 (pack "+" (car "*Ed")) 242 (path (cdr "*Ed")) ) ) ) 243 244 (de ld () 245 (and "*Ed" (load (cdr "*Ed"))) ) 246 247 # Single-Stepping 248 (de _dbg (Lst) 249 (or 250 (atom (car Lst)) 251 (num? (caar Lst)) 252 (flg? (caar Lst)) 253 (== '! (caar Lst)) 254 (set Lst (cons '! (car Lst))) ) ) 255 256 (de _dbg2 (Lst) 257 (map 258 '((L) 259 (if (and (pair (car L)) (flg? (caar L))) 260 (map _dbg (cdar L)) 261 (_dbg L) ) ) 262 Lst ) ) 263 264 (de dbg (Lst) 265 (when (pair Lst) 266 (casq (pop 'Lst) 267 ((case casq state) 268 (_dbg Lst) 269 (for L (cdr Lst) 270 (map _dbg (cdr L)) ) ) 271 ((cond nond) 272 (for L Lst 273 (map _dbg L) ) ) 274 (quote 275 (when (fun? Lst) 276 (map _dbg (cdr Lst)) ) ) 277 ((job use let let? recur) 278 (map _dbg (cdr Lst)) ) 279 (loop 280 (_dbg2 Lst) ) 281 ((bind do) 282 (_dbg Lst) 283 (_dbg2 (cdr Lst)) ) 284 (for 285 (and (pair (car Lst)) (map _dbg (cdar Lst))) 286 (_dbg2 (cdr Lst)) ) 287 (T (map _dbg Lst)) ) 288 T ) ) 289 290 (de d () (let *Dbg NIL (dbg ^))) 291 292 (de debug ("X" C) 293 (ifn (traced? "X" C) 294 (let *Dbg NIL 295 (when (pair "X") 296 (setq C (cdr "X") "X" (car "X")) ) 297 (or 298 (dbg (if C (method "X" C) (getd "X"))) 299 (quit "Can't debug" "X") ) ) 300 (untrace "X" C) 301 (debug "X" C) 302 (trace "X" C) ) ) 303 304 (de ubg (Lst) 305 (when (pair Lst) 306 (map 307 '((L) 308 (when (pair (car L)) 309 (when (== '! (caar L)) 310 (set L (cdar L)) ) 311 (ubg (car L)) ) ) 312 Lst ) 313 T ) ) 314 315 (de u () (let *Dbg NIL (ubg ^))) 316 317 (de unbug ("X" C) 318 (let *Dbg NIL 319 (when (pair "X") 320 (setq C (cdr "X") "X" (car "X")) ) 321 (or 322 (ubg (if C (method "X" C) (getd "X"))) 323 (quit "Can't unbug" "X") ) ) ) 324 325 # Tracing 326 (de traced? ("X" C) 327 (setq "X" 328 (if C 329 (method "X" C) 330 (getd "X") ) ) 331 (and 332 (pair "X") 333 (pair (cadr "X")) 334 (== '$ (caadr "X")) ) ) 335 336 # Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B)) 337 (de trace ("X" C) 338 (let *Dbg NIL 339 (when (pair "X") 340 (setq C (cdr "X") "X" (car "X")) ) 341 (if C 342 (unless (traced? "X" C) 343 (or (method "X" C) (quit "Can't trace" "X")) 344 (con @ 345 (cons 346 (conc 347 (list '$ (cons "X" C) (car @)) 348 (cdr @) ) ) ) ) 349 (unless (traced? "X") 350 (and (sym? (getd "X")) (quit "Can't trace" "X")) 351 (and (num? (getd "X")) (expr "X")) 352 (set "X" 353 (list 354 (car (getd "X")) 355 (conc (list '$ "X") (getd "X")) ) ) ) ) 356 "X" ) ) 357 358 # Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B) 359 (de untrace ("X" C) 360 (let *Dbg NIL 361 (when (pair "X") 362 (setq C (cdr "X") "X" (car "X")) ) 363 (if C 364 (when (traced? "X" C) 365 (con 366 (method "X" C) 367 (cdddr (cadr (method "X" C))) ) ) 368 (when (traced? "X") 369 (let X (set "X" (cddr (cadr (getd "X")))) 370 (and 371 (== '@ (pop 'X)) 372 (= 1 (length X)) 373 (= 2 (length (car X))) 374 (== 'pass (caar X)) 375 (sym? (cdadr X)) 376 (subr "X") ) ) ) ) 377 "X" ) ) 378 379 (de *NoTrace 380 @ @@ @@@ 381 pp show more led 382 what who can dep d e debug u unbug trace untrace ) 383 384 (de traceAll (Excl) 385 (let *Dbg NIL 386 (for "X" (all) 387 (or 388 (memq "X" Excl) 389 (memq "X" *NoTrace) 390 (= `(char "*") (char "X")) 391 (cond 392 ((= `(char "+") (char "X")) 393 (mapc trace 394 (extract 395 '(("Y") 396 (and 397 (pair "Y") 398 (fun? (cdr "Y")) 399 (cons (car "Y") "X") ) ) 400 (val "X") ) ) ) 401 ((pair (getd "X")) 402 (trace "X") ) ) ) ) ) ) 403 404 # Process Listing 405 (de proc @ 406 (apply call 407 (make (while (args) (link "-C" (next)))) 408 'ps "-H" "-o" "pid,ppid,start,size,pcpu,wchan,cmd" ) ) 409 410 # Benchmarking 411 (de bench Prg 412 (let U (usec) 413 (prog1 (run Prg 1) 414 (out 2 415 (prinl 416 (format (*/ (- (usec) U) 1000) 3) 417 " sec" ) ) ) ) ) 418 419 # vi:et:ts=3:sw=3