(       Title:  Copy Input
         File:  copyinput.fs
       Author:  David N. Williams
      License:  LGPL
      Version:  0.6.1
Last revision:  September 19, 2002
)
\ Copyright (C) 2002 by David N. Williams
(
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or at your option any later version.

This library 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.  See the
GNU Lesser General Public License for more details.

Please see the file POLITENESS included with this distribution.

This code saves the input stream across lines up to a
terminating string so it can be processed later.  It includes a
word EXPORT{ which can be used to extend a structure or object
by copying definitions in the base name space into the name
space of the extension.

ANS Forth compatible except for case sensitivity and
[UNDEFINED].

Notation and terminology:

  * "s" or a ".s" suffix stands for a Forth string [ addr len].
    When modified, "string" means "Forth string".

  * "m" or a ".m" suffix stands for the address, assumed to be
    aligned, of a cell-counted string, a case of what we call a
    "measured string".
)

decimal


\ *** WORDS
(
  strings:
  M>S  M+  S-SEPARATE  TRIM-OUTER  

  input stream:
  S-PARSE  UPTO-TRIM,

  extension:
  EXPORT{
)


\ *** GENERAL USE

\ s" undef.fs" included

[UNDEFINED] cell [IF] 1 cells constant cell [THEN]

[UNDEFINED] -rot [IF]
  : -rot  ( a b c -- c a b )  rot rot ;
[THEN]

[UNDEFINED] parse-area@ [IF]
  : parse-area@  ( -- unparsed.s )
    source ( &inbuf #inbuf) >in @ ( #parsed) /string ;
[THEN]

[UNDEFINED] parse-area! [IF]
  : parse-area!  ( unparsed.s -- )
    ( addr len) source nip ( #tib) swap - >in ! ( addr) drop ;
[THEN]

[UNDEFINED] exhaust-input [IF]
  : exhaust-input  ( -- )
    source ( len) >in ! ( addr) drop ;
[THEN]

[UNDEFINED] bl-skip [IF]  \ Baden tool belt
  : bl-skip  ( str len -- str+i len-i )
    BEGIN dup WHILE over c@ 33 <
    WHILE 1 /string REPEAT THEN ;
[THEN]

: trim-outer  ( s -- s' )
  bl-skip -trailing ;

: ?echo-cr  ( -- )  source-id 0= IF cr THEN ;

: s-separate  ( s pat.s -- before.s after.s true | s false )
(
Scan s for the first occurrence of the pattern string.  If
found, leave true and the strings before and after the pattern.
If not, leave false and the original string.
)
  locals| pat.len pat.addr s.len s.addr |
  s.addr s.len pat.addr pat.len search
  ( &found #rem true | s false )
  IF
    ( &found #rem) dup >r
    ( &found #rem) pat.len /string ( after.s)
    s.addr s.len r> ( #rem) - ( before.s) 2swap true
  ELSE ( s) false THEN ;

: s-parse  ( pat.s -- before.s true | parsed.s false )
(
Scan the current source buffer for the first occurrence of the
pattern string.  If found, leave true and the string before the
pattern; leave the input stream position just after the pattern.
If not found, leave false and the source buffer as a Forth
string; leave the input stream exhausted.
)
  parse-area@ 2swap s-separate ( found?) dup >r
  IF    \ pattern found
    ( before.s after.s) parse-area!
  ELSE  \ pattern not found
    ( parsed.s) exhaust-input
  THEN r> ( found?) ;

: m>s  ( m -- s )  \ replacement for COUNT
  >r r@ cell+ ( addr) r> @  ( len) ;

: m+  ( s m -- )  \ replacement for APPEND (Baden tool belt)
(
Append the Forth string to the cell-counted string.
)
  2dup 2>r   m>s +   swap move 2r> +! ;

: upto-trim,  ( end.s -- s )
(
Store the input stream across lines, up to the terminating
end.s, into data space as a cell-counted string, stripping
leading and trailing spaces from the lines and separating them
by single BL's.  Leave its Forth string representation.  Leave
the input stream positioned just after the terminating string.

Note:  This implementation stores a leading BL when the input
stream initially contains no text, and a trailing BL when the
terminating string is the only text at the beginning of a line.
)
  align here ( m) >r 0 ( m.len) ,
  BEGIN
    ( end.s) 2dup s-parse -rot ( found? parsed.s)
    trim-outer ( len) dup allot ( trimmed.s) r@ m+
    ( found?) 0=
  WHILE
    1 allot s"  " r@ m+
    ?echo-cr refill 0= ABORT"  ***Terminating string not found."
  REPEAT ( end.s) 2drop r> m>s ;


\ *** EXTENSION BY COPY

: export{  ( "<text>}export" -- )
(
Define a word "import" in the current compilation word list and
compile the text in the input stream across lines up to the next
"}export" so that the word EVALUATE's it.  Execute the word.
Leave the input stream positioned just after "}export".

Note:  This implementation also defines a string constant
"'export'" in the current compilation word list.
)
  s" }export" upto-trim,   s" 2constant 'export'" evaluate
  s" : import 'export' evaluate ;" evaluate
  s" import" evaluate ;

0 [IF]
\ *** SYNTAX EXAMPLES

struct: Point1{
export{
  1 cells field: x
  1 cells field: y
}export
;struct: /Point1

struct: ColoredPoint{
  Point1{ import }
  1 cells field: color
;struct: /ColoredPoint

struct: Point2{
export{
  1 cells field: u
  1 cells field: v
}export
;struct: /Point2

struct: CompositePoint{
Point1{ import }
Point2{ import }
;struct: /CompositePoint
[THEN]