\ Memory Sections - ANS Forth compliant \ Permits standard dataspace operations HERE , C, ALLOT ALIGN UNUSED to be \ used with memory obtained using ALLOCATE rather than just Forth dataspace \ Extensions copyright (C) Gerry Jackson 2008 \ This software is free; you can redistribute it and/or modify it in \ any way provided you acknowledge the original source and copyright \ This program is distributed in the hope that it will be useful, \ but WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. \ ----------------------------------------------------------------------------- \ 02/05/07 User control of error handling added .( Loading Sections.fth) cr \ ----------------------------------------------------------------------------- \ \ The interface provided by this file is: \ \ section-type ( -- class ) \ Usage: section-type construct my_section_type \ \ section ( size -- size class ) \ Usage: my_section_type 1000 section construct my_section \ \ here ( -- ad ) \ allot ( n -- ) \ align ( -- ) \ c, ( x -- ) \ , ( x -- ) \ unused ( -- u ) \ org ( ad -- ) \ show-section ( xt sec -- ) \ show ( -- ) \ get-section ( -- sec ) \ restore-section ( sec -- ) \ general-data ( -- ) General data section type \ dataspace ( -- ) Selects Forth dataspace \ \ exc-sec-alloc ( -- n ) \ Exception code \ exc-sec-overflow ( -- n ) \ Exception code \ exc-sec-range ( -- n ) \ Exception code \ ----------------------------------------------------------------------------- \ Variable to point to the section type currently in use variable current_section_type 0 current_section_type ! \ ----------------------------------------------------------------------------- \ The parent section type class constructor class 1 cells var psection \ Points to the current section of this type method set_psection end-class section-type :noname ( class -- sectyp ) [ constructor :: new ] ( -- obj ) 0 over psection ! ; section-type defines new :noname ( sectyp -- ) current_section_type ! ; section-type defines invoke :noname ( ad sectyp -- ) psection ! ; section-type defines set_psection \ Get the active sections address : get-section ( -- sec ) current_section_type @ psection @ ; \ A word to restore section-type. This can be used with get-section \ to stack the current section, select another section, then \ restore the original section. : restore-section ( sec -- ) \ sec is a section object invoke \ therefore this calls section::invoke ; \ ----------------------------------------------------------------------------- \ A standard Forth dataspace section class, which is the section base class \ All this does is call Forth standard words and some initialisation constructor class 1 cells var psection_type \ Pointer to section type method sec_here method sec_allot method sec_align method sec_c, method sec_, method sec_unused end-class section_base \ new must be provided as it will be called by the section definer. \ Note that no memory is allocated for this pseudo section :noname ( class -- sec ) [ constructor :: new ] ( -- sec ) current_section_type @ ( -- sec sec2 ) over psection_type ! ( -- sec ) ; section_base defines new :noname ( sec -- ) dup psection_type @ ( -- sec sectyp ) set_psection ( -- ) ; section_base defines invoke :noname drop here ; section_base defines sec_here :noname drop allot ; section_base defines sec_allot :noname drop align ; section_base defines sec_align :noname drop c, ; section_base defines sec_c, :noname drop , ; section_base defines sec_, :noname drop unused ; section_base defines sec_unused \ ----------------------------------------------------------------------------- \ The Section class - inherits from section_base section_base class 1 cells var sec_low \ Holds the minimum permitted address 1 cells var sec_high \ Holds maximum address + 1 1 cells var sec_next \ Next available location 1 cells class-var sec_errflag \ 0 abort, -1 throw an exception on error method sec_org \ Set the next available address method sec_show \ Display section contents method sec_allocate \ Allocate memory for the section method sec_error \ Error handling end-class section \ ----------------------------------------------------------------------------- \ Error handling - allows user to control what happens in the event of an \ error. The user can: \ 1. set sec_errflag to abort or throw an exception on an error \ 2. choose exception numbers by setting the values exc-sec-alloc etc \ 3. redefine sec_error to provide a better error handler \ 4. By sub-classing section, errors can be handled in different ways \ for different sections \ The default is to abort with a message 0 section sec_errflag ! \ Defaults to abort on error \ Default exception code values, may be overwritten by the user 1000 value exc-sec-alloc \ Memory allocation failed 1001 value exc-sec-overflow \ Section overflow i.e. full 1002 value exc-sec-range \ Address out of range e.g. for org :noname ( caddr u n sec -- ) @ sec_errflag @ and throw \ flag = -1 means throw, 0 abort cr type cr abort ; section defines sec_error : ?sec_overflow ( ad sec -- ) tuck dup sec_low @ ( -- sec ad sec lo ) swap sec_high @ within 0= ( -- sec f ) if >r s" Section overflow" exc-sec-overflow r> sec_error then drop ( -- ) ; : ?sec_range ( ad sec -- ) swap if dup >r s" Section org address out of range" exc-sec-range r> sec_error then drop ; \ ----------------------------------------------------------------------------- :noname ( size class -- sec ) [ section_base :: new ] ( -- size sec ) >r ( -- size ) aligned \ Exact number of cells simplifies range checks for , dup 0> ( -- size flag ) if dup r@ sec_allocate ( -- size ad ) else drop 0 0 ( -- 0 0 ) then tuck + ( -- ad hi ) r@ sec_high ! ( -- ad ) dup r@ sec_low ! ( -- ad ) r@ sec_next ! ( -- ) r> ( -- sec ) ; section defines new :noname ( size sec -- ad ) swap allocate ( -- sec ad ior ) if over >r s" Section - memory not allocated" exc-sec-alloc r> sec_error then nip ( -- ad ) ; section defines sec_allocate :noname ( ad sec -- ) dup >r 2dup sec_low @ ( -- ad sec ad lo ) r> sec_high @ within 0= ( -- ad sec f ) if 2dup ?sec_range ( -- ad sec ) nip dup sec_low @ swap ( -- lo sec ) \ ad = 0 resets sec_next to sec_low then sec_next ! ; section defines sec_org \ :noname ( ad sec -- ) \ 2dup ?sec_overflow \ sec_next ! \ ; section defines sec_org :noname ( sec -- ad ) dup >r sec_next @ ( -- ad ) dup r> ?sec_overflow ( -- ad ) ; section defines sec_here :noname ( n sec -- ) dup >r sec_next @ ( -- n ad ) + ( -- ad2 ) dup r@ sec_high @ <> ( -- ad2 flag ) \ Must be able to use all space if dup r@ ?sec_overflow ( -- ad2 ) then r> sec_next ! ; section defines sec_allot :noname ( sec -- ) dup >r sec_next @ ( -- ad ) aligned ( -- ad' ) dup r@ sec_high @ <> ( -- ad' flag ) \ Must be able to use all space if dup r@ ?sec_overflow ( -- ad' ) then r> sec_next ! ( -- ) ; section defines sec_align :noname ( b sec -- ) dup >r sec_next @ ( -- b ad ) dup r@ ?sec_overflow ( -- b ad ) dup char+ r> sec_next ! ( -- b ad ) c! ( -- ) ; section defines sec_c, :noname ( x sec -- ) dup >r sec_next @ ( -- x ad ) dup r@ ?sec_overflow tuck ! ( -- ad ) cell+ r> sec_next ! ; section defines sec_, :noname ( sec -- u ) dup >r sec_high @ ( -- hi ) r@ sec_next @ ( -- hi ad ) r> sec_low @ max ( -- hi ad' lo ) \ Ensure unused <= size - 0 max ( -- u ) \ Ensure unused >= 0 ; section defines sec_unused \ show-section displays the contents of a section, using the \ supplied xt to do the actual display. This should be called \ by sec_show of all descendant section classes if the default \ in this class is inadequate : show-section ( xt sec -- ) cr ." Section contents:" cr dup sec_next @ ( -- xt sec ad1 ) swap sec_low @ ( -- xt ad1 ad2 ) ?do ( -- xt ) i over execute ( -- xt inc ) +loop ( -- xt ) drop cr ; :noname ( ad -- inc ) [char] < emit dup 8 .r [char] > emit @ 10 .r cr 1 cells ; value .cell :noname ( sec -- ) .cell swap show-section ; section defines sec_show \ ----------------------------------------------------------------------------- \ Redefinition of standard words to use section definitions : org get-section sec_org ; : here get-section sec_here ; : allot get-section sec_allot ; : align get-section sec_align ; : c, get-section sec_c, ; : , get-section sec_, ; : unused get-section sec_unused ; \ ----------------------------------------------------------------------------- \ To display contents of the active section : show get-section sec_show ; \ ----------------------------------------------------------------------------- \ Definition of general data section type object section-type construct general-data \ ----------------------------------------------------------------------------- \ Definition of Forth datapace pseudo-section \ and dataspace to select Forth dataspace general-data section_base construct dspace \ No size needed for section_base : dataspace general-data dspace ; dataspace \ Use standard dataspace for now \ ----------------------------------------------------------------------------- .( Sections.fth loaded. ) .s