1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: pxu/disassemble.sl - disassembler for i486 4% 5% Author: H. Melenk , ZIB Berlin 6% 7% Date : 4-May-1994 8% Status: Open Source: BSD License 9% 10% Redistribution and use in source and binary forms, with or without 11% modification, are permitted provided that the following conditions are met: 12% 13% * Redistributions of source code must retain the relevant copyright 14% notice, this list of conditions and the following disclaimer. 15% * Redistributions in binary form must reproduce the above copyright 16% notice, this list of conditions and the following disclaimer in the 17% documentation and/or other materials provided with the distribution. 18% 19% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 21% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 22% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 23% CONTRIBUTORS 24% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 27% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 28% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 29% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30% POSSIBILITY OF SUCH DAMAGE. 31% 32%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 33% Revisions: 34% 35 36(fluid '(bytes* lth* reg* regnr* segment* symvalhigh symfnchigh *curradr* *currinst*)) 37 38 (de getwrd(a)(getmem a)) 39 40 (de getfunctionaddress(fkt) 41 (wor 16#8000000 (wshift(wshift (cdr (getd fkt)) 5) -5))) 42 43 (de idnumberp(x) 44 (cond ((not (posintp x)) nil) 45 ((greaterp x (lshift maxsymbols 1)) nil) 46 ((stringp (symnam x)) x) 47 (t nil))) 48 49 (de safe!-int2id(x) 50 (setq x (wand 16#f7ffffff x)) 51 (if (idnumberp x) (mkid x) (mkid 32))) 52 53 (copyd 'ttab 'tab) 54 55 56(de word2addr (n) (times n 4)) 57(de addr2word (n) (quotient n 4)) 58(de jump2word (n) (quotient n 6)) 59 60 61(fluid '(eregs !*comment fktend !*hardjump instrs1 instrs2 instrs3 instrs*)) 62 63% establish instruction list at compile time 64 65(compiletime (progn 66 67(fluid '(instrs*)) 68 69(setq instrs1 nil) 70(setq instrs2 nil) 71(setq instrs3 nil) 72 73(dm fi(u) 74 (prog (name adr) 75 (pop u) 76 (setq adr (pop u)) 77 (setq name (pop u)) 78 (while u 79 (set instrs* (cons `(,adr ,name .,(pop u)) (eval instrs*))) 80 (setq adr (add1 adr))))) 81 82% fillin standard instructions 83 84(setq instrs* 'instrs1) 85 86(fi 16#00 add ((E b)(G b)) 87 ((E v)(G v)) 88 ((G b)(E b)) 89 ((G v)(E v)) 90 (AL (I b)) 91 (eAX (I v))) 92 93(fi 16#08 or ((E b)(G b)) 94 ((E v)(G v)) 95 ((G b)(E b)) 96 ((G v)(E v)) 97 (AL (I b)) 98 (eAX (I v))) 99 100(fi 16#10 adc ((E b)(G b)) 101 ((E v)(G v)) 102 ((G b)(E b)) 103 ((G v)(E v)) 104 (AL (I b)) 105 (eAX (I v))) 106 107 108(fi 16#18 sbb ((E b)(G b)) 109 ((E v)(G v)) 110 ((G b)(E b)) 111 ((G v)(E v)) 112 (AL (I b)) 113 (eAX (I v))) 114 115(fi 16#20 and ((E b)(G b)) 116 ((E v)(G v)) 117 ((G b)(E b)) 118 ((G v)(E v)) 119 (AL (I b)) 120 (eAX (I v))) 121 122(fi 16#28 sub ((E b)(G b)) 123 ((E v)(G v)) 124 ((G b)(E b)) 125 ((G v)(E v)) 126 (AL (I b)) 127 (eAX (I v))) 128 129(fi 16#30 xor ((E b)(G b)) 130 ((E v)(G v)) 131 ((G b)(E b)) 132 ((G v)(E v)) 133 (AL (I b)) 134 (eAX (I v))) 135 136(fi 16#36 ss: (nil)) 137 138(fi 16#38 cmp ((E b)(G b)) 139 ((E v)(G v)) 140 ((G b)(E b)) 141 ((G v)(E v)) 142 (AL (I b)) 143 (eAX (I v))) 144 145 146(fi 16#40 inc (eax) (ecx) (edx) (ebx) (esp) (ebp) (esi) (edi)) 147 148(fi 16#48 dec (eax) (ecx) (edx) (ebx) (esp) (ebp) (esi) (edi)) 149 150(fi 16#50 push (eax) (ecx) (edx) (ebx) (esp) (ebp) (esi) (edi)) 151 152(fi 16#58 pop (eax) (ecx) (edx) (ebx) (esp) (ebp) (esi) (edi)) 153 154(fi 16#60 pusha nil) 155 156(fi 16#61 popa nil) 157 158(fi 16#68 push ((I v))) 159 160(fi 16#70 jo ((j b))) 161(fi 16#71 jno ((j b))) 162(fi 16#72 jb ((j b))) 163(fi 16#73 jnb ((j b))) 164(fi 16#74 jz ((j b))) 165(fi 16#75 jnz ((j b))) 166(fi 16#76 jbe ((j b))) 167(fi 16#77 jbne ((j b))) 168(fi 16#78 js ((j b))) 169(fi 16#79 jns ((j b))) 170(fi 16#7a jp ((j b))) 171(fi 16#7b jnp ((j b))) 172(fi 16#7c jl ((j b))) 173(fi 16#7d jnl ((j b))) 174(fi 16#7e jle ((j b))) 175(fi 16#7f jnle ((j b))) 176 177(fi 16#80 Grp1 ((E b)(I b)) ((E v)(I v)) nil ((E v)(I b))) % grp1 178 179(fi 16#86 xchg ((E b) (G b)) ((E v) (G v))) 180 181(fi 16#88 mov ((E b)(G b)) ((E v) (G v)) ((G b)(E b)) ((G v) (E v))) 182 183(fi 16#8d lea ((G v) (M))) 184 185(fi 16#90 nop (nil)) 186 187(fi 16#91 xchg (ecx eax)(edx eax)(ebx eax)(esp eax)(ebp eax)(esi eax)(edi eax)) 188 189(fi 16#9a call (A p)) 190 191(fi 16#a0 mov (AL (O b)) (eax (O v)) ((O b) AL) ((O v) EAX)) 192 193(fi 16#b0 mov (AL (I b))(CL (I b))(DL (I b))(BL (I b)) 194 (AH (I b))(CH (I b))(DH (I b))(BH (I b))) 195 196(fi 16#b8 mov (EAX (I v))(ECX (I v))(EDX (I v))(EBX (I v)) 197 (ESP (I v))(EBP (I v))(ESI (I v))(EDI (I v))) 198 199(fi 16#c0 shift ((E b)(I b)) ((E v)(I b))) 200 201(fi 16#c3 ret (nil)) 202 203(fi 16#c6 mov ((E b)(I b)) ((E v)(I v))) 204 205(fi 16#d0 shift ((E b) 1) ((E v) 1) ((E b) CL) ((E v) CL)) 206 207(fi 16#e8 call ((A v))) 208 209(fi 16#e9 jmp ((J v)) ((A p)) ((J b))) 210 211(fi 16#f6 Grp3 ((E b)) ((E v))) 212 213(fi 16#ff Grp5 ((E v))) % grp5 214 215% second group 216 217(setq instrs* 'instrs2) 218 219(fi 16#80 JO ((j v))) 220(fi 16#81 JNO ((j v))) 221(fi 16#82 Jb ((j v))) 222(fi 16#83 Jnb ((j v))) 223(fi 16#84 Jz ((j v))) 224(fi 16#85 Jnz ((j v))) 225(fi 16#86 Jbe ((j v))) 226(fi 16#87 Jnbe((j v))) 227(fi 16#88 Js ((j v))) 228(fi 16#89 Jns ((j v))) 229(fi 16#8a Jp ((j v))) 230(fi 16#8b Jnp ((j v))) 231(fi 16#8c Jl ((j v))) 232(fi 16#8d Jnl ((j v))) 233(fi 16#8e Jle ((j v))) 234(fi 16#8f Jnle((j v))) 235 236 237(fi 16#af imul ((G v)(E v))) 238 239(dm make-the-instructions(u) 240 `(progn 241 (setq instrs1 ',instrs1) 242 (setq instrs2 ',instrs2) 243 (setq instrs3 ',instrs3) 244 )) 245 246)) 247 248(make-the-instructions) 249 250 251 252(setq eregs '("eax" "ecx" "edx" "ebx" "esp" "ebp" "esi" "edi")) 253 254(fluid '( the-instruction* addr*)) 255 256(de decode(p1 pl addr*) 257 (prog(i lth name) 258 (setq lth 1) 259 (setq i (assoc p1 instrs1)) 260 (when (eq p1 16#0f) 261 (setq p1 (pop pl)) 262 (setq lth 2) 263 (setq i (assoc p1 instrs2))) 264 (when (not i)(return (cons lth nil))) 265 (setq the-instruction* i) 266 (setq name (cadr i)) 267 (when (eq name 'ss:) (setq segment* "ss")) 268 (setq i (decode-operands pl lth (cddr i))) 269 (return `(,(car i) % lth 270 ,name 271 .,(cdr i))))) 272 273(de decode-operands(bytes* lth* pat) 274 (prog (r reg*) 275 (when (eqcar pat nil) (go done)) 276 (push (cons 'op1 (decode-operand1 (pop pat))) r) 277 (when pat 278 (push (cons 'op2 (decode-operand1 (pop pat))) r)) 279 done 280 (setq r (subst reg* 'reg r)) 281 (return (cons lth* r)))) 282 283(de decode-operand1(p) 284 (let(w) 285 (cond ((atom p) p) 286 ((eq (car p) 'G) 'reg) 287 % immediate byte 288 ((equal p '(I b)) 289 (setq lth* (add1 lth*)) 290 (pop bytes*)) 291 % immediate word 292 ((equal p '(I v)) 293 (setq lth* (plus 4 lth*)) 294 (bytes2word)) 295 % absolute address 296 ((equal p '(A b)) 297 (setq lth* (add1 lth*)) 298 (pop bytes*)) 299 ((equal p '(A v)) 300 (setq lth* (plus 4 lth*)) 301 (bytes2word)) 302 % displacement (relative jump) 303 ((equal p '(J b)) 304 (setq lth* (add1 lth*)) 305 (setq w (pop bytes*)) 306 (when (greaterp w 127)(setq w (difference w 256))) 307 (plus addr* w 2)) 308 ((equal p '(J v)) 309 (setq lth* (plus 4 lth*)) 310 (plus addr* (bytes2word) 5)) 311 % mod R/M 312 ((eqcar p 'E) (decode-modrm p)) 313 ((eqcar p 'R) (decode-modrm p)) 314 ((eqcar p 'M) (decode-modrm p)) 315 % offset 316 ((equal p '(o b)) 317 (setq lth!* (plus lth!* 1)) 318 (pop bytes!*)) 319 320 ((equal p '(o v)) 321 (setq lth!* (plus lth!* 4)) 322 (bytes2word)) 323 324 (t (terpri) 325 (prin2t (list "dont know operand declaration:" p)) 326 (stderror "disassemble"))))) 327 328(de decode-modrm(p) 329 (prog(mod rm b w) 330 (setq b (pop bytes*)) (setq lth* (add1 lth*)) 331 (setq mod (wshift b -6)) 332 (setq regnr* (wand 7 (wshift b -3))) (setq reg* (reg-m regnr*)) 333 (setq rm (wand 7 b)) 334 %(terpri)(prin2t(list "modrm" b mod regnr* rm)) (print bytes*) 335 (return 336 (cond ((and (lessp mod 3)(eq rm 2#100)) 337 (decode-sib p mod)) 338 ((and (eq mod 0)(eq rm 5)) 339 % probably a sym*** reference 340 (setq lth* (plus 4 lth*)) 341 (setq w (bytes2word)) 342 (cond ((and (xgreaterp w symfnc) 343 (xgreaterp symfnchigh w)) 344 (setq *comment 345 (bldmsg " -> %w" 346 (safe-int2id (wshift (wdifference (int2sys w) symfnc) -2))))) 347 ((and (xgreaterp w symval) 348 (xgreaterp symvalhigh w)) 349 (setq *comment 350 (bldmsg " -> %w" 351 (safe-int2id (wshift (wdifference (int2sys w) symval) -2)))))) 352 (bldmsg "*%w" w)) 353 ((eq mod 0) (bldmsg "[%w]" (reg-m rm))) 354 ((eq mod 1) 355 (setq lth* (add1 lth*)) 356 (let ((b (pop bytes*))) 357 % b is unsigned, convert to signed byte 358 (if (greaterp b 127) 359 (setq b (wdifference b 256))) 360 (bldmsg "[%w%w%w]" (reg-m rm) (if (wlessp b 0) "" "+") b))) 361 ((eq mod 2) 362 (setq lth* (plus 4 lth*)) 363 (setq w (bytes2word)) 364 (cond ((equal w 16#C0000000) (setq *comment " -> car")) 365 ((equal w 16#C0000004) (setq *comment " -> cdr"))) 366 (bldmsg "[%w+%x]" (reg-m rm) (int2sys w))) 367 ((eq mod 3) (bldmsg "%w" (reg-m rm)))) ))) 368 369(de decode-sib(p mod) 370 (prog(ss index base offset seg b w) 371 (setq b (pop bytes*)) 372 (setq lth* (add1 lth*)) 373 (setq ss (wshift b -6)) 374 (setq index (wand 7 (wshift b -3))) 375 (setq index "") % erstmal 376 (setq base (wand 7 b)) 377 (setq offset "") 378 (when (eq mod 1) 379 (setq offset (bldmsg "+%w" (pop bytes*))) 380 (setq lth* (add1 lth*))) 381 (when (eq mod 2) 382 (setq w (bytes2word)) 383 (setq offset (bldmsg "+%w" w)) 384 (setq lth* (plus lth* 4))) 385 (when (and (eq mod 0)(eq base 2#101)) 386 (setq lth* (plus lth* 4)) 387 (return (bldmsg "[%w%w]" (bytes2word) index))) 388 (setq seg 389 (cond (segment* segment*) 390 ((or (eq base 2#100)(eq base 2#101)) "") 391 (t "ss"))) 392 (setq segment* nil) 393 (return (bldmsg "%w[%w%w%w]" seg (reg-m base) index offset)))) 394 395 396(de reg-m(n) 397 (cond ((eq n 0) 'eax) 398 ((eq n 1) 'ecx) 399 ((eq n 2) 'edx) 400 ((eq n 3) 'ebx) 401 ((eq n 4) 'esp) 402 ((eq n 5) 'ebp) 403 ((eq n 6) 'esi) 404 ((eq n 7) 'edi))) 405 406(de bytes2word() 407 (prog(w) 408 (when (lessp (length bytes*) 4) 409 (stderror (bldmsg "operands %w too short at %w: %w" 410 bytes* *curradr* *currinst*))) 411 (setq w 412 (wplus2 (pop bytes*) 413 (wplus2 (wshift (pop bytes*) 8) 414 (wplus2 (wshift (pop bytes*) 16) 415 (wshift (pop bytes*) 24))))) 416 (when (idp w) 417 (setq *comment (bldmsg "'%w" w)) 418 (return w)) 419 (when (stringp w) 420 (setq *comment (bldmsg """%w""" w)) 421 (return 'string)) 422% (when (eq (wand w 16#ffffff) 0) (return 'CAR)) 423% (when (eq (wand w 16#ffffff) 4) (return 'CDR)) 424 (return (sys2int w)))) 425 426(de xgreaterp(a b)(and (numberp a)(numberp b)(greaterp a b))) 427 428(de namegrp1() 429 (cond ((eq regnr* 000) 'add) 430 ((eq regnr* 2#001) 'or) 431 ((eq regnr* 2#010) 'adc) 432 ((eq regnr* 2#011) 'sbb) 433 ((eq regnr* 2#100) 'and) 434 ((eq regnr* 2#101) 'sub) 435 ((eq regnr* 2#110) 'xor) 436 ((eq regnr* 2#111) 'cmp))) 437 438(de namegrp5() 439 (cond 440 ((eq regnr* 2#010) 'call) 441 ((eq regnr* 2#100) 'jump) 442 )) 443 444(de namegrp3() 445 (cond ((eq regnr* 000) 'test) 446 ((eq regnr* 2#010) 'not) 447 ((eq regnr* 2#011) 'neg) 448 ((eq regnr* 2#100) 'mul) 449 ((eq regnr* 2#101) 'imul) 450 ((eq regnr* 2#110) 'div) 451 ((eq regnr* 2#111) 'idiv) 452 )) 453 454(de nameshift() 455 (cond 456 ((eq regnr* 4) 'shl) 457 ((eq regnr* 7) 'sar) 458 ((eq regnr* 5) 'shr))) 459 460 461 462(de disassemble (fkt) 463 (prog(base instr jk jk77 p1 pp lth pat x 464 mem jmem symvalhigh symfnchigh frame 465 argumentblockhigh labels label bstart bend breg com4 memp1 466 !*lower lc name) 467 (setq !*lower t) 468 469 (cond ((numberp fkt) (setq base fkt)) 470 ((pairp fkt) (setq base (car fkt)) 471 (setq bend (cadr fkt)) 472 (plus2 base bend)) %do an arithmetic test 473 ((idp fkt) 474 (when (not (getd fkt)) (error 99 "not compiled")) 475 (when (not (codep (cdr (getd fkt))))(return nil)) 476 (setq base (sys2int (getfunctionaddress fkt))) 477 ) ) 478 (when (greaterp base (sys2int nextbps)) (return (error 99 "out of range"))) 479 (setq argumentblockhigh (plus2 argumentblock (word2addr 15))) 480 (setq symvalhigh (plus2 (sys2int symval) (word2addr maxsymbols))) 481 (setq symfnchigh (plus2 (sys2int symfnc) (word2addr maxsymbols))) 482 (terpri) 483 % (putmem nextbps 0) % safe endcondition 484 (setq bstart base) 485 (setq fktend nil) 486(go erstmal) % erstmal nur ein lauf 487 % first pass: find label references 488loop1 489 (setq p1 (getwrd (int2sys base))) 490 (setq !*hardjump nil) 491 (when (eq p1 0)(go continue1)) 492 (setq lth (atsoc 'LTH instr)) 493 (setq lth (if lth (cdr lth) 2)) 494 (setq jmem (atsoc 'addr instr)) 495 (when jmem (setq jmem (cdr jmem))) 496 (cond ((not (assoc jmem labels)) 497 (setq labels (cons (list jmem) labels)) )) 498 next (setq base (plus2 base lth)) 499 (when (and !*hardjump fktend (greaterp base fktend)) 500 (go continue1)) 501 (cond ((not bend ) (go loop1)) 502 ((greaterp base bend) (go continue1)) 503 (t (go loop1))) 504 continue1 505 % second pass: assign symbolic labels to jump targets 506 (when (not bend) (setq bend base)) 507 (setq labels (labelsort (delete '(nil) labels))) 508 (mapcar labels 509 (function 510 (lambda(x) 511 (cond 512 ((and % test within-range 513 (geq (car x) bstart) 514 (leq (car x) bend) 515 )(rplacd x (gensym)) ) 516 (t (rplaca x nil)) 517 ) ) ) ) 518 % third pass: print instructions 519erstmal 520 (setq base bstart) 521 (prinblx (list "function: " fkt " base: " base)) 522 (terpri) 523 (setq lc 0) 524loop 525 (cond ((assoc base labels) 526 (ttab 22) (prin2 (cdr (assoc base labels))) 527 (setq lc (add1 lc)) 528 (prin2t ":"))) 529 (setq p1 (wand 255 (byte(int2sys base) 0))) 530 (cond((eq p1 0)(return nil))) 531 532 (setq pp 533 (list (wand 255 (byte (int2sys base) 1)) 534 (wand 255 (byte (int2sys base) 2)) 535 (wand 255 (byte (int2sys base) 3)) 536 (wand 255 (byte (int2sys base) 4)) 537 (wand 255 (byte (int2sys base) 5)) 538 (wand 255 (byte (int2sys base) 6)) 539 (wand 255 (byte (int2sys base) 7)) 540 (wand 255 (byte (int2sys base) 8)) 541 (wand 255 (byte (int2sys base) 9)) 542 )) 543 (setq *curradr* base *currinst* pp) 544 (setq !*comment nil) 545 (setq instr (decode p1 pp base)) % instruction 546 (setq lth (pop instr)) 547 (setq name (when instr (pop instr))) 548 549 (when (eq name 'grp1) (setq name (namegrp1))) 550 (when (eq name 'grp5) (setq name (namegrp5))) 551 (when (eq name 'grp3) (setq name (namegrp3))) 552 (when (eq name 'shift)(setq name ( nameshift))) 553 554 (cond ((atsoc 'op2 instr) 555 (setq pat (list (cdr (atsoc 'op1 instr)) "," 556 (cdr (atsoc 'op2 instr)) ))) 557 ((atsoc 'op1 instr) 558 (setq pat (list (cdr (atsoc 'op1 instr))))) 559 (t (setq pat nil))) 560 561 (setq mem (atsoc 'addr instr)) (when mem (setq mem (cdr mem))) 562 (setq jmem (assoc mem labels)) (when jmem(setq jmem (cdr jmem))) 563 % (when jmem (setq pat (subst (cdr jmem) mem pat))) 564 (when jmem (setq pat (subst jmem mem pat)) 565 (setq instr (cons (cons '!<effa!> jmem) instr))) 566 567 (ttab 1) 568 (prinbnx base 8) 569 (prin2 " ") 570 (prinbnx p1 2) % binary first parcel 571 (when (greaterp lth 1) (prin2 " ") (prinbnx (pop pp) 2)) 572 (when (greaterp lth 2) (prin2 " ") (prinbnx (pop pp) 2)) 573 (when (greaterp lth 3) (prin2 " ") (prinbnx (pop pp) 2)) 574 (when (greaterp lth 4) (prin2 " ") (prinbnx (pop pp) 2)) 575 (when (greaterp lth 5) (prin2 " ") (prinbnx (pop pp) 2)) 576 (ttab 30) 577 (when name (prin2 name)) 578 (ttab 38) 579 (prinblx (subla instr pat)) 580 (prin2 " ") 581 582 (when *comment (ttab 60) (prin2 *comment)) 583 (setq *comment nil) 584 (setq base (plus2 base lth)) 585 (setq lc (add1 lc)) 586 (when (or (not (numberp bend)) (leq base bend))(go loop)) 587) ) 588 589 590(de prinbl (l) % binary (octal) printing of a list 591 (if (atom l)(prinb l) 592 (mapc l (function prinbl)))) 593 594(de prinblx (l) % binary (hexa) printing of a list 595 (if (atom l)(prinbx l) 596 (mapc l (function prinblx)))) 597 598 599 600(de prinb (it) % binary (octal) printing of an item 601 (cond ((numberp it)(prinbo it)) 602 ((eq it 't1) (ttab 42)) 603 ((eq it 't2) (ttab 60)) 604 (t (prin2 it)))) 605 606(de prinbx (it) % binary (hexa) printing of an item 607 (cond ((numberp it)(prinbox it)) 608 ((eq it 't1) (ttab 42)) 609 ((eq it 't2) (ttab 60)) 610 (t (prin2 it)))) 611 612 613(de prinbo (it) 614 (cond ((lessp it 0) (prin2 "-") (prinbo (minus it))) 615 ((geq it 8) (prin2 "O'") (prinbn it 1)) 616 (t (prinbn it 1)))) 617 618(de prinbox (it) 619 (cond ((lessp it 0) (prin2 "-") (prinbox (minus it))) 620 ((geq it 9) (prin2 "0x") (prinbnx it 1) ) 621 (t (prinbnx it 1)))) 622 623(de prinbn (it n) % print an octal number 624 (cond ((and (eq it 0) (leq n 0)) nil) 625 (t (progn 626 (prinbn (lshift it -3) (plus2 n -1)) 627 (prindig (logand it 7)) 628) ) ) ) 629 630(de prinbnx (it n) % print a hexa number 631 (cond ((and (eq it 0) (leq n 0)) nil) 632 (t (progn 633 (prinbnx (quotient it 16) (plus2 n -1)) 634 (prindigx (logand it 15)) 635) ) ) ) 636 637 638 639(de prindig (dig) % print a numeric digit 640 (writeChar (plus2 dig 48))) 641 642(fluid '(hexadigits)) 643(setq hexadigits 644 '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "a" "b" "c" "d" "e" "f")) 645(de prindigx (dig) (prin2 (nth hexadigits (add1 dig)))) 646 647(de labelsort (l) % sort labels to ascending sequence 648 (labelsort1 l nil)) 649 650(de labelsort1 (rest sorted) 651 (cond ((null rest) sorted) 652 (t (labelsort1(cdr rest) (labelsortin (car rest) sorted))) )) 653 654(de labelsortin (object l) 655 (cond ((null l)(list object)) 656 ((greaterp (car object)(caar l)) 657 (cons (car l) (labelsortin object (cdr l))) ) 658 (t (cons object l)) )) 659 660 661