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