qemu/roms/SLOF/slof/fs/display.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2008 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13 0 VALUE char-height
  14 0 VALUE char-width
  15 0 VALUE fontbytes
  16
  17 CREATE display-emit-buffer 20 allot
  18
  19 \ \\\\\\\\\\\\\\ Global Data
  20
  21 \ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
  22
  23 \ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
  24 \ *
  25 \ *
  26 defer dis-old-emit
  27 ' emit behavior to dis-old-emit
  28
  29 : display-write terminal-write ;
  30 : display-emit dup dis-old-emit display-emit-buffer tuck c! 1 terminal-write drop ;
  31
  32 \ \\\\\\\\\\\\\\ Exported Interface:
  33 \ *
  34 \ Generic device methods:
  35 \ *
  36
  37
  38 \ \\\\\\\\\\\\\\ Exported Interface:
  39 \ *
  40 \ IEEE 1275 : display device driver initialization
  41 \ *
  42 : is-install ( 'open -- )
  43         s" defer vendor-open to vendor-open" eval
  44         s" : open deadbeef vendor-open dup deadbeef = IF drop true ELSE nip THEN ;" eval
  45         s" defer write ' display-write to write" eval
  46         s" : draw-logo ['] draw-logo CATCH IF 2drop 2drop THEN ;" eval
  47         s" : reset-screen ['] reset-screen CATCH drop ;" eval
  48 ;
  49
  50 : is-remove ( 'close -- )
  51         s" defer close to close" eval
  52 ;
  53
  54 : is-selftest ( 'selftest -- )
  55         s" defer selftest to selftest" eval
  56 ;
  57
  58
  59 STRUCT
  60         cell FIELD font>addr
  61         cell FIELD font>width
  62         cell FIELD font>height
  63         cell FIELD font>advance
  64         cell FIELD font>min-char
  65         cell FIELD font>#glyphs
  66 CONSTANT /font
  67
  68 CREATE default-font-ctrblk /font allot default-font-ctrblk
  69         dup font>addr 0 swap !
  70         dup font>width 8 swap !
  71         dup font>height -10 swap !
  72         dup font>advance 1 swap !
  73         dup font>min-char 20 swap !
  74         font>#glyphs 7f swap !
  75
  76 : display-default-font ( str len -- )
  77    romfs-lookup dup 0= IF drop EXIT THEN
  78    600 <> IF ." Only support 60x8x16 fonts ! " drop EXIT THEN
  79    default-font-ctrblk font>addr !
  80 ;
  81
  82 s" default-font.bin" display-default-font
  83
  84 \ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
  85 \ *
  86 \ *
  87
  88
  89 \ \\\\\\\\\\\\\\ Exported Interface:
  90 \ *
  91 \ Generic device methods:
  92 \ *
  93 : .scan-lines ( height -- scanlines ) dup 0>= IF 1- ELSE negate THEN ;
  94
  95
  96 \ \\\\\\\\\\\\\\ Exported Interface:
  97 \ *
  98 \ *
  99
 100 : set-font ( addr width height advance min-char #glyphs -- )
 101    default-font-ctrblk /font + /font 0
 102    DO
 103       1 cells - dup >r ! r> 1 cells
 104    +LOOP drop
 105    default-font-ctrblk dup font>height @ abs to char-height
 106    dup font>width @ to char-width font>advance @ to fontbytes
 107 ;
 108
 109 : >font ( char -- addr )
 110    dup default-font-ctrblk dup >r font>min-char @ dup r@ font>#glyphs + within
 111    IF
 112       r@ font>min-char @ -
 113       r@ font>advance @ * r@ font>height @ .scan-lines *
 114       r> font>addr @ +
 115    ELSE
 116       drop r> font>addr @
 117    THEN
 118 ;
 119
 120 : default-font ( -- addr width height advance min-char #glyphs )
 121     default-font-ctrblk /font 0 DO dup cell+ >r @ r> 1 cells +LOOP drop
 122 ;
 123