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