123 lines
3.1 KiB
Forth
123 lines
3.1 KiB
Forth
\ *****************************************************************************
|
|
\ * Copyright (c) 2004, 2008 IBM Corporation
|
|
\ * All rights reserved.
|
|
\ * This program and the accompanying materials
|
|
\ * are made available under the terms of the BSD License
|
|
\ * which accompanies this distribution, and is available at
|
|
\ * http://www.opensource.org/licenses/bsd-license.php
|
|
\ *
|
|
\ * Contributors:
|
|
\ * IBM Corporation - initial implementation
|
|
\ ****************************************************************************/
|
|
|
|
0 VALUE char-height
|
|
0 VALUE char-width
|
|
0 VALUE fontbytes
|
|
|
|
CREATE display-emit-buffer 20 allot
|
|
|
|
\ \\\\\\\\\\\\\\ Global Data
|
|
|
|
\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
|
|
|
|
\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
|
|
\ *
|
|
\ *
|
|
defer dis-old-emit
|
|
' emit behavior to dis-old-emit
|
|
|
|
: display-write terminal-write ;
|
|
: display-emit dup dis-old-emit display-emit-buffer tuck c! 1 terminal-write drop ;
|
|
|
|
\ \\\\\\\\\\\\\\ Exported Interface:
|
|
\ *
|
|
\ Generic device methods:
|
|
\ *
|
|
|
|
|
|
\ \\\\\\\\\\\\\\ Exported Interface:
|
|
\ *
|
|
\ IEEE 1275 : display device driver initialization
|
|
\ *
|
|
: is-install ( 'open -- )
|
|
s" defer vendor-open to vendor-open" eval
|
|
s" : open deadbeef vendor-open dup deadbeef = IF drop true ELSE nip THEN ;" eval
|
|
s" defer write ' display-write to write" eval
|
|
s" : draw-logo ['] draw-logo CATCH IF 2drop 2drop THEN ;" eval
|
|
s" : reset-screen ['] reset-screen CATCH drop ;" eval
|
|
;
|
|
|
|
: is-remove ( 'close -- )
|
|
s" defer close to close" eval
|
|
;
|
|
|
|
: is-selftest ( 'selftest -- )
|
|
s" defer selftest to selftest" eval
|
|
;
|
|
|
|
|
|
STRUCT
|
|
cell FIELD font>addr
|
|
cell FIELD font>width
|
|
cell FIELD font>height
|
|
cell FIELD font>advance
|
|
cell FIELD font>min-char
|
|
cell FIELD font>#glyphs
|
|
CONSTANT /font
|
|
|
|
CREATE default-font-ctrblk /font allot default-font-ctrblk
|
|
dup font>addr 0 swap !
|
|
dup font>width 8 swap !
|
|
dup font>height -10 swap !
|
|
dup font>advance 1 swap !
|
|
dup font>min-char 20 swap !
|
|
font>#glyphs 7f swap !
|
|
|
|
: display-default-font ( str len -- )
|
|
romfs-lookup dup 0= IF drop EXIT THEN
|
|
600 <> IF ." Only support 60x8x16 fonts ! " drop EXIT THEN
|
|
default-font-ctrblk font>addr !
|
|
;
|
|
|
|
s" default-font.bin" display-default-font
|
|
|
|
\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
|
|
\ *
|
|
\ *
|
|
|
|
|
|
\ \\\\\\\\\\\\\\ Exported Interface:
|
|
\ *
|
|
\ Generic device methods:
|
|
\ *
|
|
: .scan-lines ( height -- scanlines ) dup 0>= IF 1- ELSE negate THEN ;
|
|
|
|
|
|
\ \\\\\\\\\\\\\\ Exported Interface:
|
|
\ *
|
|
\ *
|
|
|
|
: set-font ( addr width height advance min-char #glyphs -- )
|
|
default-font-ctrblk /font + /font 0
|
|
DO
|
|
1 cells - dup >r ! r> 1 cells
|
|
+LOOP drop
|
|
default-font-ctrblk dup font>height @ abs to char-height
|
|
dup font>width @ to char-width font>advance @ to fontbytes
|
|
;
|
|
|
|
: >font ( char -- addr )
|
|
dup default-font-ctrblk dup >r font>min-char @ dup r@ font>#glyphs + within
|
|
IF
|
|
r@ font>min-char @ -
|
|
r@ font>advance @ * r@ font>height @ .scan-lines *
|
|
r> font>addr @ +
|
|
ELSE
|
|
drop r> font>addr @
|
|
THEN
|
|
;
|
|
|
|
: default-font ( -- addr width height advance min-char #glyphs )
|
|
default-font-ctrblk /font 0 DO dup cell+ >r @ r> 1 cells +LOOP drop
|
|
;
|
|
|