\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: dlbin.fth
\ 
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ 
\  - Do no alter or remove copyright notices
\ 
\  - Redistribution and use of this software in source and binary forms, with 
\    or without modification, are permitted provided that the following 
\    conditions are met: 
\ 
\  - Redistribution of source code must retain the above copyright notice, 
\    this list of conditions and the following disclaimer.
\ 
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution. 
\ 
\    Neither the name of Sun Microsystems, Inc. or the names of contributors 
\ may be used to endorse or promote products derived from this software 
\ without specific prior written permission. 
\ 
\     This software is provided "AS IS," without a warranty of any kind. 
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, 
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A 
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN 
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR 
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR 
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN 
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR 
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE 
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, 
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF 
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ 
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)dlbin.fth 2.14 97/08/11
purpose: 
copyright: Copyright 1990-1995 Sun Microsystems, Inc.  All Rights Reserved

\ Download a.out files over a serial line to a stand-alone Forth system.

decimal

headerless
headers

\ Move all these out of the way.
vocabulary dloader also dloader definitions

variable charbuf
variable dl.break
variable dl.read
variable dl.handle

: dl-call ( xxx -- xxx ) dl.handle @ call-package ;

: getbyte  ( -- char )
   begin dl.break @ dl-call charbuf 1 dl.read @ dl-call 0> until
   charbuf c@
;
: getbytes  ( adr len -- adr+len )
   over + tuck swap ?do  getbyte i c!  loop
;

: .cantfind ( adr,len -- true )
  ." Unable find " type ."  method" cr true
;

: setup-dload ( -- )
  0 0 ttya expand-alias drop		( 0 0 str,len )
  $open-package ?dup 0= if		( ihandle )
    ." ttya didn't open" cr		( -- )
    true exit				( -- )
  then dl.handle !			( ihandle )
  " read" 2dup				( str,len str,len )
  dl.handle @ ihandle>phandle		( str,len str,len phandle )
  find-method if			( str,len acf )
    dl.read !				( str,len )
    2drop " poll-tty" 2dup		( str,len str,len )
    dl.handle @ ihandle>phandle		( str,len str,len phandle )
    find-method if			( str,len acf )
      dl.break !			( str,len )
      2drop false exit			( false )
    then				( adr,len )
  then					( str,len )
  .cantfind				( -- true )
;

\ Throw out junk until we see the start of the header
: consume  ( -- )  begin  getbyte  1 =  until  ;

: gettext  ( adr len -- adr actual )
   bounds 2dup  ?do                  ( end start )
      getbyte  dup control D =  if   ( end start  char )
         drop  nip  i swap  leave    ( end' start )
      then                           ( end start  char )
      i c!
   loop                              ( end' start )
   tuck -                            ( adr actual )
;

previous definitions
also dloader
headers

: dlbin  ( -- )
   cleanup  setup-dload if exit then
   ." Ready for download.  Send binary file." cr
   consume
   1 a.out-header c!                    \ consume ate the first header byte
   a.out-header 1+  /a.out-header 1-  getbytes drop	\ Read the header

   \ Verify the magic number; if it's wrong, then you have to abort with
   \ a break character.
   a.out-header a_magic w@  h# 107 <>  if  begin getbyte drop  again  then

   entry-adr	      ( tadr )		\ Read the file segments
   /text   getbytes   ( dadr )
   /data   getbytes   ( radr )
   /reloc  l->n -1 <>  if  /reloc getbytes  then  ( sadr )
   /syms   getbytes   ( stradr )

   /syms  if                   ( string-table-adr )
      4  getbytes              ( rest-of-string-table-adr )
      dup 4 - @ 4 -  getbytes  ( string-table-end-adr )
   then                        ( end-adr )
   (init-program)              ( end-adr )
   entry-adr set-pc            ( end-adr )
   entry-adr /a.out-header -  tuck -  initsyms    ( )
   entry-adr /text + /data +  /bss  erase         ( )
;
 
: sload  ( -- )
   cleanup  setup-dload if exit then
   ." Ready for download.  Send file then type ^D"  cr
   load-base h# 20000
   \ Turn off interrupts for now because the interrupt handler takes too long
   \ and we lose characters.
   lock[  ['] gettext  catch  ]unlock  ?dup  if  throw  then  ( adr len )
   file-size !  drop
;
: dl  ( -- )  sload  load-base  file-size @  interpret-string  ;

previous