initial import of openbios--main--1.0--patch-26

git-svn-id: svn://coreboot.org/openbios/openbios-devel@1 f158a5a8-5612-0410-a976-696ce0be7e32

forth/bootstrap/build.xml

@@ -0,0 +1,16 @@
+<build>
+ <!--
+  build description for openbios forth bootstrap
+ 
+  Copyright (C) 2004-2005 by Stefan Reinauer
+  See the file "COPYING" for further information about
+  the copyright and warranty status of this work.
+  -->
+
+ <dictionary name="bootstrap">
+  <object source="start.fs" target="forth"/>
+ </dictionary>
+
+ <dictionary name="openbios" init="bootstrap"/>
+ 
+</build>

forth/bootstrap/builtin.fs

@@ -0,0 +1,30 @@
+\ tag: initialize builtin functionality
+\ 
+\ Copyright (C) 2003 Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+ 
+
+: init-builtin-terminal  ( -- )
+
+  \ define key, key? and emit
+  ['] (key) ['] key (to)
+  ['] (key?) ['] key? (to)
+  ['] (emit) ['] emit (to)
+
+  \ 2 bytes band guard on each side
+  100 #ib !
+  #ib @ dup             ( -- ibs ibs )
+  cell+ alloc-mem       ( -- ibs addr )
+  dup -rot              ( -- addr ibs addr )
+
+  /w + ['] ib (to)      \ assign input buffer
+  0 fill                \ erase tib
+  0 ['] source-id (to)  \ builtin terminal has id 0
+
+  ;
+
+

forth/bootstrap/interpreter.fs

@@ -0,0 +1,174 @@
+\ tag: forth interpreter
+\ 
+\ Copyright (C) 2003 Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+
+\ 
+\ 7.3.4.6 Display pause
+\ 
+
+0 value interactive?
+
+: exit?
+  interactive? 0= if
+    false exit
+  then
+  false \ FIXME we should check whether to interrupt output
+        \ and ask the user how to proceed.
+  ;
+
+
+\ 
+\ 7.3.9.1 Defining words
+\ 
+
+: forget 
+  s" This word is obsolescent." type cr
+  ['] ' execute
+  cell - dup 
+  @ dup 
+  last ! latest !
+  here!
+  ;
+ 
+\ 
+\ 7.3.9.2.4 Miscellaneous dictionary
+\ 
+
+\ interpreter. This word checks whether the interpreted word
+\ is a word in dictionary or a number. It honours compile mode 
+\ and immediate/compile-only words.
+
+: interpret 
+  0 >in !
+  begin
+    parse-word dup 0> \ was there a word at all?
+  while
+    $find 
+    if
+      dup flags? 0<> state @ 0= or if
+        execute
+      else
+        ,             \ compile mode && !immediate
+      then
+    else              \ word is not known. maybe it's a number
+      2dup $number
+      if
+        span @ >in !  \ if we encountered an error, don't continue parsing
+        type 3a emit
+	-13 throw
+      else
+        -rot 2drop 1 handle-lit
+      then
+    then
+    depth 200 >=  if -3 throw then 
+    depth 0<      if -4 throw then
+    rdepth 200 >= if -5 throw then 
+    rdepth 0<     if -6 throw then
+  repeat
+  2drop
+  ;
+
+: refill ( -- )
+	ib #ib @ expect 0 >in ! ;
+
+: print-status  ( exception -- )
+  space
+  ?dup if
+    dup sys-debug \ system debug hook
+    case 
+       -1 of s" Aborted." type endof
+       -2 of s" Aborted." type endof
+       -3 of s" Stack Overflow." type 0 depth! endof
+       -4 of s" Stack Underflow." type 0 depth! endof
+       -5 of s" Return Stack Overflow." type endof
+       -6 of s" Return Stack Underflow." type endof
+      -13 of s" undefined word." type endof
+      -15 of s" out of memory." type endof
+      -21 of s" undefined method." type endof
+      -22 of s" no such device." type endof
+      dup s" Exception #" type . 
+    endcase
+  else
+    state @ 0= if
+      s" ok"
+    else 
+      s" compiled"
+    then
+    type
+  then
+  cr
+  ;
+
+defer status
+['] noop ['] status (to)
+
+: print-prompt
+  status 
+  depth . 3e emit space
+  ;
+  
+defer outer-interpreter
+:noname
+  cr
+  begin
+    print-prompt
+    source 0 fill           \ clean input buffer
+    refill 
+
+    ['] interpret catch print-status
+  again
+; ['] outer-interpreter (to)
+
+\ 
+\ 7.3.8.5 Other control flow commands
+\ 
+
+: save-source  ( -- )
+  r>               \ fetch our caller
+  ib >r #ib @ >r   \ save current input buffer
+  source-id >r     \ and all variables 
+  span @ >r        \ associated with it.
+  >in @ >r
+  >r               \ move back our caller
+  ;
+
+: restore-source ( -- )
+  r> 
+  r> >in ! 
+  r> span ! 
+  r> ['] source-id (to) 
+  r> #ib ! 
+  r> ['] ib (to) 
+  >r
+  ;
+
+: (evaluate) ( str len -- ??? )
+  save-source
+  -1 ['] source-id (to)
+  dup
+  #ib ! span !
+  ['] ib (to)
+  interpret
+  restore-source
+  ; 
+
+: evaluate ( str len -- ?? )
+  2dup + -rot
+  over + over do 
+    i c@ 0a = if 
+      i over - 
+      (evaluate)
+      i 1+ 
+    then 
+  loop 
+  swap over - (evaluate)
+  ;
+  
+: eval evaluate ;
+
+

forth/bootstrap/memory.fs

@@ -0,0 +1,218 @@
+\ tag: forth memory allocation
+\ 
+\ Copyright (C) 2002-2003 Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+\ 7.3.3.2 memory allocation
+
+\ these need to be initialized by the forth kernel by now.
+variable start-mem 0 start-mem !	\ start of memory
+variable end-mem   0 end-mem   !	\ end of memory
+variable free-list 0 free-list !	\ free list head
+
+\ initialize necessary variables and write a valid 
+\ free-list entry containing all of the memory.
+\   start-mem: pointer to start of memory.
+\   end-mem:   pointer to end of memory.
+\   free-list: head of linked free list
+
+: init-mem ( start-addr size )
+  over dup
+  start-mem !		\ write start-mem 
+  free-list !		\ write first freelist entry
+  2dup /n - swap !	\ write 'len'  entry
+  over cell+ 0 swap !	\ write 'next' entry
+  + end-mem  !		\ write end-mem 
+  ;
+ 
+\ --------------------------------------------------------------------
+
+\ return pointer to smallest free block that contains 
+\ at least nb bytes and the block previous the the 
+\ actual block. On failure the pointer to the smallest
+\ free block is 0.
+
+: smallest-free-block ( nb -- prev ptr | 0 0 )
+  0 free-list @
+  fffffff 0 0 >r >r >r
+  begin
+    dup
+  while
+    ( nb prev pp R: best_nb best_pp )
+    dup @ 3 pick r@ within if
+      ( nb prev pp )
+      r> r> r> 3drop            \ drop old smallest
+      2dup >r >r dup @ >r       \ new smallest
+    then
+    nip dup                     \ prev = pp
+    cell + @                    \ pp = pp->next
+  repeat
+  3drop r> drop r> r>
+;
+
+
+\ --------------------------------------------------------------------
+
+\ allocate size bytes of memory
+\ return pointer to memory (or throws an exception on failure).
+
+: alloc-mem ( size -- addr )
+
+  \ make it legal (and fast) to allocate 0 bytes
+  dup 0= if exit then
+
+  aligned			\ keep memory aligned.
+  dup smallest-free-block	\ look up smallest free block.
+  
+  dup 0= if 
+    \ 2drop
+    -15 throw \ out of memory
+  then
+  
+  ( al-size prev addr )
+  
+  \ If the smallest fitting block found is bigger than
+  \ the size of the requested block plus 2*cellsize we
+  \ can split the block in 2 parts. otherwise return a
+  \ slightly bigger block than requested.
+
+  dup @ ( d->len ) 3 pick cell+ cell+ > if
+  
+    \ splitting the block in 2 pieces.
+    \ new block = old block + len field + size of requested mem
+    dup 3 pick cell+ +	(  al-size prev addr nd )
+
+    \ new block len = old block len - req. mem size - 1 cell
+    over @		( al-size prev addr nd addr->len )
+    4 pick		( ... al-size )
+    cell+ -		( al-size prev addr nd nd nd->len )
+    over !		( al-size prev addr nd )
+
+    over cell+ @	( al-size prev addr nd addr->next )
+    			\ write addr->next to nd->next
+    over cell+ !	( al-size prev addr nd )
+    over 4 pick swap !
+  else
+    \ don't split the block, it's too small.
+    dup cell+ @
+  then
+
+  ( al-size prev addr nd )
+
+  \ If the free block we got is the first one rewrite free-list
+  \ pointer instead of the previous entry's next field.
+  rot dup 0= if drop free-list else cell+ then
+  ( al-size addr nd prev->next|fl )
+  !
+  nip cell+	\ remove al-size and skip len field of returned pointer
+
+  ;
+
+
+\ --------------------------------------------------------------------
+  
+\ free block given by addr. The length of the
+\ given block is stored at addr - cellsize.
+\ 
+\ merge with blocks to the left and right 
+\ immediately, if they are free.
+
+: free-mem ( addr len -- )
+
+  \ we define that it is legal to free 0-byte areas
+  0= if drop exit then
+  ( addr )
+	
+  \ check if the address to free is somewhere within
+  \ our available memory. This fails badly on discontigmem
+  \ architectures. If we need more RAM than fits on one 
+  \ contiguous memory area we are too bloated anyways. ;)
+  
+  dup start-mem @ end-mem @ within 0= if
+ \   ." free-mem: no such memory: 0x" u. cr
+    exit
+  then
+
+  /n -				\ get real block address
+  0 free-list @			( addr prev l )
+  
+  begin				\ now scan the free list
+    dup 0<> if			\ only check len, if block ptr != 0
+      dup dup @ cell+ + 3 pick < 
+    else
+      false
+    then
+  while 
+    nip dup			\ prev=l
+    cell+ @			\ l=l->next
+  repeat
+
+  ( addr prev l )
+
+  dup 0<> if				\ do we have free memory to merge with?
+  
+    dup dup @ cell+ + 3 pick  = if	\ hole hit. adding bytes.
+      \ freeaddr = end of current block -> merge
+      ( addr prev l )
+      rot @ cell+		( prev l f->len+cellsize )
+      over @ +			\ add l->len
+      over !			( prev l )
+      swap over cell+ @		\ f = l; l = l->next;
+
+      \ The free list is sorted by addresses. When merging at the
+      \ start of our block we might also want to merge at the end
+      \ of it. Therefore we fall through to the next border check
+      \ instead of returning.
+      true				\ fallthrough value
+    else
+      false				\ no fallthrough
+    then
+    >r					\ store fallthrough on ret stack
+    
+    ( addr prev l )
+
+    dup 3 pick dup @ cell+ + = if	\ hole hit. real merging.
+      \ current block starts where block to free ends.
+      \ end of free block addr = current block -> merge and exit
+      					( addr prev l )
+      2 pick dup @			( f f->len ) 
+      2 pick @ cell+ +			( f newlen )
+      swap !				( addr prev l )
+      3dup drop
+      0= if
+	free-list
+      else
+	2 pick cell+ 
+      then				( value prev->next|free-list )
+      !					( addr prev l )
+      cell+ @ rot			( prev l->next addr )
+      cell+ ! drop
+      r> drop exit			\ clean up return stack
+    then
+
+    r> if 3drop exit then		\ fallthrough? -> exit
+  then
+  
+  \ loose block - hang it before current.
+
+  ( addr prev l )
+
+  \ hang block to free in front of the current entry.
+  dup 3 pick cell+ !			\ f->next = l;
+  free-list @ = if			\ is block to free new list head?
+    over free-list !
+  then
+  
+  ( addr prev )
+  dup 0<> if				\ if (prev) prev->next=f
+    cell+ !
+  else 
+    2drop				\ no fixup needed. clean up.
+  then
+    
+  ;
+
+

forth/bootstrap/start.fs

@@ -0,0 +1,69 @@
+\ tag: forth bootstrap starter.
+\ 
+\ Copyright (C) 2003 Patrick Mauritz, Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+include bootstrap.fs        \ all base words
+include interpreter.fs      \ interpreter
+include builtin.fs          \ builtin terminal.
+
+: include ( >filename<eol> -- )
+  linefeed parse $include
+;
+
+: encode-file ( >filename< > -- dictptr size )
+  parse-word $encode-file
+;
+
+: bye 
+  s" Farewell!" cr type cr cr 
+  0 rdepth! 
+  ;
+
+\ quit starts the outer interpreter of the forth system.
+\ zech describes quit as being the outer interpreter, but
+\ we split it apart to keep the interpreter elsewhere.
+
+: quit                      ( -- )
+  2 rdepth!
+  outer-interpreter
+;
+
+\ initialize is the first forth word run by the kernel.
+\ this word is automatically executed by the C core on start 
+\ and it's never left unless something goes really wrong or
+\ the user decides to leave the engine.
+
+variable init-chain
+
+\ :noname <definition> ; initializer
+: initializer ( xt -- )
+  here swap , 0 ,            \ xt, next
+  init-chain
+  begin dup @ while @ na1+ repeat
+  !
+;
+
+: initialize-forth          ( startmem endmem -- )
+  over - init-mem
+  init-pockets
+  init-tmp-comp
+  init-builtin-terminal
+
+  init-chain @              \ execute initializers
+  begin dup while
+    dup @ execute
+    na1+ @
+  repeat
+  drop
+;
+
+\ compiler entrypoint
+: initialize                ( startmem endmem -- )
+  initialize-forth
+  s" OpenBIOS kernel started." type cr
+  quit
+;