Flow Control using UNNEST

Revision 2017-01-25

Charles Moore:

 

"More and more I've come to favor R> DROP to alter the flow of control.
[...] The alternative is burdening the rest of the application with checking
whether an error occurred. That's an inconvenience."

 

Thinking Forth, Leo Brodie; 1984.

Background

Forth users will be familiar with the Forth-94 Standard words CATCH and THROW. These provide a standard procedure
for handling exceptions without the need to propagate flags through multiple levels of word nesting.

While effective and simple to use, CATCH THROW can be quite resource hungry. In order to function over an arbitrary
number of levels, it must save and restore stack positions and other parameters as determined by the system. In many
applications such complexity is unwarranted and/or prohibitive and a simpler mechanism can be employed. Typical
situations are those that involve skipping one level of nesting.

UNNEST

Traditionally Forth programmers used the phrase R> DROP EXIT to terminate the current definition and the definition
that called it. Today R> DROP is not guaranteed to work on all Forth systems so we define a portable word UNNEST
which has the same functionality:

UNNEST ( -- ) ( R: nest-sys -- )

Discard the calling definition specified by nest-sys.

In addition to portability, having a dedicated word for this function offers improved readability - unlike the sequence
R> DROP whose purpose could only be ascertained by examining the code in which it appeared.

Sample implementation

    : UNNEST POSTPONE R> POSTPONE DROP ; IMMEDIATE

Example

\ ANSFORTH file handling for CP/M

forth definitions decimal

128 constant recsiz   \ CP/M record size
10 constant #fcb      \ max handles
0 value fh ( -- a )   \ current handle
6 36 + constant hsiz  \ handle size

sp@ 512 - $FFF0 and constant dlimit

: hbuf ( -- a )  dlimit recsiz - ;  \ r/w buffer
: /fh ( -- )  #fcb hsiz * hbuf over - swap erase ; /fh
: use ( -- a )  fh hsiz negate * hbuf + ;
: uid ( -- a )  use 1+ ;   \ user number
: fcb ( -- a )  use 6 + ;  \ FCB
: rwp@ ( -- ud )  use 2+ 2@ ;
: rwp! ( ud -- )  use 2+ 2! ;

\ get free handle, 0 if none
: getfh ( -- fid | 0 )
  #fcb 1+  begin  1-  dup while
    dup to fh  use c@ 0=
  until then ;

\ select/check handle
\ mode mask: 1=read 2=write 3=read/write
: setfh ( fid mask -- 0 | err# )
  swap  dup 1- 0 #fcb within if
    to fh  use c@  dup if
      and 0=  5 and
    end
  then  2drop 6 ;

\ get/set #records at 3-byte field expressed as bytes
: REC@ ( a -- +d )  dup >r  @  r> 2+ c@  7 0 do d2* loop ;
: REC! ( +d a -- )  >r  7 0 do d2/ loop  r@ 2+ c!  r> ! ;

: >IOR ( err# -- ior )  dup if $FE00 or then ;

: FILE-POSITION ( fid -- ud ior )
  3 setfh  rwp@  rot >ior ;

: REPOSITION-FILE ( ud fid -- ior )
  3 setfh dup >r if  2drop  else  rwp!  then  r> >ior ;

\ set/reset partial close attribute (CPM3/MPM)
: xf5 ( mask fcb -- )
  5 + tuck c@ over or swap >< and swap c! ;

: FLUSH-FILE ( fid -- ior )
  3 setfh  dup 0= if
    uid c@ setusr  fcb  $FF80 over xf5
    dup 16 bdos drop  $7F00 over xf5
    35 bdos drop  rstusr
  then  >ior ;

: FILE-SIZE ( fid -- ud ior )
  flush-file  fcb 33 + rec@  rot ;

: CLOSE-FILE ( fid -- ior )
  3 setfh dup 0= if
    ( 0 ) use c!  uid c@ setusr
    fcb 16 bdos  rstusr  255 =  2 and
  then  >ior ;

aka 0 R/O
aka 1 W/O
aka 2 R/W
aka noop BIN immediate

: open1 ( a u fam -- | x ior )
  getfh 0= if  2drop  4 >ior  unnest  end
  1+ use c!  >fname count  fcb setfcb  dup uid c!
  setusr  0 0 rwp! ;

: open2 ( fn# -- fid flag )
  fh  fcb rot bdos 255 =  rstusr ;

: open3 ( flag err -- | ior )
  and >ior  ?dup if  0 use c!  unnest  then ;

: OPEN-FILE ( a u fam -- fid ior )
  open1  15 open2  2 open3
  ( test if file R/O and mode=write )
  fcb 9 + c@  6 rshift  use c@  and  1 >  5 open3  0 ;

: CREATE-FILE ( a u fam -- fid ior )
  open1  fcb 19 bdos drop  22 open2  5 open3  0 ;

: >FCB ( a u -- fcb usr )
  2dup >fname 18 + -rot 2 pick setfcb ;

: DELETE-FILE ( a u -- ior )
  >fcb setusr  19 bdos  rstusr 255 =  2 and  >ior ;

: RENAME-FILE  ( a1 u1 a2 u2 -- ior )
  2swap  >fcb setusr >r  >fcb drop
  r@ c@  over c!  dup 15 bdos  255 = if
    r@ 16 + 16 cmove
    r> 23 bdos  255 =  2 and  >ior
  else
    16 bdos  r> 2drop  5 >ior
  then  rstusr ;

0 value offs

: setsiz ( -- size )
  rwp@  over $7F and  to offs  fcb 33 + rec!
  recsiz offs - ;

: SETDMA ( a -- )  26 bdos drop ;

: ranrw ( a size fn# -- a size | a u' )
  fcb swap bdos if  drop  unnest  r>  then ;

: rdini ( a u fid -- u a u | u ior )
  1 setfh  ?dup if  nip >ior  unnest  end  tuck ;

: fread ( a u1 -- a u2 )
  begin  dup while
    >r  setsiz r@ umin ( siz)
    dup recsiz = if
      over setdma  33 ranrw
    else
      hbuf setdma  33 ranrw
      2dup hbuf offs + -rot cmove
    then
    dup >r +  rwp@  r@ m+  rwp!  2r> -
  repeat ;

: wrini ( a u fid -- a u | ior )
  2 setfh ?dup if  nip nip >ior  unnest  then ;

: fwrite ( a u1 -- a u2 )
  begin  dup while
    >r  setsiz r@ umin ( siz)
    dup recsiz = if
      over setdma
    else
      hbuf recsiz $1A fill
      hbuf setdma  fcb 33 bdos drop ( allow errors)
      2dup hbuf offs + swap cmove
    then
    34 ranrw
    dup >r +  rwp@  r@ m+  rwp!  2r> -
  repeat ;

: READ-FILE ( a u1 fid -- u2 ior )
  rdini  uid c@ setusr  fread  rstusr  nip -  0 ;

: WRITE-FILE ( a u fid -- ior )
  wrini  uid c@ setusr  fwrite  rstusr  nip 0<> 255 and >ior ;

create (cr) 13 c, 10 c,

: WRITE-LINE  ( c-addr u fileid -- ior )
  dup >r  write-file  ?dup if  r> drop  end
  (cr) 2  r> write-file ;

: eol? ( addr -- 2|1|0 )
  c@ case
    $0D of 2 endof
    $0A of 1 endof
    0 swap
  endcase ;

: READ-LINE ( addr u1 fid -- u2 flag ior )
  >r  over swap  r> read-file ?dup if  end
  ( a u') 2dup over + swap ?do
    i  dup c@ $1A = if
      rot -  fh file-size drop  rwp!  leave
    then
    eol?  ?dup if
      i + >r  over +  r> swap -  dup 0<>  rwp@ d+  rwp!
      i swap -  -1 0  unloop
    end
  loop nip dup 0<> 0 ;

History

2013-07-30 First release
2014-03-18 Add note on readability

Top    Home    Forth

Page updated: 2017-01-25