dsforth/main_emit_common.zas

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; common printing routines
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5   $IF USE_EMIT_DRIVER_AS_DEFAULT == 6
   6 $FORTH_VALUE CONWIDTH emit6_line_width
   7   $ELSE
   8 $FORTH_VALUE CONWIDTH 32
   9   $ENDIF
  10 conwidth_addr: equ $-2
  11
  12 $FORTH_CONST SV-ATTR-P emit6_attrp
  13
  14 emit_allowattr: defb 1
  15
  16
  17
  18 ;; defered words for printer driver
  19 $FORTH_DEFER EMIT       NOOP  ;;EMIT6
  20 $FORTH_DEFER XEMIT      NOOP  ;;XEMIT6
  21 $FORTH_DEFER WHEREX     NOOP  ;;WHEREX6
  22 $FORTH_DEFER WHEREY     NOOP  ;;WHEREY6
  23 $FORTH_DEFER GOTOXY     NOOP  ;;GOTOXY6
  24 $FORTH_DEFER GOTOXY16   NOOP  ;;GOTOXY6_16
  25 $FORTH_DEFER WHEREXY16  NOOP  ;;WHEREXY6_16
  26
  27 $FORTH_WORD EMIT6?
  28 ;; k8
  29 ;; ( -- )
  30   CONWIDTH LIT 32 <> ;S
  31 $FORTH_END_WORD EMIT6?
  32
  33 $FORTH_WORD EMIT8?
  34 ;; k8
  35 ;; ( -- )
  36   CONWIDTH LIT 32 = ;S
  37 $FORTH_END_WORD EMIT8?
  38
  39   $IF USE_EMIT6_DRIVER
  40 $FORTH_WORD SET-EMIT6
  41 ;; k8
  42 ;; ( -- )
  43   ['] EMIT6 TO EMIT
  44   ['] XEMIT6 TO XEMIT
  45  $IF forthexists("WHEREX6")
  46   ['] WHEREX6 TO WHEREX
  47  $ENDIF
  48  $IF forthexists("WHEREY6")
  49   ['] WHEREY6 TO WHEREY
  50  $ENDIF
  51  $IF forthexists("GOTOXY6")
  52   ['] GOTOXY6 TO GOTOXY
  53  $ENDIF
  54  $IF forthexists("GOTOXY6_16")
  55   ['] GOTOXY6_16 TO GOTOXY16
  56  $ENDIF
  57  $IF forthexists("WHEREXY6_16")
  58   ['] WHEREXY6_16 TO WHEREXY16
  59  $ENDIF
  60   LIT emit6_line_width TO CONWIDTH
  61   ;S
  62 $FORTH_END_WORD SET-EMIT6
  63   $ENDIF
  64
  65   $IF USE_EMIT8_DRIVER
  66 $FORTH_WORD SET-EMIT8
  67 ;; k8
  68 ;; ( -- )
  69   ['] EMIT8 TO EMIT
  70   ['] XEMIT8 TO XEMIT
  71  $IF forthexists("WHEREX8")
  72   ['] WHEREX8 TO WHEREX
  73  $ENDIF
  74  $IF forthexists("WHEREY8")
  75   ['] WHEREY8 TO WHEREY
  76  $ENDIF
  77  $IF forthexists("GOTOXY8")
  78   ['] GOTOXY8 TO GOTOXY
  79  $ENDIF
  80  $IF forthexists("GOTOXY8_16")
  81   ['] GOTOXY8_16 TO GOTOXY16
  82  $ENDIF
  83  $IF forthexists("WHEREXY8_16")
  84   ['] WHEREXY8_16 TO WHEREXY16
  85  $ENDIF
  86   LIT 32 TO CONWIDTH
  87   ;S
  88 $FORTH_END_WORD SET-EMIT8
  89   $ENDIF
  90
  91 ;; doesn't do CR if the cursor is at 0 col
  92 $FORTH_WORD ENDCR
  93 ;; k8
  94 ;; ( -- )
  95   2 EMIT
  96   ;S
  97 $FORTH_END_WORD ENDCR
  98
  99
 100 ;; scroll up
 101 emit_do_scroll_subr:
 102   call  #0DFE    ;; CL-SC-ALL
 103   ; set attribute for the lower part
 104   ld    hl,scrattr8x8(0,23)
 105   ld    de,scrattr8x8(1,23)
 106   ld    a,(emit6_attrp)
 107   ld    (hl),a
 108   ld    bc,31
 109   ldir
 110   ret
 111
 112
 113 $FORTH_CODE_WORD TATTRS
 114 ;; k8
 115 ;; ( flag -- )
 116 ;; allow attr setting
 117   pop   hl
 118   ld    a,h
 119   or    l
 120   jr    z,fword_tattrz_zero
 121   ld    a,1
 122 fword_tattrz_zero:
 123   ld    (emit_allowattr),a
 124   jp    i_next
 125 $FORTH_END_CODE_WORD TATTRS
 126
 127 $FORTH_CODE_WORD TATTRS?
 128 ;; k8
 129 ;; ( -- flag )
 130   ld    a,(emit_allowattr)
 131   ld    l,a
 132   ld    h,0
 133   jp    i_pushhl
 134 $FORTH_END_CODE_WORD TATTRS?
 135
 136
 137 $FORTH_CODE_WORD TOVER
 138 ;; k8
 139 ;; ( n -- )
 140   IF USE_EMIT8_DRIVER
 141   xor   a
 142   ld    (fword_xemit8_over0),a
 143   ld    (fword_xemit8_over1),a
 144   ld    (fword_xemit8_over2),a
 145   ENDIF
 146   IF USE_EMIT6_DRIVER
 147   ld    hl,draw6CharMask
 148   ld    (hl),#03
 149   ENDIF
 150   pop   de
 151   ld    a,e
 152   or    a
 153   jr    z,tover0
 154   IF USE_EMIT6_DRIVER
 155   ld    (hl),#FF
 156   ENDIF
 157   dec   a
 158   jr    z,tover1
 159 ;; mode 2 (OR)
 160   IF USE_EMIT8_DRIVER
 161   ld    a,#B6  ; or (hl)
 162   ld    (fword_xemit8_over0),a
 163   ld    (fword_xemit8_over1),a
 164   ld    (fword_xemit8_over2),a
 165   ENDIF
 166   IF USE_EMIT6_DRIVER
 167   ld    a,#B2
 168   ld    (draw6PutALU0),a
 169   ENDIF
 170   jr    tover2
 171 tover1:
 172 ;; mode 1 (XOR)
 173   IF USE_EMIT8_DRIVER
 174   ld    a,#AE  ; xor (hl)
 175   ld    (fword_xemit8_over0),a
 176   ld    (fword_xemit8_over1),a
 177   ld    (fword_xemit8_over2),a
 178   ENDIF
 179   IF USE_EMIT6_DRIVER
 180   ld    a,#AA
 181   ld    (draw6PutALU0),a
 182   ENDIF
 183 tover2:
 184   IF USE_EMIT6_DRIVER
 185   inc   a
 186   ld    (draw6PutALU1),a
 187   ENDIF
 188 tover0:
 189   jp    i_next
 190 $FORTH_END_CODE_WORD TOVER
 191
 192 $FORTH_CODE_WORD TOVER?
 193 ;; k8
 194 ;; ( n -- )
 195   IF USE_EMIT8_DRIVER
 196   ld    a,(fword_xemit8_over0)
 197   or    a
 198   jp    z,i_push_zero
 199   cp    #AE  ; xor (hl)
 200   ld    hl,1
 201   jp    z,i_pushhl
 202   inc   hl
 203   jp    i_pushhl
 204   ELSE
 205   ld    a,(draw6CharMask)
 206   cp    #03
 207   jp    z,i_push_zero
 208   ld    a,(draw6PutALU0)
 209   ld    hl,1
 210   cp    #AA
 211   jp    z,i_pushhl
 212   inc   hl
 213   jp    i_pushhl
 214   ENDIF
 215 $FORTH_END_CODE_WORD TOVER?
 216
 217 $FORTH_CODE_WORD TINV
 218 ;; k8
 219 ;; ( n -- )
 220   pop   de
 221   ld    a,e
 222   or    a
 223   jr    z,tinv0
 224   ld    a,#FC
 225 tinv0:
 226   IF USE_EMIT6_DRIVER
 227   ld    (draw6InvMask),a
 228   ENDIF
 229   IF USE_EMIT8_DRIVER
 230   or    a
 231   jr    z,tinv_okmask8
 232   ld    a,#2F  ; cpl
 233 tinv_okmask8:
 234   ld    (fword_xemit8_inv0),a
 235   ld    (fword_xemit8_inv1),a
 236   ld    (fword_xemit8_inv2),a
 237   ; done with emit8
 238   ENDIF
 239   jp    i_next
 240 $FORTH_END_CODE_WORD TINV
 241
 242 $FORTH_CODE_WORD TINV?
 243 ;; k8
 244 ;; ( -- n )
 245   IF USE_EMIT6_DRIVER
 246   ld    a,(draw6InvMask)
 247   ELSE
 248   ld    (fword_xemit8_inv0),a
 249   ENDIF
 250   or    a
 251   jp    z,i_push_zero
 252   jp    i_push_one
 253 $FORTH_END_CODE_WORD TINV?
 254
 255 ;; 0: none
 256 ;; 1: bold
 257 ;; 2: half-bold
 258 $FORTH_CODE_WORD TBOLD
 259 ;; k8
 260 ;; ( n -- )
 261   pop   hl
 262   IF USE_EMIT8_DRIVER
 263   ld    a,l
 264   ld    (emit8_bold),a
 265   ENDIF
 266   jp    i_next
 267 $FORTH_END_CODE_WORD TBOLD
 268
 269 $FORTH_CODE_WORD TBOLD?
 270 ;; k8
 271 ;; ( -- n )
 272   IF USE_EMIT8_DRIVER
 273   ld    hl,(emit8_bold)
 274   ld    h,0
 275   jp    i_next
 276   ENDIF
 277   jp    i_push_zero
 278 $FORTH_END_CODE_WORD TBOLD?
 279
 280   IF 1
 281 $FORTH_WORD AAA
 282 ;; k8
 283 ;; ( -- )
 284   ENDCR
 285   LIT 256 0 (DO)
 286 fword_emittest_aaa_loop:
 287     I XEMIT
 288     I LIT 15 AND LIT 15 = 0BRANCH fword_emittest_aaa_skip
 289     ENDCR
 290 fword_emittest_aaa_skip:
 291   (LOOP) fword_emittest_aaa_loop
 292   ;S
 293 $FORTH_END_WORD AAA
 294   ENDIF
 295
 296 ;; clear screen
 297 $FORTH_CODE_WORD CLS
 298 ;; AberSoft, k8
 299 docls6:
 300   ld    hl,0
 301   IF USE_EMIT6_DRIVER
 302   ld    (emit6y),hl
 303   ENDIF
 304   IF USE_EMIT8_DRIVER
 305   ld    (emit8_coordx),hl
 306   ENDIF
 307   push  bc
 308   ld    a,2
 309   call  #1601
 310   call  #0D6B
 311   pop   bc
 312   jp    i_next
 313 $FORTH_END_CODE_WORD CLS
 314
 315
 316 ;; scroll up
 317 $FORTH_CODE_WORD VSCROLL
 318 ;; k8
 319 ;; ( -- )
 320   push  bc
 321   call  emit_do_scroll_subr
 322   pop   bc
 323   jp    i_next
 324 $FORTH_END_CODE_WORD VSCROLL
 325
 326
 327 $FORTH_WORD CR
 328 ;; k8
 329 ;; ( -- )
 330   CHCR EMIT CHLF EMIT ;S
 331 $FORTH_END_WORD CR
 332
 333 $FORTH_WORD EMITCR
 334 ;; k8
 335 ;; ( -- )
 336   CHCR EMIT ;S
 337 $FORTH_END_WORD EMITCR
 338
 339 $FORTH_WORD EMITBS
 340 ;; k8
 341 ;; ( -- )
 342   LIT 8 EMIT ;S
 343 $FORTH_END_WORD EMITBS
 344
 345 $FORTH_WORD VTAB
 346 ;; k8
 347 ;; ( -- )
 348   CHLF EMIT ;S
 349 $FORTH_END_WORD VTAB
 350
 351 $FORTH_WORD HTAB
 352 ;; k8
 353 ;; ( -- )
 354   LIT 9 EMIT ;S
 355 $FORTH_END_WORD HTAB
 356
 357 $FORTH_WORD SPACE
 358 ;; k8
 359 ;; ( -- )
 360   BL EMIT ;S
 361 $FORTH_END_WORD SPACE
 362
 363
 364 $FORTH_WORD SPACES
 365 ;; k8
 366 ;; ( n -- )
 367   DUP 0> 0BRANCH fword_spaces_err
 368   0 (DO)
 369 fword_spaces_loop:
 370     SPACE
 371   (LOOP) fword_spaces_loop
 372   ;S
 373 fword_spaces_err:
 374   DROP
 375   ;S
 376 $FORTH_END_WORD SPACES
 377
 378
 379 $FORTH_WORD TYPE
 380 ;; AberSoft, k8
 381 ;; ( addr len -- )
 382   DUP 0> 0BRANCH fword_type_err
 383   OVER + SWAP (DO)
 384 fword_type_loop:
 385     I C@ EMIT
 386   (LOOP) fword_type_loop
 387   ;S
 388 fword_type_err:
 389   2DROP
 390   ;S
 391 $FORTH_END_WORD TYPE
 392
 393 $FORTH_WORD XTYPE
 394 ;; AberSoft, k8
 395 ;; ( addr len -- )
 396   DUP 0> 0BRANCH fword_xtype_err
 397   OVER + SWAP (DO)
 398 fword_xtype_loop:
 399     I C@ XEMIT
 400   (LOOP) fword_xtype_loop
 401   ;S
 402 fword_xtype_err:
 403   2DROP
 404   ;S
 405 $FORTH_END_WORD XTYPE
 406
 407
 408 $FORTH_CODE_WORD PAPER?
 409 ;; k8
 410 ;; ( -- n )
 411   ld    a,(emit6_attrp)
 412   and   0o0070
 413   rrca
 414   rrca
 415   rrca
 416   jp    i_pusha
 417 $FORTH_END_CODE_WORD PAPER?
 418
 419 $FORTH_CODE_WORD PAPER
 420 ;; k8
 421 ;; ( n -- )
 422   pop   de
 423   ld    a,e
 424   and   7
 425   rlca
 426   rlca
 427   rlca
 428   ld    e,a
 429   ld    hl,emit6_attrp
 430   ld    a,(hl)
 431   and   0o0307
 432   or    e
 433   ld    (hl),a
 434   jp    i_next
 435 $FORTH_END_CODE_WORD PAPER
 436
 437 $FORTH_CODE_WORD INK?
 438 ;; k8
 439 ;; ( -- n )
 440   ld    a,(emit6_attrp)
 441   and   0o0007
 442   jp    i_pusha
 443 $FORTH_END_CODE_WORD INK?
 444
 445 $FORTH_CODE_WORD INK
 446 ;; k8
 447 ;; ( n -- )
 448   pop   de
 449   ld    a,e
 450   and   7
 451   ld    e,a
 452   ld    hl,emit6_attrp
 453   ld    a,(hl)
 454   and   0o0370
 455   or    e
 456   ld    (hl),a
 457   jp    i_next
 458 $FORTH_END_CODE_WORD INK
 459
 460 $FORTH_CODE_WORD FLASH?
 461 ;; k8
 462 ;; ( -- n )
 463   ld    a,(emit6_attrp)
 464   and   0o0200
 465   jp    z,i_push_zero
 466   jp    i_push_one
 467 $FORTH_END_CODE_WORD FLASH?
 468
 469 $FORTH_CODE_WORD FLASH
 470 ;; k8
 471 ;; ( n -- )
 472   pop   de
 473   ld    a,e
 474   or    a
 475   jr    z,fword_flash_zero
 476   ld    e,0o0200
 477 fword_flash_zero:
 478   ld    hl,emit6_attrp
 479   ld    a,(hl)
 480   and   0o0177
 481   or    e
 482   ld    (hl),a
 483   jp    i_next
 484 $FORTH_END_CODE_WORD FLASH
 485
 486 $FORTH_CODE_WORD BRIGHT?
 487 ;; k8
 488 ;; ( -- n )
 489   ld    a,(emit6_attrp)
 490   and   0o0100
 491   jp    z,i_push_zero
 492   jp    i_push_one
 493 $FORTH_END_CODE_WORD BRIGHT?
 494
 495 $FORTH_CODE_WORD BRIGHT
 496 ;; k8
 497 ;; ( n -- )
 498   pop   de
 499   ld    a,e
 500   or    a
 501   jr    z,fword_bright_zero
 502   ld    e,0o0100
 503 fword_bright_zero:
 504   ld    hl,emit6_attrp
 505   ld    a,(hl)
 506   and   0o0277
 507   or    e
 508   ld    (hl),a
 509   jp    i_next
 510 $FORTH_END_CODE_WORD BRIGHT
 511
 512
 513 $FORTH_CODE_WORD BORDER
 514 ;; AberSoft
 515 ;; ( c -- )
 516   pop   hl
 517   push  bc
 518   ld    a,l
 519   call  #2297
 520   pop   bc
 521   jp    i_next
 522 $FORTH_END_CODE_WORD BORDER