1(compiletime (copyd '*jumpon '*xjumpon)) 2%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 3% 4% File: PNK:PRINTERS.SL 5% Title: Printing functions for various data types 6% Author: Eric Benson 7% Created: 27 August 1981 8% Modified: 28-Sep-87 9% Package: Kernel 10% 11% (c) Copyright 1987, University of Utah, all rights reserved. 12% 13%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 14% 15% Revisions: 16% 17% 27-Jan-95 (Herbert Melenk) 18% Introduced function >output-case< for supporting upper case output. 19% 03-NOV-94 (Herbert Melenk) 20% Installed switching to lower case PSL **low-case. 21% 06-APR-88 (Julian Padget) 22% Incorporated stuff for printing extra CPSL datatypes. 23% 19 Mar 1988 (Julian Padget) 24% As immediately below for stack group descriptors. 25% 28-Sep-87 (Harold Carr) 26% Copied compiletime macro definition of isinum from arithemetic.sl to here. 27% Then used it in ChannelWriteBitStrAux instead of INUMP. 28% 04-Sep-87 (Leigh Stoller & Harold Carr) 29% Made ChannelWriteBitStrAux make sure that the value returned by 30% intlshift is a machine word since the recursive calls expect words. 31% 26-Aug-87 (Leigh Stoller) 32% Removed internal functions. 33% 27-May-87 (Harold Carr & Leigh Stoller) 34% Added fluid declaration of in* and out*. 35% Thu Feb 19 20:18:49 1987, originally Wed Mar 14 08:15:11 1984 (Russ Fish) 36% Fix infinite loop in ChannelWriteBitStrAux due to sign extension of 37% negative numbers by WShift on the VAX. Use IntLShift fn instead. 38%JAP: 02 Sep 1986 (Julian Padget) 39%JAP: Added extra type tests to recursivechannelprin1 to recognise the new 40%JAP: data types added to support the new binder 41% 19-Jul-84 10:00 (Brian Beach) 42% Added (STRINF ...) around uses of DIGITSTRING in STRBYT. 43% 12-Jul-84 10:00 (Brian Beach) 44% Added compile-time load of sys-macros for warray declarations. 45% 31-May-84 10:46:35 (Brian Beach) 46% Call on IDAPPLY2 --> IDAPPLY. 47% 10-May-84 14:19:21 (Brian Beach) 48% <PSL.KERNEL>PRINTERS.RED.18, 6-Feb-84 10:30:27, Edit by KESSLER 49% As Per Hearn - Floating Point right offset is too large. Changed from 50% 30 to 14. 51% 52% 22-Mar-84 11:42:42 (Brian Beach) 53% Added compiletime load of io-decls. 54% 01-Dec-83 14:57:36 (Brian Beach) 55% Translated from Rlisp to Lisp. 56% 57%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 58 59(compiletime (load io-decls token-decls sys-consts sys-macros if-system)) 60 61(compiletime (flag '(charneedsescape output-switch-case) 'internalfunction)) 62 63(on fast-integers) 64 65(fluid '(in* out*)) 66 67(fluid '(outputbase* % current output base 68 prinlength % length of structures to print 69 prinlevel % level of recursion to print 70 currentscantable* 71 lispscantable* 72 idescapechar* 73 *lower % print IDs with uppercase chars lowered / outmoded 74 **low-case % lower case PSL 75 output-case* % eq 'raise: print IDs with lowercase chars raised 76 )) 77 78 79(loadtime 80 (progn (setq outputbase* 10) 81 (setq idescapechar* 33) % (char !!) 82 (setq currentscantable* lispscantable*))) % so TokenTypeOfChar works right 83 84(compiletime 85 (progn (ds uppercasep (ch) (and (wgeq ch (char !A)) (wleq ch (char !Z)))) 86 (ds lowercasep (ch) (and (wgeq ch (char !a)) (wleq ch (char !z)))) 87 (ds raisechar (ch) (wplus2 (wdifference ch (char !a)) (char !A))) 88 (ds lowerchar (ch) (wplus2 (wdifference ch (char !A)) (char !a))) 89 )) 90 91(compiletime 92 (dm isinum (u) 93 (list '(lambda (x) 94 (eq (signedfield x 95 (isub1 infstartingbit) 96 (iadd1 infbitlength)) 97 x)) 98 (second u)) 99 )) 100 101(de output-case(u) 102 (let((c output-case*)) 103 (when (and u (not (eq u 'raise))) 104 (typeerror u 'output-case "a supported mode")) 105 (setq output-case* u) 106 c)) 107 108%. Writes EOL first if given Len causes max line length to be exceeded 109(de checklinefit (len chn fn itm) 110 (when (and (wgreaterp (wplus2 (wgetv lineposition chn) len) 111 (wgetv maxline chn)) 112 (wgreaterp (wgetv maxline chn) 0)) 113 (channelwritechar chn (char eol))) 114 (idapply fn (list chn itm))) 115 116(de channelwritestring (channel strng) 117 % 118 % Strng may be tagged or not, but it must have a length field accesible 119 % by StrLen. 120 % 121 (prog (uplim) 122 (setq uplim (strlen (strinf strng))) 123 (for (from i 0 uplim 1) 124 (do (channelwritechar channel (strbyt (strinf strng) i)))))) 125 126(de writestring (s) 127 (channelwritestring out* s)) 128 129(fluid '(digitstring)) 130 131(setq digitstring "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") 132 133(declare-wstring writenumberbuffer size 100) 134 135(de channelwritesysinteger (channel number radix) 136 (let ((exponent (syspowerof2p radix))) 137 138 (cond (exponent 139 (channelwritebitstring channel number (wdifference radix 1) 140 exponent)) 141 ((wlessp number 0) 142 (channelwritechar channel (char '!-)) 143 (writenumber1 channel (wminus (wquotient number radix)) 144 radix) 145 % To catch largest NEG 146 147 (channelwritechar channel 148 (strbyt (strinf digitstring) 149 (wminus (wremainder number radix))))) 150 ((weq number 0) 151 (channelwritechar channel (char !0))) 152 (t 153 (writenumber1 channel number radix))))) 154 155(de writenumber1 (channel number radix) 156 (if (weq number 0) 157 channel 158 (progn (writenumber1 channel (wquotient number radix) radix) 159 (channelwritechar channel 160 (strbyt (strinf digitstring) 161 (wremainder number radix)))))) 162 163(de channelwritebitstring (channel number digitmask exponent) 164 (if (weq number 0) 165 (channelwritechar channel (char !0)) 166 (channelwritebitstraux channel number digitmask exponent))) 167 168(de channelwritebitstraux (channel number digitmask exponent) 169 (cond ((weq number 0) channel) 170 (t % Channel means nothing here just trying to fool the compiler 171 (progn 172 (channelwritebitstraux 173 channel 174 (if_system VAX % Avoid wshift sign extension on the Vax. 175 (prog (u) 176 (cond ((not (isinum 177 (setq u 178 (intlshift number 179 (wminus exponent))))) 180 (return (fixval (fixinf u)))) 181 (t 182 (return u)))) 183 (wshift number (wminus exponent))) 184 digitmask 185 exponent) 186 (channelwritechar channel 187 (strbyt (strinf digitstring) (wand number digitmask))))))) 188 189(de writesysinteger (number radix) 190 (channelwritesysinteger out* number radix)) 191 192(de channelwritefixnum (channel num) 193 (channelwriteinteger channel (fixval (fixinf num)))) 194 195(de channelwriteinteger (channel num) 196 (when (wneq outputbase* 10) 197 (channelwritesysinteger channel outputbase* 10) 198 (channelwritechar channel (char !#))) 199 (channelwritesysinteger channel num outputbase*) 200 ) 201 202(de channelwritesysfloat (channel floatptr) 203 (prog (ch chindex) 204 (writefloat writenumberbuffer floatptr) 205 (channelwritestring channel writenumberbuffer))) 206 207(de channelwritefloat (channel lispfloatptr) 208 (channelwritesysfloat channel (floatbase (fltinf lispfloatptr)))) 209 210(de channelprintstring (channel strng) 211 (prog (len ch) 212 (channelwritechar channel (char !")) 213 (setq len (strlen (strinf strng))) 214 (for (from i 0 len 1) 215 (do (progn (setq ch (strbyt (strinf strng) i)) 216 (when (weq ch (char !")) 217 (channelwritechar channel (char !"))) 218 (channelwritechar channel ch)))) 219 (channelwritechar channel (char !")))) 220 221(de output-switch-case(ch) 222 (if **low-case 223 (if (lowercasep ch) (raisechar ch) ch) 224 (if (uppercasep ch) (lowerchar ch) ch))) 225 226(de channelwriteid (channel itm) 227 (cond ((or (and **low-case (not (eq output-case* 'raise))) 228 (and (not **low-case) (not *lower))) 229 (channelwritestring channel (symnam (idinf itm)))) 230 (t 231 (prog (ch len) 232 (setq itm (strinf (symnam (idinf itm)))) 233 (setq len (strlen itm)) 234 (for (from i 0 len 1) 235 (do (progn (setq ch (output-switch-case (strbyt itm i))) 236 (channelwritechar channel ch)))))))) 237 238(de channelwriteunbound (channel itm) 239 (channelwritestring channel "#<Unbound:") 240 (channelwriteid channel itm) 241 (channelwritechar channel (char '>))) 242 243(de charneedsescape(ch) 244 (or (and (null **low-case) (lowercasep ch)) 245 (and **low-case (uppercasep ch)))) 246 247(de channelprintid (channel itm) 248 (prog (len ch tokentype) 249 (setq itm (strinf (symnam (idinf itm)))) 250 (setq len (strlen itm)) 251 (setq ch (strbyt itm 0)) 252 (when (or (wneq (tokentypeofchar ch) 10) (charneedsescape ch)) 253 (channelwritechar channel idescapechar*)) 254 (if (or (and **low-case (not (eq output-case* 'raise))) 255 (and (not **low-case) (not *lower))) 256 (progn (channelwritechar channel ch) 257 (for (from i 1 len 1) 258 (do 259 (progn (setq ch (strbyt itm i)) 260 (setq tokentype (tokentypeofchar ch)) 261 (unless (or (wleq tokentype 10) 262 (weq tokentype plussign) 263 (weq tokentype minussign)) 264 (channelwritechar channel idescapechar*)) 265 (when (charneedsescape ch) 266 (channelwritechar channel idescapechar*)) 267 (channelwritechar channel ch))))) 268 (progn (channelwritechar channel (output-switch-case ch)) 269 (for (from i 1 len 1) 270 (do 271 (progn (setq ch (strbyt itm i)) 272 (setq tokentype (tokentypeofchar ch)) 273 (unless (or (wleq tokentype 10) 274 (weq tokentype plussign) 275 (weq tokentype minussign)) 276 (channelwritechar channel idescapechar*)) 277 (when (charneedsescape ch) 278 (channelwritechar channel idescapechar*)) 279 (setq ch (output-switch-case ch)) 280 (channelwritechar channel ch)))))))) 281 282(de channelprintunbound (channel itm) 283 (channelwritestring channel "#<Unbound ") 284 (channelprintid channel itm) 285 (channelwritechar channel (char '>))) 286 287(de channelwritecodepointer (channel cp) 288 (prog (n) 289 (setq cp (codeinf cp)) 290 (channelwritestring channel "#<Code ") 291 (setq n (!%code-number-of-arguments cp)) 292 (when (and (wgeq n 0) (wleq n maxargs)) 293 (channelwritesysinteger channel n 10) 294 (channelwritechar channel (char blank))) 295 (channelwritesysinteger channel cp compressedbinaryradix) 296 (channelwritechar channel (char '>)))) 297 298(de channelwriteunknownitem (channel itm) 299 (channelwritestring channel "#<Unknown ") 300 (channelwritesysinteger channel itm compressedbinaryradix) 301 (channelwritechar channel (char >))) 302 303(de channelwriteblankoreol (channel) 304 (if (and (wgeq (wplus2 (wgetv lineposition channel) 1) 305 (wgetv maxline channel)) 306 (wgreaterp (wgetv maxline channel) 0)) 307 (channelwritechar channel (char eol)) 308 (channelwritechar channel (char ! )))) 309 310(de channelwritepair (channel itm level) 311 (if (and (intp prinlevel) (wgeq level prinlevel)) 312 (channelwritechar channel (char '!#)) 313 (prog (n) 314 (setq level (wplus2 level 1)) 315 (checklinefit 1 channel 'channelwritechar (char !()) 316 (if (or (not (intp prinlength)) (wleq 1 prinlength)) 317 (progn (recursivechannelprin2 channel (car itm) level) 318 (setq n 2) 319 (setq itm (cdr itm)) 320 (while (and (pairp itm) 321 (or (not (intp prinlength)) (wleq n prinlength))) 322 (channelwriteblankoreol channel) 323 (recursivechannelprin2 channel (car itm) level) 324 (setq n (wplus2 n 1)) 325 (setq itm (cdr itm))) 326 (cond ((pairp itm) 327 (checklinefit 3 channel 'channelwritestring 328 " ...")) 329 (itm 330 (checklinefit 3 channel 'channelwritestring 331 " . ") 332 (recursivechannelprin2 channel itm level)))) 333 (checklinefit 3 channel 'channelwritestring "...")) 334 (checklinefit 1 channel 'channelwritechar (char !)))))) 335 336(de channelprintpair (channel itm level) 337 (if (and (intp prinlevel) (wgeq level prinlevel)) 338 (channelwritechar channel (char '!#)) 339 (prog (n) 340 (setq level (wplus2 level 1)) 341 (checklinefit 1 channel 'channelwritechar (char !()) 342 (if (or (not (intp prinlength)) (wleq 1 prinlength)) 343 (progn (recursivechannelprin1 channel (car itm) level) 344 (setq n 2) 345 (setq itm (cdr itm)) 346 (while (and (pairp itm) 347 (or (not (intp prinlength)) (wleq n prinlength))) 348 (channelwriteblankoreol channel) 349 (recursivechannelprin1 channel (car itm) level) 350 (setq n (wplus2 n 1)) 351 (setq itm (cdr itm))) 352 (cond ((pairp itm) 353 (checklinefit 3 channel 'channelwritestring 354 " ...")) 355 (itm 356 (checklinefit 3 channel 'channelwritestring 357 " . ") 358 (recursivechannelprin1 channel itm level)))) 359 (checklinefit 3 channel 'channelwritestring "...")) 360 (checklinefit 1 channel 'channelwritechar (char !)))))) 361 362(de channelwritevector (channel vec level) 363 (if (and (intp prinlevel) (wgeq level prinlevel)) 364 (channelwritechar channel (char '!#)) 365 (prog (len i) 366 (setq level (wplus2 level 1)) 367 (checklinefit 1 channel 'channelwritechar (char '![)) 368 (setq len (veclen (vecinf vec))) 369 (when (wlessp len 0) 370 (return (checklinefit 1 channel 'channelwritechar (char '!])))) 371 (setq i 0) 372 loopbegin 373 (if (or (not (intp prinlength)) (wlessp i prinlength)) 374 (progn (recursivechannelprin2 channel (vecitm (vecinf vec) i) 375 level) 376 (when (wleq (setq i (wplus2 i 1)) len) 377 (channelwriteblankoreol channel) 378 (go loopbegin))) 379 (checklinefit 3 channel 'channelwritestring "...")) 380 (checklinefit 1 channel 'channelwritechar (char '!]))))) 381 382(de channelprintvector (channel vec level) 383 (if (and (intp prinlevel) (wgeq level prinlevel)) 384 (channelwritechar channel (char '!#)) 385 (prog (len i) 386 (setq level (wplus2 level 1)) 387 (checklinefit 1 channel 'channelwritechar (char '![)) 388 (setq len (veclen (vecinf vec))) 389 (when (wlessp len 0) 390 (return (checklinefit 1 channel 'channelwritechar (char '!])))) 391 (setq i 0) 392 loopbegin 393 (if (or (not (intp prinlength)) (wlessp i prinlength)) 394 (progn (recursivechannelprin1 channel (vecitm (vecinf vec) i) 395 level) 396 (when (wleq (setq i (wplus2 i 1)) len) 397 (channelwriteblankoreol channel) 398 (go loopbegin))) 399 (checklinefit 3 channel 'channelwritestring "...")) 400 (checklinefit 1 channel 'channelwritechar (char '!]))))) 401 402(de channelwriteevector (channel evec level) 403 (prog (handler) 404 (cond ((and (intp prinlevel) (wgeq level prinlevel)) 405 (channelwritechar channel (char '!#))) 406 ((and (getd 'object-get-handler-quietly) 407 (setq handler 408 (object-get-handler-quietly evec 'channelprin))) 409 (apply handler (list evec channel level nil))) 410 (t (channelwritestring channel "#<EVector ") 411 (channelwritesysinteger channel (evecinf evec) 412 compressedbinaryradix) 413 (channelwritechar channel (char '>)) nil)))) 414 415(de channelprintevector (channel evec level) 416 (prog (handler) 417 (cond ((and (intp prinlevel) (wgeq level prinlevel)) 418 (channelwritechar channel (char '!#))) 419 ((and (getd 'object-get-handler-quietly) 420 (setq handler 421 (object-get-handler-quietly evec 'channelprin))) 422 (apply handler (list evec channel level t))) 423 (t (channelwritestring channel "#<EVector ") 424 (channelwritesysinteger channel (evecinf evec) 425 compressedbinaryradix) 426 (channelwritechar channel (char '>)) nil)))) 427 428(de channelwritecontext (channel itm level) 429 (if (and (intp prinlevel) (wgeq level prinlevel)) 430 (channelwritechar channel (char '!#)) 431 (progn 432 (channelwritestring channel "#<Context seq:") 433 (channelwritesysinteger channel (seq itm) 10) 434 435 (channelwritestring channel " span:") 436 (channelwritesysinteger channel (span itm) 10) 437 438 (channelwritestring channel " gen:") 439 (channelwritesysinteger channel (gen itm) 10) 440 441 (channelwritestring channel " alink:") 442 (channelwritestring channel "#<Context ") 443 (channelwritesysinteger channel (alink itm) compressedbinaryradix) 444 (channelwritechar channel (char '!>)) 445 446 (channelwritestring channel " clink:") 447 (channelwritestring channel "#<Context ") 448 (channelwritesysinteger channel (clink itm) compressedbinaryradix) 449 (channelwritechar channel (char '!>)) 450 451 (channelwritestring channel " refc:") 452 (channelwritesysinteger channel (refc itm) 10) 453 454 (channelwritestring channel " bvec:") 455 (channelwritestring channel "#<Bvector ") 456 (channelwritesysinteger channel (bvec itm) compressedbinaryradix) 457 (channelwritechar channel (char '!>)) 458 459 (channelwritestring channel " root:") 460 (channelwritestring channel "#<Context ") 461 (channelwritesysinteger channel (root itm) compressedbinaryradix) 462 (channelwritechar channel (char '!>)) 463 (channelwritechar channel (char '!>))))) 464 465(de channelprintcontext (channel itm level) 466 (if (and (intp prinlevel) (wgeq level prinlevel)) 467 (channelwritechar channel (char '!#)) 468 (progn 469 (channelwritestring channel "#<Context seq:") 470 (channelwritesysinteger channel (seq itm) 10) 471 472 (channelwritestring channel " span:") 473 (channelwritesysinteger channel (span itm) 10) 474 475 (channelwritestring channel " gen:") 476 (channelwritesysinteger channel (gen itm) 10) 477 478 (channelwritestring channel " alink:") 479 (channelwritestring channel "#<Context ") 480 (channelwritesysinteger channel (alink itm) compressedbinaryradix) 481 (channelwritechar channel (char '!>)) 482 483 (channelwritestring channel " clink:") 484 (channelwritestring channel "#<Context ") 485 (channelwritesysinteger channel (clink itm) compressedbinaryradix) 486 (channelwritechar channel (char '!>)) 487 488 (channelwritestring channel " refc:") 489 (channelwritesysinteger channel (refc itm) 10) 490 491 (channelwritestring channel " bvec:") 492 (channelwritestring channel "#<Bvector ") 493 (channelwritesysinteger channel (bvec itm) compressedbinaryradix) 494 (channelwritechar channel (char '!>)) 495 496 (channelwritestring channel " root:") 497 (channelwritestring channel "#<Context ") 498 (channelwritesysinteger channel (root itm) compressedbinaryradix) 499 (channelwritechar channel (char '!>)) 500 (channelwritechar channel (char '!>))))) 501 502(de channelwritebstruct (channel itm level) 503 (channelwritestring channel "#<Bstruct ") 504 (channelwritesysinteger channel itm compressedbinaryradix) 505 (channelwritechar channel (char '!>))) 506 507(de channelprintbstruct (channel itm level) 508 (channelwritestring channel "#<Bstruct ") 509 (channelwritesysinteger channel itm compressedbinaryradix) 510 (channelwritechar channel (char '!>))) 511 512(de channelwritebvector (channel itm level) 513 (channelwritestring channel "#<Bvector ") 514 (channelwritesysinteger channel itm compressedbinaryradix) 515 (channelwritechar channel (char '!>))) 516 517(de channelprintbvector (channel itm level) 518 (channelwritestring channel "#<Bvector ") 519 (channelwritesysinteger channel itm compressedbinaryradix) 520 (channelwritechar channel (char '!>))) 521 522(de channelwritefunarg (channel itm level) 523 (if (and (intp prinlevel) (wgeq level prinlevel)) 524 (channelwritechar channel (char '!#)) 525 (progn 526 (channelwritestring channel "#<Funarg context:") 527 (channelwritesysinteger channel (car itm) compressedbinaryradix) 528 (channelwritestring channel " expression:") 529 (channelwritesysinteger channel (cdr itm) compressedbinaryradix) 530 (channelwritechar channel (char '!>))))) 531 532(de channelprintfunarg (channel itm level) 533 (if (and (intp prinlevel) (wgeq level prinlevel)) 534 (channelwritechar channel (char '!#)) 535 (progn 536 (channelwritestring channel "#<Funarg context:") 537 (channelwritesysinteger channel (car itm) compressedbinaryradix) 538 (channelwritestring channel " expression:") 539 (channelwritesysinteger channel (cdr itm) compressedbinaryradix) 540 (channelwritechar channel (char '!>))))) 541 542(de channelwritesgd (channel itm level) 543 (channelwritestring channel "#<SGD ") 544 (channelwritesysinteger channel itm compressedbinaryradix) 545 (channelwritechar channel (char '!>))) 546 547(de channelprintsgd (channel itm level) 548 (channelwritestring channel "#<SGD ") 549 (channelwritesysinteger channel itm compressedbinaryradix) 550 (channelwritechar channel (char '!>))) 551 552(de channelwritewords (channel itm) 553 (prog (len i) 554 (channelwritestring channel "#<Words:") 555 (setq len (wrdlen (wrdinf itm))) 556 (when (wlessp len 0) 557 (return (checklinefit 1 channel 'channelwritechar (char '>)))) 558 (setq i 0) 559 loopbegin 560 (if (or (not (intp prinlength)) (wlessp i prinlength)) 561 (progn (checklinefit 10 channel 'channelwriteinteger 562 (wrditm (wrdinf itm) i)) 563 (when (wleq (setq i (wplus2 i 1)) len) 564 (channelwriteblankoreol channel) 565 (go loopbegin))) 566 (checklinefit 3 channel 'channelwritestring "...")) 567 (checklinefit 1 channel 'channelwritechar (char '>)))) 568 569(de channelwritehalfwords (channel itm) 570 (prog (len i) 571 (channelwritestring channel "#<Halfwords:") 572 (setq len (halfwordlen (halfwordinf itm))) 573 (when (wlessp len 0) 574 (return (checklinefit 1 channel 'channelwritechar (char '>)))) 575 (setq i 0) 576 loopbegin 577 (if (or (not (intp prinlength)) (wlessp i prinlength)) 578 (progn (checklinefit 10 channel 'channelwriteinteger 579 (halfworditm (halfwordinf itm) i)) 580 (when (wleq (setq i (wplus2 i 1)) len) 581 (channelwriteblankoreol channel) 582 (go loopbegin))) 583 (checklinefit 3 channel 'channelwritestring "...")) 584 (checklinefit 1 channel 'channelwritechar (char '>)))) 585 586(de channelwritebytes (channel itm) 587 (prog (len i) 588 (channelwritestring channel "#<Bytes:") 589 (setq len (strlen (strinf itm))) 590 (when (wlessp len 0) 591 (return (checklinefit 1 channel 'channelwritechar (char '>)))) 592 (setq i 0) 593 loopbegin 594 (if (or (not (intp prinlength)) (wlessp i prinlength)) 595 (progn (checklinefit 10 channel 'channelwriteinteger 596 (strbyt (strinf itm) i)) 597 (when (wleq (setq i (wplus2 i 1)) len) 598 (channelwriteblankoreol channel) 599 (go loopbegin))) 600 (checklinefit 3 channel 'channelwritestring "...")) 601 (checklinefit 1 channel 'channelwritechar (char '>)))) 602 603(de channelprin2 (channel itm) 604 %. Display Itm on Channel 605 (recursivechannelprin2 channel itm 0)) 606 607(de recursivechannelprin2 (channel itm level) 608 (case (tag itm) 609 ((posint-tag negint-tag) 610 (if (eq channel 4) % explode , flatsize etc 611 (checklinefit 10 channel 'channelwriteinteger itm) 612 (checklinefit (flatsize2 itm) channel 'channelwriteinteger itm))) 613 ((id-tag) 614 (checklinefit (wplus2 (strlen (strinf (symnam (idinf itm)))) 1) 615 channel 'channelwriteid itm)) 616 ((unbound-tag) 617 (checklinefit (wplus2 (strlen (strinf (symnam (idinf itm)))) 12) 618 channel 'channelwriteunbound itm)) 619 ((string-tag) 620 (checklinefit (wplus2 (strlen (strinf itm)) 1) channel 621 'channelwritestring itm)) 622 ((code-tag) 623 (checklinefit 14 channel 'channelwritecodepointer itm)) 624 ((fixnum-tag) 625 (if (eq channel 4) % explode , flatsize etc 626 (checklinefit 20 channel 'channelwritefixnum itm) 627 (checklinefit (flatsize2 itm) channel 'channelwritefixnum itm))) 628 ((floatnum-tag) 629 (if (eq channel 4) % explode , flatsize etc 630 (checklinefit 20 channel 'channelwritefloat itm) 631 (checklinefit (flatsize2 itm) channel 'channelwritefloat itm))) 632 ((words-tag) (channelwritewords channel itm)) 633 ((halfwords-tag) (channelwritehalfwords channel itm)) 634 ((bytes-tag) (channelwritebytes channel itm)) 635 ((pair-tag) (channelwritepair channel itm level)) 636 ((vector-tag) (channelwritevector channel itm level)) 637 ((evector-tag) (channelwriteevector channel itm level)) 638 ((context-tag) (channelwritecontext channel itm level)) 639 ((bstruct-tag) (channelwritebstruct channel itm level)) 640 ((bvector-tag) (channelwritebvector channel itm level)) 641 ((funarg-tag) (channelwritefunarg channel itm level)) 642 ((sgd-tag) (channelwritesgd channel itm level)) 643 (nil (checklinefit 20 channel 'channelwriteunknownitem itm))) 644 itm) 645 646(de prin2 (itm) 647 %. ChannelPrin2 to current channel 648 (channelprin2 out* itm)) 649 650(de channelprin1 (channel itm) 651 %. Display Itm in READable form 652 (recursivechannelprin1 channel itm 0)) 653 654(de recursivechannelprin1 (channel itm level) 655 (case (tag itm) 656 ((posint-tag negint-tag) 657 (if (eq channel 4) % explode , flatsize etc 658 (checklinefit 10 channel 'channelwriteinteger itm) 659 (checklinefit (flatsize itm) channel 'channelwriteinteger itm))) 660 ((id-tag) % leave room for possible escape chars 661 (checklinefit (wplus2 (strlen (strinf (symnam (idinf itm)))) 1) 662 channel 'channelprintid itm)) 663 ((unbound-tag) % leave room for possible escape chars 664 (checklinefit (wplus2 (strlen (strinf (symnam (idinf itm)))) 16) 665 channel 'channelprintunbound itm)) 666 ((string-tag) 667 (checklinefit (wplus2 (strlen (strinf itm)) 1) channel 668 'channelprintstring itm)) 669 ((code-tag) 670 (checklinefit 14 channel 'channelwritecodepointer itm)) 671 ((fixnum-tag) 672 (if (eq channel 4) % explode , flatsize etc 673 (checklinefit 20 channel 'channelwritefixnum itm) 674 (checklinefit (flatsize itm) channel 'channelwritefixnum itm))) 675 ((floatnum-tag) 676 (if (eq channel 4) % explode , flatsize etc 677 (checklinefit 20 channel 'channelwritefloat itm) 678 (checklinefit (flatsize itm) channel 'channelwritefloat itm))) 679 ((words-tag) (channelwritewords channel itm)) 680 ((halfwords-tag) (channelwritehalfwords channel itm)) 681 ((bytes-tag) (channelwritebytes channel itm)) 682 ((pair-tag) (channelprintpair channel itm level)) 683 ((vector-tag) (channelprintvector channel itm level)) 684 ((evector-tag) (channelprintevector channel itm level)) 685 ((context-tag) (channelprintcontext channel itm level)) 686 ((bstruct-tag) (channelprintbstruct channel itm level)) 687 ((bvector-tag) (channelprintbvector channel itm level)) 688 ((funarg-tag) (channelprintfunarg channel itm level)) 689 ((sgd-tag) (channelprintsgd channel itm level)) 690 (nil (checklinefit 20 channel 'channelwriteunknownitem itm))) 691 itm) 692 693(de prin1 (itm) 694 %. ChannelPrin1 to current output 695 (channelprin1 out* itm)) 696 697 698(off fast-integers) 699 700%% End of file. 701