1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: Helferlein.SL 4% Description: various useful access functions 5% Author: Herbert Melenk and Winfried Neun, ZIB Berlin 6% Created: 5 February 1989 (SUN4 version) 7% Status: Experimental (Do Not Distribute) 8% Mode: Lisp 9% Package: Utilities 10% 11% copyright (c) 1989 Konrad Zuse-Zentrum Berlin, all rights reserved 12%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13 14(compiletime (setq *syslisp t)) 15(compiletime (load inum if-system)) 16(compiletime (flag '(terminalwritechar c-p-s c-p-s-nl 17 helferle-prindig) 'internalfunction)) 18 19(de memo (x) (getmem x)) 20 21(de info (x) (inf x)) 22 23(de valo (x) (symval (inf x))) 24 25(de namo (x) (symnam (inf x))) 26 27(de fnco (x) (getmem (wplus2 symfnc (times2 addressingunitsperfunctioncell 28 (inf x))))) 29 30(de propo (x) (symprp (inf x))) 31 32(de hasho (x) (halfword hashtable x)) 33 34(de terminalwritechar (x y) (unixputc y)) 35 36(if_system SPARC 37 (progn 38 (de c-p-s (stri) 39 (when (eq 0 (wand stri 3)) (console-print-string stri) ) 40 (console-newline)) 41 42 (de c-p-s-nl (stri) 43 (when (eq 0 (wand stri 3)) (console-print-string stri) ))) 44 45 (progn 46 (de c-p-s (stri) 47 (console-print-string stri) (console-newline)) 48 49 (de c-p-s-nl (stri) 50 (console-print-string stri)))) 51 52(de printo (x) (puthex x 8) (terminalwritechar 32 32) 53 (terminalwritechar 32 32) 54 (terminalwritechar 32 32) 55 56 (case (tag x) 57 ((posint-tag negint-tag) 58 (progn (unixputn x) (console-newline))) 59 ((fixnum-tag) (c-p-s "<fixnum>")) 60 ((bignum-tag) (c-p-s "<bignum>")) 61 ((floatnum-tag) (c-p-s "<float>")) 62 ((bytes-tag) (c-p-s "<bytes>")) 63 ((halfwords-tag) (c-p-s "<halfwords>")) 64 ((words-tag) (c-p-s "<words>")) 65 ((vector-tag) (c-p-s "<vector>")) 66 ((pair-tag) (c-p-s "<pair>")) 67 ((evector-tag) (c-p-s "<evector>")) 68 ((code-tag) (c-p-s "<code>")) 69 ((unbound-tag) (c-p-s "<unbound>")) 70 ((btr-tag) (c-p-s "<backtrace>")) 71 ((forward-tag) (c-p-s "<forward>")) 72 ((hvect-tag) (c-p-s "<h vector>")) 73 ((hwords-tag) (c-p-s "<h words>")) 74 ((hhalfwords-tag)(c-p-s "<h halfwords>")) 75 ((hbytes-tag) (c-p-s "<h bytes>")) 76 ((id-tag)(if (and (wlessp (inf x) maxsymbols) 77 (stringp (symnam (inf x)))) 78 (c-p-s (symnam (inf x))) 79 (console-newline))) 80 ((string-tag)(if (and (wlessp (inf x) heapupperbound) 81 (wgeq (inf x) 82 (inf (cdr (getd 'firstkernel)))) 83 (eq 0 (wand 3 (inf x))) % No BUS 84 (wlessp (strlen (strinf x)) 100)) 85 (progn 86 (terminalwritechar 34 34) 87 (c-p-s-nl x) 88 (terminalwritechar 34 34) 89 (console-newline)) 90 (console-newline))) 91 (nil (console-newline)) 92 ) 93T ) 94 95(de dumpo (x n) 96 (prog (outputbase* addr) 97 (setq outputbase* 8) 98 (when (greaterp n 255) (setq n 255)) 99 (console-newline) 100 (printo x) (console-newline) 101 (setq x (wshift (wshift x -2) 2)) % avoid bus error 102 (ifor (from i 0 n 1) 103 (do (progn 104 (setq addr (wplus2 (inf x) (wshift i 2))) 105 (when (eq (wand addr 31) 0) 106 (console-newline) (puthex addr 8) 107 (c-p-s " ---------------")) 108 109 (printo (getmem addr)) 110 ) ) ) 111 (return t) 112) ) 113 114(if_system Cray-2 115 (de localdumpo (x n) 116 (prog (outputbase* addr) 117 (setq outputbase* 8) 118 (when (greaterp n 255) (setq n 255)) 119 (console-newline) 120 (printo x) (console-newline) 121 (ifor (from i 0 n 1) 122 (do (progn 123 (setq addr (wplus2 (inf x) i)) 124 (when (eq (wand addr 7) 0) 125 (console-newline) (putoct addr) 126 (c-p-s " ---------------")) 127 128 (printo (localmemo addr)) 129 ) ) ) 130 (return t) 131)) ) 132 133 134(de puthex (it n) % print an octal number 135 (cond ((and (weq it 0) (wleq n 0)) nil) 136 (t (progn 137 (puthex (wshift it -4) (wplus2 n -1)) 138 (helferle-prindig (wand it 15)) 139) ) ) ) 140 141(de helferle-prindig (dig) % print a numeric digit 142 (if (wlessp dig 10) (unixputc (wplus2 dig 48)) 143 (unixputc (wplus2 65 (wdifference dig 10))))) 144 145(compiletime (setq *syslisp nil)) 146