ht.l (16585B)
1 # 13mar13abu 2 # (c) Software Lab. Alexander Burger 3 4 (data 'HtData) 5 initData 6 7 ### Hypertext I/O functions ### 8 : HtLt asciz "<" 9 : HtGt asciz ">" 10 : HtAmp asciz "&" 11 : HtQuot asciz """ 12 : HtNbsp asciz " " 13 14 : HtEsc ascii " \\\"#%&:;<=>?_" 15 (equ HTESC 12) 16 17 (code 'HtCode) 18 initCode 19 20 # (ht:Prin 'sym ..) -> sym 21 (code 'Prin 2) 22 push X 23 push Y 24 push Z 25 ld X (E CDR) # Args 26 do 27 ld E (X) # Eval next 28 eval 29 num E # Number? 30 jnz 20 # Yes 31 atom E # Pair? 32 jz 20 # Yes 33 sym (E TAIL) # External symbol? 34 if nz # Yes 35 20 call prinE_E # Plain print 36 else 37 push E # Save return value 38 call bufStringE_SZ # Write to stack buffer 39 ld Y S # Point to string 40 do 41 nul (Y) # Null byte? 42 while nz # No 43 ld B (Y) # Next byte 44 cmp B (char "<") # Escape special characters 45 if eq 46 ld C HtLt # "<" 47 call outStringC 48 else 49 cmp B (char ">") 50 if eq 51 ld C HtGt # ">" 52 call outStringC 53 else 54 cmp B (char "&") 55 if eq 56 ld C HtAmp # "&" 57 call outStringC 58 else 59 cmp B (char "\"") 60 if eq 61 ld C HtQuot # """ 62 call outStringC 63 else 64 cmp B (hex "FF") 65 if eq 66 ld B (hex "EF") 67 call (PutB) 68 ld B (hex "BF") 69 call (PutB) 70 ld B (hex "BF") 71 call (PutB) 72 else 73 ld C A # Save char 74 call (PutB) # Output it 75 test C (hex "80") # Double byte? 76 if nz # Yes 77 inc Y # Next 78 ld B (Y) # Output second byte 79 call (PutB) 80 test C (hex "20") # Triple byte? 81 if nz # Yes 82 inc Y # Next 83 ld B (Y) # Output third byte 84 call (PutB) 85 end 86 end 87 end 88 end 89 end 90 end 91 end 92 inc Y # Increment string pointer 93 loop 94 ld S Z # Drop buffer 95 pop E 96 end 97 ld X (X CDR) # X on rest 98 atom X # More? 99 until nz # No 100 pop Z 101 pop Y 102 pop X 103 ret 104 105 (code 'putHexB 0) # E 106 ld E A # Save B 107 ld B (char "%") # Prefix with "%" 108 call (PutB) 109 ld A E # Get B 110 shr B 4 # Get upper nibble 111 and B 15 112 cmp B 9 # Letter? 113 if gt # Yes 114 add B 7 115 end 116 add B (char "0") 117 call (PutB) # Output upper nibble 118 ld A E # Get B again 119 and B 15 # Get lower nibble 120 cmp B 9 # Letter? 121 if gt # Yes 122 add B 7 123 end 124 add B (char "0") 125 jmp (PutB) # Output lower nibble 126 127 (code 'htFmtE 0) 128 cmp E Nil # NIL? 129 if ne # No 130 num E # Number? 131 if nz # Yes 132 ld B (char "+") # Prefix with "+" 133 call (PutB) 134 jmp prinE # and print it 135 end 136 push X 137 atom E # List? 138 if z # Yes 139 ld X E 140 do 141 ld B (char "_") # Prefix with "_" 142 call (PutB) 143 ld E (X) # Print next item 144 call htFmtE 145 ld X (X CDR) # End of list? 146 atom X 147 until nz # Yes 148 else # Symbol 149 ld X (E TAIL) 150 call nameX_X # Get name 151 cmp X ZERO # Any? 152 if ne # Yes 153 sym (E TAIL) # External symbol? 154 if nz # Yes 155 ld B (char "-") # Prefix with "-" 156 call (PutB) 157 call prExtNmX # Print external 158 else 159 push Y 160 ld Y ((EnvIntern)) 161 call isInternEXY_F # Internal symbol? 162 ld C 0 163 if eq # Yes 164 ld B (char "$") # Prefix with "$" 165 call (PutB) 166 else 167 call symByteCX_FACX # Get first byte 168 cmp B (char "$") # Dollar, plus or minus? 169 jeq 40 170 cmp B (char "+") 171 jeq 40 172 cmp B (char "-") 173 jne 50 174 40 call putHexB # Encode hexadecimal 175 end 176 do 177 call symByteCX_FACX # Next byte 178 while nz 179 50 memb HtEsc HTESC # Escape? 180 if eq # Yes 181 call putHexB # Encode hexadecimal 182 else 183 ld E A # Save char 184 call (PutB) # Output it 185 test E (hex "80") # Double byte? 186 if nz # Yes 187 call symByteCX_FACX # Next byte 188 call (PutB) # Output second byte 189 test E (hex "20") # Triple byte? 190 if nz # Yes 191 call symByteCX_FACX # Next byte 192 call (PutB) # Output third byte 193 end 194 end 195 end 196 loop 197 pop Y 198 end 199 end 200 end 201 pop X 202 end 203 ret 204 205 # (ht:Fmt 'any ..) -> sym 206 (code 'Fmt 2) 207 push X 208 push Y 209 push Z 210 ld X (E CDR) # X on args 211 link 212 do 213 ld E (X) 214 eval+ # Eval next arg 215 push E 216 ld X (X CDR) 217 atom X # More args? 218 until nz # No 219 lea Y (L -I) # Y on first arg 220 ld Z S # Z on last arg 221 link 222 call begString # Start string 223 ld E (Y) 224 call htFmtE # Format first arg 225 do 226 cmp Y Z # More args? 227 while ne # Yes 228 ld B (char "&") 229 call (PutB) 230 sub Y I # Next arg 231 ld E (Y) 232 call htFmtE # Format it 233 loop 234 call endString_E # Retrieve result 235 drop 236 pop Z 237 pop Y 238 pop X 239 ret 240 241 (code 'getHexX_A 0) 242 ld A ((X) TAIL) # Get first hex digit 243 call firstByteA_B 244 sub B (char "0") # Convert 245 cmp B 9 246 if gt 247 and B (hex "DF") 248 sub B 7 249 end 250 ld X (X CDR) # Next symbol 251 ret 252 253 (code 'getUnicodeX_FAX 0) 254 ld E X # Save X 255 ld C 0 # Init unicode value 256 do 257 ld X (X CDR) 258 ld A ((X) TAIL) # Get next character symbol 259 call firstByteA_B 260 cmp B (char "0") # Digit? 261 while ge 262 cmp B (char "9") 263 while le # Yes 264 sub B (char "0") # Convert 265 push A # Save digit 266 ld A C # Get accu 267 mul 10 # Build decimal number 268 pop C # Get digit 269 add C A # New unicode value 270 loop 271 cmp B (char ";") # Terminator? 272 if eq # Yes 273 ld X (X CDR) # Skip ";" 274 ld A C # Get value 275 null A # Any? 276 jnz Ret # Yes 277 end 278 ld X E # Restore X 279 setz # 'z' 280 ret 281 282 (code 'headCX_FX 0) # E 283 ld E X # Save X 284 do 285 inc C # Point to next char 286 nul (C) # Any? 287 while nz # Yes 288 ld A ((X) TAIL) # Get next character symbol 289 call firstByteA_B 290 cmp B (C) # Matched? 291 while eq # Yes 292 ld X (X CDR) 293 loop 294 ldnz X E # Restore X when no match 295 ret # 'z' if match 296 297 # (ht:Pack 'lst) -> sym 298 (code 'Pack 2) 299 push X 300 ld E ((E CDR)) # Eval arg 301 eval 302 link 303 push E # Save 304 link 305 ld X E # List in X 306 call begString # Start string 307 do 308 atom X # More items? 309 while z # Yes 310 ld E (X) # Get next character symbol 311 ld A (E TAIL) 312 call firstByteA_B 313 cmp B (char "%") # Hex-escaped? 314 if eq # Yes 315 ld X (X CDR) # Skip "%" 316 call getHexX_A # Get upper nibble 317 shl A 4 318 ld C A # into C 319 call getHexX_A # Get lower nibble 320 or A C # Combine 321 call (PutB) # Output 322 else 323 ld X (X CDR) # Next symbol 324 cmp B (char "&") # Ampersand? 325 if ne # No 326 call outNameE # Normal output 327 else 328 ld C HtLt # "<" 329 call headCX_FX 330 if eq 331 ld B (char "<") 332 call (PutB) 333 else 334 ld C HtGt # ">" 335 call headCX_FX 336 if eq 337 ld B (char ">") 338 call (PutB) 339 else 340 ld C HtAmp # "&" 341 call headCX_FX 342 if eq 343 ld B (char "&") 344 call (PutB) 345 else 346 ld C HtQuot # """ 347 call headCX_FX 348 if eq 349 ld B (char "\"") 350 call (PutB) 351 else 352 ld C HtNbsp # " " 353 call headCX_FX 354 if eq 355 ld B (char " ") 356 call (PutB) 357 else 358 ld A ((X) TAIL) # Get next byte 359 call firstByteA_B 360 cmp B (char "#") # Hash? 361 jne 40 # No 362 call getUnicodeX_FAX # Unicode? 363 if nz # Yes 364 call mkCharA_A # Make symbol 365 ld E A 366 call outNameE # Output unicode char 367 else 368 40 ld B (char "&") # Else ouput an ampersand 369 call (PutB) 370 end 371 end 372 end 373 end 374 end 375 end 376 end 377 end 378 loop 379 call endString_E # Retrieve result 380 drop 381 pop X 382 ret 383 384 ### Read content length bytes ### 385 # (ht:Read 'cnt) -> lst 386 (code 'Read 2) 387 push X 388 ld X E 389 ld E ((E CDR)) # E on arg 390 call evCntEX_FE # Eval 'cnt' 391 if nsz # > 0 392 ld A (Chr) # Look ahead char? 393 null A 394 if z # No 395 call (Get_A) # Get next char 396 end 397 null A # EOF? 398 if ns # No 399 call getChar_A # Read first char 400 cmp A 128 # Double byte? 401 if ge # Yes 402 dec E # Decrement count 403 cmp A 2048 # Triple byte? 404 if ge # Yes 405 dec E # Decrement count 406 end 407 end 408 dec E # Less than zero? 409 if ns # No 410 call mkCharA_A # First character 411 call consA_X # Build first cell 412 ld (X) A 413 ld (X CDR) Nil 414 link 415 push X # <L I> Result 416 link 417 do 418 null E # Count? 419 if z # No 420 ld E (L I) # Return result 421 break T 422 end 423 call (Get_A) # Get next char 424 null A # EOF? 425 if s # Yes 426 ld E Nil # Return NIL 427 break T 428 end 429 call getChar_A 430 cmp A 128 # Double byte? 431 if ge # Yes 432 dec E # Decrement count 433 cmp A 2048 # Triple byte? 434 if ge # Yes 435 dec E # Decrement count 436 end 437 end 438 dec E # Less than zero? 439 if s # Yes 440 ld E Nil # Return NIL 441 break T 442 end 443 call mkCharA_A # Build next character 444 call consA_C # And next cell 445 ld (C) A 446 ld (C CDR) Nil 447 ld (X CDR) C # Append to result 448 ld X C 449 loop 450 ld (Chr) 0 # Clear look ahead char 451 drop 452 pop X 453 ret 454 end 455 end 456 end 457 ld E Nil # Return NIL 458 pop X 459 ret 460 461 462 ### Chunked Encoding ### 463 (equ CHUNK 4000) 464 465 (data 'Chunk 0) 466 word 0 # <Y> Chunk size count 467 word 0 # <Y I> Saved Get_A function 468 word 0 # <Y II> Saved PutB function 469 skip CHUNK # <Y III> Chunk buffer 470 471 : Newlines asciz "0\\r\\n\\r\\n" 472 473 (code 'chrHex_AF 0) 474 ld A (Chr) 475 cmp B (char "0") # Decimal digit? 476 if ge 477 cmp B (char "9") 478 if le 479 sub B 48 # Yes 480 ret # 'nc' 481 end 482 end 483 and B (hex "DF") # Force upper case 484 cmp B (char "A") # Hex letter? 485 if ge 486 cmp B (char "F") 487 if le 488 sub B 55 # Yes 489 ret # 'nc' 490 end 491 end 492 ld A 0 493 sub A 1 # -1 494 ret # 'c' 495 496 (code 'chunkSize 0) 497 push X 498 ld X Chunk # Get Chunk 499 null (Chr) # 'Chr'? 500 if z # No 501 ld A (X I) # Call saved 'get' 502 call (A) 503 end 504 call chrHex_AF # Read encoded count 505 ld (X) A # Save in count 506 if ge # >= 0 507 do 508 ld A (X I) # Call saved 'get' 509 call (A) 510 call chrHex_AF # Read encoded count 511 while ge # >= 0 512 ld C (X) # Get count 513 shl C 4 # Combine 514 or C A 515 ld (X) C 516 loop 517 do 518 cmp (Chr) 10 # Fine linefeed 519 while ne 520 null (Chr) # EOF? 521 js 90 # Return 522 ld A (X I) # Call saved 'get' 523 call (A) 524 loop 525 ld A (X I) # Call saved 'get' 526 call (A) 527 null (X) # Count is zero? 528 if z # Yes 529 ld A (X I) # Call saved 'get' 530 call (A) # Skip '\r' of empty line 531 ld (Chr) 0 # Discard '\n' 532 end 533 end 534 90 pop X 535 ret 536 537 (code 'getChunked_A 0) 538 push Y 539 ld Y Chunk # Get Chunk 540 null (Y) # Count <= 0 541 if sz # Yes 542 ld A -1 # Return EOF 543 ld (Chr) A 544 else 545 ld A (Y I) # Call saved 'get' 546 call (A) 547 dec (Y) # Decrement count 548 if z 549 ld A (Y I) # Call saved 'get' 550 call (A) 551 ld A (Y I) # Skip '\n', '\r' 552 call (A) 553 call chunkSize 554 end 555 end 556 pop Y 557 ret 558 559 # (ht:In 'flg . prg) -> any 560 (code 'In 2) 561 push X 562 ld X (E CDR) # Args 563 ld E (X) # Eval 'flg' 564 eval 565 ld X (X CDR) # X on 'prg' 566 cmp E Nil # 'flg? 567 if eq # No 568 prog X # Run 'prg' 569 else 570 push Y 571 ld Y Chunk # Get Chunk 572 ld (Y I) (Get_A) # Save current 'get' 573 ld (Get_A) getChunked_A # Set new 574 call chunkSize 575 prog X # Run 'prg' 576 ld (Get_A) (Y I) # Restore 'get' 577 ld (Chr) 0 # Clear look ahead char 578 pop Y 579 end 580 pop X 581 ret 582 583 584 (code 'outHexA 0) 585 cmp A 15 # Single digit? 586 if gt # No 587 push A 588 shr A 4 # Divide by 16 589 call outHexA # Recurse 590 pop A 591 and B 15 592 end 593 cmp B 9 # Digit? 594 if gt # No 595 add B 39 # Make lower case letter 596 end 597 add B (char "0") # Make ASCII digit 598 jmp (PutB) 599 600 (code 'wrChunkY 0) # X 601 ld (PutB) (Y II) # Restore 'put' 602 ld A (Y) # Get count 603 call outHexA # Print as hex 604 ld B 13 # Output 'return' 605 call (PutB) 606 ld B 10 # Output 'newline' 607 call (PutB) 608 lea X (Y III) # X on chunk buffer 609 do 610 ld B (X) # Next byte from chunk buffer 611 call (PutB) # Output 612 inc X # Increment pointer 613 dec (Y) # Decrement 'Cnt' 614 until z 615 ld B 13 # Output 'return' 616 call (PutB) 617 ld B 10 # Output 'newline' 618 call (PutB) 619 ld (Y II) (PutB) # Save 'put' 620 ld (PutB) putChunkedB # Set new 621 ret 622 623 (code 'putChunkedB 0) 624 push X 625 push Y 626 ld Y Chunk # Get Chunk 627 lea X (Y III) # X on chunk buffer 628 add X (Y) # Count index 629 ld (X) B # Store byte 630 inc (Y) # Increment count 631 cmp (Y) CHUNK # Max reached? 632 if eq # Yes 633 call wrChunkY # Write buffer 634 end 635 pop Y 636 pop X 637 ret 638 639 # (ht:Out 'flg . prg) -> any 640 (code 'Out 2) 641 push X 642 ld X (E CDR) # Args 643 ld E (X) # Eval 'flg' 644 eval 645 ld X (X CDR) # X on 'prg' 646 cmp E Nil # 'flg? 647 if eq # No 648 prog X # Run 'prg' 649 else 650 push Y 651 ld Y Chunk # Get Chunk 652 ld (Y) 0 # Clear count 653 ld (Y II) (PutB) # Save current 'put' 654 ld (PutB) putChunkedB # Set new 655 prog X # Run 'prg' 656 null (Y) # Count? 657 if nz # Yes 658 call wrChunkY # Write rest 659 end 660 ld (PutB) (Y II) # Restore 'put' 661 ld C Newlines # Output termination string 662 call outStringC 663 pop Y 664 end 665 ld A (OutFile) # Flush OutFile 666 call flushA_F # OK? 667 pop X 668 ret 669 670 # vi:et:ts=3:sw=3