One task writes and one task reads. There are no rules on who puts in and who takes out. But data can only be taken out once.
io_common class
cell% instance_variable %%character
cell% instance_variable %%line
cell% instance_variable %%page
cell% instance_variable %%character_max
cell% instance_variable %%line_max
cell% instance_variable %%?page
\ set by reader if it is waiting for data and a wakeup is desired.
#facility_length bytes% instance_variable %%reading_task
\ Set by writer if it is waiting to write and a wakeup is desired.
#facility_length bytes% instance_variable %%writing_task
\ The real question. Do we allow more than one active sting. I think
\ it best if the answer is no "KISS". We will have two buffers
\ an active write buffer and an active read buffer.
$200 CONSTANT _#pipe_buffer_length
_#pipe_buffer_length bytes% instance_variable %%buffer1
_#pipe_buffer_length bytes% instance_variable %%buffer2
cell% instance_variable %%read_data>
cell% instance_variable %%read_count
cell% instance_variable %%write_buffer>
cell% instance_variable %%write_count
_#release_version 01 ??=
m: ( --)
\ does the unlinking
this [parent] :destruct
\ claim the facilities so noone else gets into trouble.
\ If you try and destroy things with other tasks reading and writing
\ tough.
%%reading_task grab
%%writing_task grab
\ Then unlink from our facility link so we don't get into trouble.
%%reading_task _#facility_link + unlink_double
%%writing_task _#facility_link + unlink_double
; overrides :destruct
m: ( parent--)
this [parent] :construct
zero %%?page !
zero %%page !
zero %%character !
zero %%line !
#23 %%line_max !
#79 %%character_max !
%%reading_task #facility_length ERASE
%%writing_task #facility_length ERASE
zero %%read_count !
zero %%write_count !
%%buffer1 %%write_buffer> !
; overrides :construct
\ you can open the device but no files
m: ( addr num mode-- handle )
this :!mode
ABORT" Device does not support files"
DROP
this
; overrides :Sopen
\ will read number of specified characters.
\ There is no terminator.
| m: ( add num_bytes --num_bytes)
%%reading_task get
TUCK zero DO
xsleep
%%read_count @ 0= IF
%%writing_task _#facility + @ ?DUP IF
wake SWAP W!
THEN
\ When data is written to pipe we will awake
xnext
THEN
%%read_data> @ C@
OVER I + C!
1 %%read_data> +!
-1 %%read_count +!
LOOP
%%reading_task release
; overrides :read
\ The last character is the line terminator, if it equals #end_eof
\ the output flag is false otherwise the flag is true.
\ The line terminator is part of the count. It has to be like
\ this as a zero count says the supplying task has nothing to say.
\ A null line with a terminator is a valid message.
m: { variable %buffer_addr variable %buffer_count -- ( len flag) }
\
send
%%reading_task get
xsleep
%%read_count 0= IF
%%writing_task _#facility + @ ?DUP IF
wake SWAP W!
THEN
xnext
THEN
\ %%read_count should now be non zero
%%read_count @ %buffer_count @ > IF
\ The last character in the buffer has to be
\ #end_count terminator
%buffer_count @ 1 - DUP zero DO
%%read_data> @ char@
%buffer_addr @ I CHARS + char!
1 CHARS %%read_data> +!
-1 %%read_count +!
LOOP
\ count(--
#end_count %buffer_addr @ jump CHARS + char!
ELSE
%%read_count @ DUP zero DO
%%read_data> @ char@
%buffer_addr @ I CHARS + char!
1 CHARS %%read_data> +!
-1 %%read_count +!
LOOP
\ count(--
THEN
%%reading_task release
%buffer_addr @ SWAP
this :termination>code
; overrides :read_line
\ manipulate the input data to produce a termination code
\ addr is the start of the buffer
\ num is the numbr of characters including the terminator
\ num1 excludes the terminator code; which is now one byte only.
\ flag is true if more data
m: ( addr num --num flag)
TUCK + char@
#end_eof = IF
1 - FALSE
ELSE
1 - TRUE
THEN
; overrides :termination>code
\ returns the character position of the previous line.
\ a pipe cannot do such a thing
m: \ compile time ( --xt)
\ runtime ( n -- n true | false )
FALSE
; overrides :previous_line
| : _pipe_send ( addr count --)
DUP not IF \ don't send null packet
2DROP
xpause
EXIT
THEN
xsleep
%%read_count @ 0<> IF
xnext
THEN
\ %%read_count is zero
\ addr count(--
%%read_count !
%%read_data> !
%%reading_task _#facility + @ ?DUP IF
wake SWAP W!
THEN
;
m: ( --)
%%write_buffer> @ %%write_count @
_pipe_send
zero %%write_count !
%%write_buffer> @ %%buffer1 = IF
%%buffer2 %%write_buffer> !
ELSE
%%buffer1 %%write_buffer> !
THEN
; overrides :flush_file
protected
\ keep going around until count is zero, each time
\ around we send a little more data
: _data>write_buffer ( addr count -- false|addr count true)
_#pipe_buffer_length %%write_count @ - 2DUP > IF ( will not all fit)
\ addr count amount_to_fit(--
>R \ addr count (--
OVER %%write_buffer> @ %%write_count @ + R@ MOVE \ put in as much as we can
SWAP R@ + SWAP R@ - \ update send data to reflect what has been sent
R> %%write_count +!
FALSE \ tell TYPE to send the packet
\ and come back again
EXIT
THEN
\ data will fit in the buffer
DROP
\ character we are up to since last record ( eol ).
%%write_buffer> @ %%write_count @ + SWAP \ addr to count(--
\ update %%type_buffer_count after you have done the address calculations
DUP %%write_count +!
MOVE
TRUE
;
public
m: ( addr num--)
%%writing_task get
DUP IF \ There is some data
BEGIN
_data>write_buffer IF \ return true if all ok
EXIT
THEN
\ sent the data to the device to clear the buffer
this :flush_file
AGAIN
ELSE
2DROP
THEN
%%writing_task release
; overrides :write
m: ( addr num --)
this :write
this :cr
; overrides :write_line
m: ( addr num --)
DUP %%character +!
this :write
; overrides :type
m: ( addr num -- )
DUP %%character +!
DUP 2+ this :?send
8A _emit_buffer C! _emit_buffer 01 this :write
this :write
81 _emit_buffer C! _emit_buffer 01 this :write
; overrides :mark ( send out data highlighted)
\ Make sure all will fit in transmit buffer
\ If not transmit
m: ( num --)
%%write_count @ + _#pipe_buffer_length > IF
this :flush_file
THEN
%%write_count @ + _#pipe_buffer_length > ABORT" Data too large to send"
; overrides :?send
m: ( --flag)
%%read_count @ 0<>
; overrides :key?
m: ( --)
%%reading_task get
zero %%read_count !
%%writing_task _#facility + @ ?DUP IF
wake SWAP W!
THEN
%%reading_task release
; overrides :clear
m: ( data --)
2 this :?send
86 _emit_buffer C!
_emit_buffer 1+ C!
_emit_buffer 02 this :write
; overrides :!control
m: ( addr --)
DUP COUNT NIP 2+ this :?send
87 _emit_buffer C! _emit_buffer 01 this :write
COUNT CHARS this :write
81 _emit_buffer C! _emit_buffer 01 this :write
; overrides :!eot
m: ( data --)
2 this :?send
88 _emit_buffer C!
_emit_buffer 1+ C!
_emit_buffer 02 this :write
; overrides :!device
m: ( data --)
5 this :?send
89 _emit_buffer C! _emit_buffer 01 this :write
_emit_buffer ! _emit_buffer 4 this :write
; overrides :baud
m: ( --)
%%?page @ not IF
EXIT
THEN
%%page @ IF
\ The read is against the active input device.
\ This is correct.
keybuffer one ACCEPT DROP
THEN
; overrides :?page
m: ( flag --)
%%?page !
; overrides :!?page
Application access to current character line and page
m: ( -- num)
%%character @
; overrides :character#
m: ( --num)
%%line @
; overrides :line#
m: ( --num)
%%page @
; overrides :page#
m: ( num--)
%%page !
; overrides :page!
m: ( --addr)
%%line_max
; overrides :line_max
m: ( --addr)
%%character_max
; overrides :character_max
Method of displaying data
\ normal character presentation
| CREATE _$pipe_norm $019E0000 t,
m: ( --)
_$pipe_norm COUNT this :write
; overrides :normal
\ reverse character presentation
| CREATE _$pipe_rev $019F0000 t,
m: ( --)
_$pipe_rev COUNT this :write
; overrides :rev
\ blink character presentation
| CREATE _$pipe_blink $01A00000 t,
m: ( --)
_$pipe_blink COUNT this :write
; overrides :blink
\ dim character presentation
| CREATE _$pipe_dim $01A10000 t,
m: ( --)
_$pipe_dim COUNT this :write
; overrides :dim
\ underline character presentation
| CREATE _$pipe_udl $01A20000 t,
m: ( --)
_$pipe_udl COUNT this :write
; overrides :udl
| CREATE _$pipe_dim&blink $01A30000 t,
m: ( --)
_$pipe_dim&blink COUNT this :write
; overrides :dim&blink
| CREATE _$pipe_rev&blink $01A40000 t,
m: ( --)
_$pipe_rev&blink COUNT this :write
; overrides :rev&blink
| CREATE _$pipe_rev&dim $01A50000 t,
m: ( --)
_$pipe_rev&dim COUNT this :write
; overrides :rev&dim
| CREATE _$pipe_rev&udl $01A60000 t,
m: ( --)
_$pipe_rev&udl COUNT this :write
; overrides :rev&udl
| CREATE _$pipe_rev&dim&blink $01A70000 t,
m: ( --)
_$pipe_rev&dim&blink COUNT this :write
; overrides :rev&dim&blink
| CREATE _$pipe_rev&dim&udl $01A80000 t,
m: ( --)
_$pipe_rev&dim&udl COUNT this :write
; overrides :rev&dim&udl
Cursor control
m: ( line char -- )
3 this :?send
2DUP
8B _emit_buffer C!
_emit_buffer 1+ C!
_emit_buffer 2+ C! _emit_buffer 03 this :write
%%character !
%%line !
; overrides :tab
| CREATE _$pipe_terminator $018D0000 t,
m: ( -- )
0 %%character !
1 %%line +!
_$pipe_terminator COUNT this :write
; overrides :cr
| CREATE _$pipe_page $018C0000 t,
m: ( --)
1 %%page +!
0 %%character !
0 %%line !
_$pipe_page COUNT this :write
; overrides :page
Grapic characters
\ to graphics
| CREATE _$pipe_>| $018E0000 t,
m: ( --)
_$pipe_>| COUNT this :write
; overrides :>|
\ from graphics
| CREATE _$pipe_|> $018F0000 t,
m: ( --)
_$pipe_|> COUNT this :write
; overrides :|>
\ pc element input
| CREATE _$pipe_|i $01900000 t,
m: ( --)
_$pipe_|i COUNT this :write
; overrides :|i
\ pc element output
| CREATE _$pape_|o $01910000 t,
m: ( --)
_$pape_|o COUNT this :write
; overrides :|o
\ pc element vertical line
| CREATE _$page_|v $01920000 t,
m: ( --)
_$page_|v COUNT this :write
; overrides :|v
\ pc element horizontal line
| CREATE _$page_|h $01930000 t,
m: ( --)
_$page_|h COUNT this :write
; overrides :|h
\ pc element not
| CREATE _$page_|n $01940000 t,
m: ( -- )
_$page_|n COUNT this :write
; overrides :|n
\ pc element top left
| CREATE _$page_|tl $01950000 t,
m: ( --)
_$page_|tl COUNT this :write
; overrides :|tl
\ pc element top right
| CREATE _$page_|tr $01960000 t,
m: ( --)
_$page_|tr COUNT this :write
; overrides :|tr
\ pc element bottom left
| CREATE _$page_|bl $01970000 t,
m: ( --)
_$page_|bl COUNT this :write
; overrides :|bl
\ pc element bottom left
| CREATE _$page_|br $01980000 t,
m: ( --)
_$page_|br COUNT this :write
; overrides :|br
PC elements have been supported by CVS.
m: ( line character -- )
3 this :?send
9A _emit_buffer C!
_emit_buffer 1+ C!
_emit_buffer 2+ C! _emit_buffer 03 this :write
; overrides :box
m: ( line character depth width num.in num.out -- }
7 this :?send
9B _emit_buffer C!
_emit_buffer 1+ C!
_emit_buffer 2+ C!
_emit_buffer 3 + C! _emit_buffer 04 this :write
_emit_buffer C!
_emit_buffer 1+ C!
_emit_buffer 2+ C! _emit_buffer 03 this :write
; overrides :element
m: ( line character number -- }
4 this :?send
9C _emit_buffer C!
_emit_buffer 1+ C!
_emit_buffer 2+ C!
_emit_buffer 3 + C! _emit_buffer 04 this :write
; overrides :line
m: ( line character line -- )
4 this :?send
9D _emit_buffer C!
_emit_buffer 1+ C!
_emit_buffer 2+ C!
_emit_buffer 3 + C! _emit_buffer 04 this :write
; overrides :zed
It seemed like a good idea at the time. The functions labels are
stored in the application as a series of counted strings. Each string is
aligned. The series is ended with a -1.
This word takes those strings, removes the alignment bytes and the
termination character. The resultant string starts with a count field.
i.e:
source :-$string- -aligment- -$string- -alignment- -terminator-
destination:-count- -$string- -$string-
| 0FF CONSTANT _#labels_finished
| : pack_labels ( source destination--)
>R R@ \ source dest(--
\ data goes after the count
#$count_length + \ source dest(--
BEGIN
OVER $count@ _#labels_finished <>
WHILE
2DUP #$buffer $move
OVER COUNT CHARS + \ source dest after(--
jump - \ source dest length(--
+ \ source new_dest(--
SWAP COUNT CHARS +
1+ -2 AND
SWAP \ new_source new_dest(--
REPEAT
\ new_source new_dest(--
NIP
R@ - 1- \ number_bytes(--
R> $count!
;
m: ( table_addr -- )
DUP IF
$buffer
buffer pack_labels
buffer C@ 2 + this :?send
$A9 _emit_buffer C! _emit_buffer 01 this :write
buffer COUNT this :write
$81 _emit_buffer C! _emit_buffer 01 this :write
kill_buffer
ELSE
2 this :?send
$A9 _emit_buffer C!
$81 _emit_buffer 1+ C! _emit_buffer 02 this :write
THEN
; overrides :labels
m: ( table_addr -- )
DUP IF
$buffer
buffer pack_labels
buffer C@ 2 + this :?send
$AA _emit_buffer C! _emit_buffer 01 this :write
buffer COUNT this :write
$81 _emit_buffer C! _emit_buffer 01 this :write
kill_buffer
ELSE
2 this :?send
$AA _emit_buffer C!
$81 _emit_buffer 1+ C! _emit_buffer 02 this :write
THEN
; overrides :shift_labels
| CREATE _$pipe_cursor $01AB0000 t,
m: ( --)
_$pipe_cursor COUNT this :write
; overrides :cursor
| CREATE _$pipe_no_cursor $01AC0000 t,
m: ( --)
_$pipe_no_cursor COUNT this :write
; overrides :no_cursor
m: ( addr num --)
DUP 2+ this :?send
$AD _emit_buffer C! _emit_buffer one this :write
this :write
$81 _emit_buffer C! _emit_buffer one this :write
; overrides :message
| CREATE _$pipe_no_mess 01AE0000 t,
m: ( --)
_$pipe_no_mess COUNT this :write
; overrides :no_message
m: ( colour --)
2 this :?send
$AF _emit_buffer C!
_emit_buffer 1+ C! _emit_buffer 02 this :write
; overrides :foreground ( forground colour)
m: ( colour --)
2 this :?send
$B0 _emit_buffer C!
_emit_buffer 1+ C! _emit_buffer 02 this :write
; overrides :background ( backgroung colour)
m: ( colour --)
2 this :?send
$B1 _emit_buffer C!
_emit_buffer 1+ C! _emit_buffer 02 this :write
; overrides :border ( Bourder colour)
End of words used to access the terminal driver.
m: ( indent --)
CR DUP SPACES ." pipe | " ." Object: " this .h
\ indent(--
DROP
send
; overrides :print
target_also
&drivers
target_definitions
end_class pipe
target_previous_definitions
target_previous