\ progsave

needs ids
needs events
needs double
needs 1802memory
needs fields
needs datamgr
needs fieldutils
needs skins
needs dbcosmac

decimal

: create-db  ( -- )
    0  [id] prog  [id] 1802
    dbname   \ puts zstring & len on stk
    CreateDB ;

: open-db-rw  ( -- )    db db-open-rw ;

: open/create-db  ( -- )
    ['] open-db-rw catch
    -38 = if
        db db-create
    then ;

: write-header  ( start -- )
    header rec.startaddr !
    RECTYPE-PROG header rec.type !
    header
    [ sizeof RecHdr: ] literal
    0            \ offset of header in record
    db db-write-rec ;

: write-program  ( start end -- )
    >r
    [ sizeof RecHdr: ] literal
    ( start index )
    begin
        over byte@   \ fetch 1802 byte
        over db c!db   ( start index )
        1+ swap  1+ swap   \ incr both
        over r@ u>
    until
    2drop 
    r> drop ;

: write-record
    ( start end -- ) 
    open/create-db   ( start end )
    2dup calc-recsize 
    ( start end size )    
    65535      \ record index (last)
    db db-create-rec    ( start end )
    over write-header  ( start end )
    write-program        ( )
    db db-close-rec
    db db-close ;

create save-namebuf 34 allot

: u>=  ( u1 u2 -- flag )
    u< 0= ;

: parse-addr-fields 
    ( -- start-adr end-adr true | false )
    \ parse start address
    1001 field>uhex 0= if
        ( )
        5020 FrmAlert drop
        false exit
    then

    \ parse end address
    ( start-adr )
    1002 field>uhex 0= if
        ( start-adr )
        drop    ( )
        5030 FrmAlert drop
        false exit
    then
    
    \ verify start addr < end addr        
    ( start-adr end-adr )
    2dup  u>=  if
        2drop      ( )
        5040 FrmAlert drop
        false exit
    then

    \ make sure size < 16K
    2dup swap -    (hex) 0C000 and if
        2drop     ( )
        5090 FrmAlert drop
        false exit
    then

    true ;

: znull  ( -- zstring. )   
    z"  " drop >abs ;

: parse-name  ( -- successflag )
    header rec.name 1000 Field>string
    ( length )
    dup   header rec.namesize c! ;

: show-write-err  ( err -- )
    decimal dup >r    abs u>ud
    <# 0 hold #s  r> sign #> drop
    ( zstring )
    >r
    znull znull
    r> >abs        ( &s3. &s2. &s1. )
    5050 FrmCustomAlert drop ;

: show-name-err  ( -- )
    5060 FrmAlert drop ;

\ saveit should return TRUE if no
\ errors occur and we can close the
\ dialog. FALSE will leave the dialog up
\ to allow the user to make edits and
\ retry the operation.
: saveit  ( -- flag )
    clear-header
    parse-name 0= if
         show-name-err
         false exit
    then

    parse-addr-fields if
        ( start-adr end-adr )
        ['] write-record catch ?dup
        if    
            >r  2drop  r>    ( err ) 
            show-write-err  ( )
            false
        else
            true
        then
    else
        ( )
        false
    then  ;

: do-save-buttons  ( -- flag )
    event >abs itemid
    case
    \ OK pressed
    2000 of    saveit    endof
    \  Cancel pressed
    2001 of    true     endof
    \ otherwise
    false swap
    endcase ;

\ Process events for Save dialog
\ and return TRUE when it's time
\ for the dialog to close.
: do-save-event  ( ekey -- flag )
    ctlSelectEvent = if
        do-save-buttons
    else   false    then ;    

: saveprogram  ( -- )
    2500 PopupForm
    1000 FieldFocus
    \ init start address field
    s" 0000" 1001 string>Field drop
    \ init end address field
    s" 00FF" 1002 string>Field drop 
    begin
        ekey do-save-event
    until                              
    current-form-id @
    FrmReturnToForm ;

