bootstrap.fs

open source bios with linux platform, very good and can be reused.

\ tag: bootstrap of basic forth words
\ 
\ Copyright (C) 2003-2005 Stefan Reinauer, Patrick Mauritz
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\ 

\ 
\ this file contains almost all forth words described
\ by the open firmware user interface. Some more complex
\ parts are found in seperate files (memory management,
\ vocabulary support)
\ 

\ 
\ often used constants (reduces dictionary size)
\ 

1 constant 1
2 constant 2
3 constant 3
-1 constant -1
0 constant 0

0 value my-self

\ 
\ 7.3.5.1 Numeric-base control
\ 

: decimal 10 base ! ;
: hex 16 base ! ;
: octal 8 base ! ;
hex

\ 
\ vocabulary words
\ 

variable current forth-last current !

: last 
  current @ 
  ;

variable #order 0 #order !

defer context
0 value vocabularies?

\ 
\ 7.3.7 Flag constants
\ 

1 1 = constant true
0 1 = constant false

\ 
\ 7.3.9.2.2 Immediate words (part 1)
\ 

: (immediate) ( xt -- )
  1 - dup c@ 1 or swap c!
  ;

: (compile-only)
  1 - dup c@ 2 or swap c!
  ;

: immediate 
  last @ (immediate) 
  ;
  
: compile-only 
  last @ (compile-only) 
  ;

: flags? ( xt -- flags )
  /n /c + - c@ 7f and
  ;

: immediate? ( xt -- true|false )
  flags? 1 and 1 =
  ;

: compile-only? ( xt -- true|false )
  flags? 2 and 2 =
  ;

: [  0 state ! ; compile-only
: ] -1 state ! ; 



\ 
\ 7.3.9.2.1 Data space allocation
\ 

: allot here + here! ;
: ,  here /n allot ! ;
: c, here /c allot c! ;

: align
  /n here /n 1 - and -   \ how many bytes to next alignment
  /n 1 - and allot       \ mask out everything that is bigger 
  ;                      \ than cellsize-1

: null-align
  here dup align here swap - 0 fill 
  ;

: w, 
  here 1 and allot       \ if here is not even, we have to align.
  here /w allot w! 
  ;

: l, 
  /l here /l 1 - and -   \ same as in align, with /l
  /l 1 - and             \ if it's /l we are already aligned.
  allot
  here /l allot l! 
  ;


\ 
\ 7.3.6 comparison operators (part 1)
\ 

: <> = invert ;


\ 
\ 7.3.9.2.4 Miscellaneous dictionary (part 1)
\ 

: (to) ( xt-new xt-defer -- )
  /n + !
  ;

: >body ( xt -- a-addr )  /n 1 lshift + ;
: body> ( a-addr -- xt )  /n 1 lshift - ;

: reveal latest @ last ! ;
: recursive reveal ; immediate
: recurse latest @ /n +  , ; immediate

: noop ;

defer environment?
: no-environment?
  2drop false 
  ;

['] no-environment? ['] environment? (to)


\ 
\ 7.3.8.1 Conditional branches
\ 

: resolve-orig here over /n + - swap ! ;
: (if) ['] do?branch , here 0 , ; compile-only
: (then) resolve-orig ; compile-only

variable tmp-comp-depth -1 tmp-comp-depth !
variable tmp-comp-buf 0 tmp-comp-buf !

: setup-tmp-comp ( -- )
  state @ 0 = (if)
    here tmp-comp-buf @ here! ,     \ save here and switch to tmp directory
    1 ,                              \ DOCOL
    depth tmp-comp-depth !          \ save control depth
    ]
  (then)
;

: execute-tmp-comp ( -- )
  depth tmp-comp-depth @ =
  (if)
    -1 tmp-comp-depth !
    ['] (semis) ,
    tmp-comp-buf @
    dup @ here!
    0 state !
    /n + execute
  (then)
;

: if setup-tmp-comp ['] do?branch , here 0 , ; immediate
: then resolve-orig execute-tmp-comp ; compile-only
: else ['] dobranch , here 0 , swap resolve-orig ; compile-only

\ 
\ 7.3.8.3 Conditional loops
\ 

\ some dummy words for see
: (begin) ;
: (again) ;
: (until) ;
: (while) ;
: (repeat) ;

: resolve-dest here /n + - , ;

: begin 
  setup-tmp-comp
  ['] (begin) , 
  here 
  ; immediate
  
: again 
  ['] (again) ,
  ['] dobranch , 
  resolve-dest
  execute-tmp-comp
  ; compile-only
  
: until 
  ['] (until) ,
  ['] do?branch , 
  resolve-dest 
  execute-tmp-comp
  ; compile-only
  
: while
  setup-tmp-comp
  ['] (while) ,
  ['] do?branch , 
  here 0 , swap  
  ; immediate
  
: repeat 
  ['] (repeat) ,
  ['] dobranch , 
  resolve-dest resolve-orig
  execute-tmp-comp
  ; compile-only

\ 
\ 7.3.8.4 Counted loops
\ 

variable leaves 0 leaves !

: resolve-loop
  leaves @
  begin
    ?dup 
  while 
    dup @               \ leaves -- leaves *leaves )
    swap                \ -- *leaves leaves )
    here over -         \ -- *leaves leaves here-leaves
    swap !              \ -- *leaves
  repeat
  here - , 
  leaves !
  ;

: do 
  setup-tmp-comp
  leaves @ here
  ['] (do) , 
  0 leaves !
  ; immediate

: ?do
  setup-tmp-comp
  leaves @ 
  ['] (?do) ,
  here 
  here leaves !
  0 ,
  ; immediate

: loop
  ['] (loop) ,
  resolve-loop
  execute-tmp-comp
  ; compile-only

: +loop
  ['] (+loop) ,
  resolve-loop
  execute-tmp-comp
  ; compile-only

\ Using primitive versions of i and j
\ speeds up loops by 300%
\ : i r> r@ swap >r ;
\ : j r> r> r> r@ -rot >r >r swap >r ;

: unloop r> r> r> 2drop >r ;

: leave 
  ['] unloop , 
  ['] dobranch , 
  leaves @ 
  here leaves !  
  , 
  ; compile-only

: ?leave if leave then ;

\ 
\ 7.3.8.2  Case statement
\ 
 
: case
  setup-tmp-comp
  0
; immediate

: endcase 
  ['] drop , 
  0 ?do 
    ['] then execute
  loop
  execute-tmp-comp
; compile-only

: of 
  1 + >r 
  ['] over , 
  ['] = , 
  ['] if execute 
  ['] drop , 
  r> 
  ; compile-only

: endof 
  >r 
  ['] else execute 
  r> 
  ; compile-only


\ 
\ 7.3.8.5    Other control flow commands
\ 

: exit r> drop ;


\ 
\ 7.3.4.3 ASCII constants (part 1)
\ 

20 constant bl
07 constant bell
08 constant bs
0d constant carret
0a constant linefeed


\ 
\ 7.3.1.1 - stack duplication
\ 
: tuck swap over ;
: 3dup 2 pick 2 pick 2 pick ;

\ 
\ 7.3.1.2 - stack removal
\ 
: clear 0 depth! ;
: 3drop 2drop drop ;

\ 
\ 7.3.1.3 - stack rearrangement
\ 

: 2rot >r >r 2swap r> r> 2swap ;

\ 
\ 7.3.2.1 - single precision integer arithmetic (part 1)
\ 

: u/mod 0 swap mu/mod drop ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: even 1+ -2 and ;
: bounds over + swap ;

\ 
\ 7.3.2.2 bitwise logical operators
\ 
: << lshift ;
: >> rshift ;
: 2* 1 lshift ;
: u2/ 1 rshift ;
: 2/ 1 >>a ;
: not invert ;

\ 
\ 7.3.2.3 double number arithmetic
\ 

: s>d      dup 0 < ; 
: dnegate  0 0 2swap d- ;
: dabs     dup 0 < if dnegate then ;
: um/mod   mu/mod drop ;

\ symmetric division
: sm/rem  ( d n -- rem quot )
  over >r >r dabs r@ abs um/mod r> 0 < 
  if 
    negate 
  then 
  r> 0 < if 
    negate swap negate swap
  then
  ;

\ floored division
: fm/mod ( d n -- rem quot ) 
  dup >r 2dup xor 0 < >r sm/rem over 0 <> r> and if 
    1 - swap r> + swap exit 
  then
  r> drop
  ;

\ 
\ 7.3.2.1 - single precision integer arithmetic (part 2)
\ 

: */mod ( n1 n2 n3 -- quot rem ) >r m* r> fm/mod  ;
: */ ( n1 n2 n3 -- n1*n2/n3 ) */mod nip ;
: /mod >r s>d r> fm/mod ;
: mod /mod drop ;
: / /mod nip ;


\ 
\ 7.3.2.4 Data type conversion
\ 

: lwsplit ( quad -- w.lo w.hi )
  dup ffff and swap 10 rshift ffff and
;

: wbsplit ( word -- b.lo b.hi )
  dup ff and swap 8 rshift ff and
;

: lbsplit ( quad -- b.lo b2 b3 b.hi )
  lwsplit swap wbsplit rot wbsplit
;

: bwjoin ( b.lo b.hi -- word )
  ff and 8 lshift swap ff and or
;

: wljoin ( w.lo w.hi -- quad )
  ffff and 10 lshift swap ffff and or
;

: bljoin ( b.lo b2 b3 b.hi -- quad )
  bwjoin -rot bwjoin swap wljoin
;

: wbflip ( word -- word ) \ flips bytes in a word
  dup 8 rshift ff and swap ff and bwjoin
;

: lwflip ( q1 -- q2 ) 
  dup 10 rshift ffff and swap ffff and wljoin
;

: lbflip ( q1 -- q2 )
  dup 10 rshift ffff and wbflip swap ffff and wbflip wljoin
;

\ 
\ 7.3.2.5 address arithmetic
\ 

: /c* /c * ;
: /w* /w * ;
: /l* /l * ;
: /n* /n * ;
: ca+ /c* + ;
: wa+ /w* + ;
: la+ /l* + ;
: na+ /n* + ;
: ca1+ /c + ;
: wa1+ /w + ;
: la1+ /l + ;
: na1+ /n + ;
: aligned /n 1- + /n negate and ;
: char+ ca1+ ;
: cell+ na1+ ;
: chars /c* ;
: cells /n* ;
/n constant cell

\ 
\ 7.3.6 Comparison operators
\ 

: <= > not ;
: >= < not ;
: 0= 0 = ;
: 0<= 0 <= ;
: 0< 0 < ;
: 0<> 0 <> ;
: 0> 0 > ;
: 0>=  0 >= ;
: u<= u> not ;
: u>= u< not ;
: within  >r over > swap r> >= or not ;
: between 1 + within ;

\ 
\ 7.3.3.1 Memory access
\ 

: 2@ dup cell+ @ swap @  ;
: 2! dup >r ! r> cell+ ! ;

: <w@ w@ dup 8000 >= if 10000 - then ;

: comp ( str1 str2 len -- 0|1|-1 )
  >r 0 -rot r>
  bounds ?do
    dup c@ i c@ - dup if
      < if 1 else -1 then swap leave
    then 
    drop ca1+
  loop
  drop
;

\ : +! tuck @ + swap ! ;
: off false swap ! ;
: on true swap ! ;
: blank bl fill ;
: erase 0 fill ;
: wbflips ( waddr len -- )
  bounds do i w@ wbflip i w! /w +loop
;

: lwflips ( qaddr len -- )
  bounds do i l@ lwflip i l! /l +loop
;

: lbflips ( qaddr len -- )
  bounds do i l@ lbflip i l! /l +loop
;


\ 
\ 7.3.8.6    Error handling (part 1)
\ 

variable catchframe
0 catchframe !

: catch
  my-self >r
  depth >r
  catchframe @ >r
  rdepth catchframe !
  execute
  r> catchframe !
  r> r> 2drop 0
  ;

: throw
  ?dup if
    catchframe @ rdepth!
    r> catchframe !
    r> swap >r depth!
    drop r>
    r> ['] my-self (to)
  then
  ;

\ 
\ 7.3.3.2 memory allocation
\ 

include memory.fs


\ 
\ 7.3.4.4 Console output (part 1)
\ 

defer emit

: type bounds ?do i c@ emit loop ;

\ this one obviously only works when called 
\ with a forth string as count fetches addr-1.
\ openfirmware has no such req. therefore it has to go:

\ : type 0 do count emit loop drop ;


\ 
\ 7.3.4.1 Text Input
\ 

0 value source-id 
0 value ib
variable #ib 0 #ib !
variable >in 0 >in !

: source ( -- addr len )
  ib #ib @
  ;

: /string  ( c-addr1 u1 n -- c-addr2 u2 )
   tuck - -rot + swap 
; 


\ 
\ pockets implementation for 7.3.4.1

100 constant pocketsize
variable pockets 0 pockets !
variable whichpocket 0 whichpocket !

\ allocate 2 pockets to begin with
: init-pockets     ( -- )
  pocketsize 2* alloc-mem pockets !
  ;

: pocket ( ?? -- ?? )
  pocketsize whichpocket @ *
  pockets @ +
  1 whichpocket @ -
  whichpocket !
  ;

\ span variable from 7.3.4.2
variable span 0 span !

\ if char is bl then any control character is matched
: findchar ( str len char -- offs true | false )
  swap 0 do
    over i + c@
    over dup bl = if <= else = then if
      2drop i dup dup leave
      \ i nip nip true exit \ replaces above
    then
  loop
  =
  \ drop drop false
  ;

: parse ( delim  text<delim>  -- str len )
  >r              \ save delimiter
  ib >in @ +
  span @ >in @ -  \ ib+offs len-offset.
  2dup r>         \ ib+offs len-offset ib+offs len-offset delim
  findchar if     \ look for the delimiter. 
    nip dup 1+
  else
     dup
  then
  >in +!
  \ dup -1 = if drop 0 then \ workaround for negative length
  ;

: skipws ( -- )
  ib span @        ( -- ib recvchars )
  begin
    dup >in @ > if    ( -- recvchars>offs )
      over >in @ +
      c@ bl <=
    else
      false
    then
  while
      1 >in +!
  repeat
  2drop
  ;

: parse-word (  < >text< >  -- str len )
  skipws bl parse
  ;

: word ( delim  <delims>text<delim>  -- pstr )
  pocket >r parse dup r@ c! bounds r> dup 2swap
  do
    char+ i c@ over c!
  loop
  drop
  ;

: ( 29 parse 2drop ; immediate
: \ span @ >in !   ; immediate



\ 
\ 7.3.4.7 String literals
\ 

: ",
  bounds ?do
    i c@ c,
  loop
  ;

: (")  ( -- addr len )
  r> dup 
  2 cells +                   ( r-addr addr )
  over cell+ @                ( r-addr addr len )
  rot over + aligned cell+ >r ( addr len R: r-addr )
  ;
 
: handle-text ( temp-addr len -- addr len )
  state @ if
    ['] (") , dup , ", null-align
  else
    pocket swap
    dup >r
    0 ?do
      over i + c@ over i + c!
    loop
    nip r>
  then
  ;

: s"
  22 parse handle-text
  ; immediate



\ 
\ 7.3.4.4 Console output (part 2)
\ 

: ."
  22 parse handle-text
  ['] type
  state @ if
    ,
  else
    execute
  then
  ; immediate