home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 5 / DATAFILE_PDCD5.iso / utilities / f / forthmac / !Forthmacs / risc_os / serial_dev < prev    next >
Encoding:
Text File  |  1997-05-05  |  5.5 KB  |  156 lines
  1. \ Serial communications
  2. \ RISC OS Forthmacs support for SerialDev by Hugo Fiennes
  3. \ V 2.2 04.06.96
  4. \ SerialDev driver found in risc_os.serialdev.????.driver
  5.  
  6. vocabulary modem  only forth also system also modem also definitions  decimal
  7.  
  8. 5 constant #drivers    \ number of serial drivers used, each may have two ports
  9.             \ driver0 is a fake
  10. variable next-driver
  11. nuser channel#        \ used serial channel by this task
  12.  
  13. create drivers        #drivers cells allot
  14. create driver-names    #drivers d# 32 * allot
  15. create channels        #drivers 2* cells allot
  16.  
  17. : >driver        ( i -- addr )    cells drivers + ;
  18. : >drivername        ( i -- addr )    d# 32 *  driver-names + ;
  19. : >channel        ( i -- addr )    cells channels + ;
  20.  
  21. : init-drivers    ( -- )
  22.     channel# off
  23.     1 next-driver !
  24.     drivers #drivers cells erase
  25.         driver-names #drivers d# 32 * erase
  26.         channels #drivers 2* cells erase ;  init-drivers
  27. : load-driver    ( name -- )
  28.     astring "move dup count lower
  29.     next-driver @ #drivers > if d# -630 throw then
  30.     h# 2000 allocate if drop false exit then
  31.     astring astring locals| loadaddress cli-string driver-id |
  32.     base @ hex driver-id (u.) loadaddress pack drop base !
  33.     next-driver @ >drivername "move
  34.     p" LOAD Forthmacs:devices.SerialDev." cli-string "copy
  35.     cli-string "cat p" .driver " cli-string "cat  loadaddress cli-string "cat
  36.     cli-string "cli
  37.     if false else driver-id then
  38.     ?dup 0= if d# -631 throw then 
  39.     next-driver @ >driver !
  40.     1 next-driver +! ;
  41. : use-channel    ( n -- )
  42.     dup 2 next-driver @ 2* within 0= if d# -632 throw then
  43.     channel# ! ;
  44.  
  45. \ SerialDev driver function call interface using driver-id
  46. : serial-error    d# -633 throw ;
  47. code serial_function    \ ( r2 function-code -- result )
  48.     r0    top        mov    \ set fuction-code
  49.     r4    'user channel#    ldr
  50.     r1    r4    1 #    and    \ set port#
  51.     r2    sp        pop    \ get r2-data
  52.     top    'body channels    adr
  53.     top    top   r4 2 #asl    add
  54.     top    top )        ldr
  55.     top    0 #        cmp
  56.     top    ' serial-error    eq adr 
  57.     lk    pc h# fc000003 # bic
  58.     pc    top        mov
  59.     top    r0        mov c;
  60.  
  61. \ All driver-functions use driver-id
  62. : (m-emit)    ( char -- err?)    0 serial_function ;
  63. : (m-key)    ( -- key/-1 )    0  1 serial_function ;
  64. : (m-emit?)    ( -- freeintx)    0  4 serial_function ;
  65. : (m-key?)    ( -- received#)    0  5 serial_function ;
  66. : flush-tx    ( -- )        0  6 serial_function drop ;
  67. : flush-rx    ( -- )        0  7 serial_function drop ;
  68. : get-c-lines    ( -- n )    -1 8 serial_function ;
  69. : set-c-lines    ( n -- )    8 serial_function drop ;
  70. : get-m-lines    ( -- n )    0  9 serial_function ;
  71. : rx-errors    ( -- err-mask)    0 10 serial_function ;
  72. : break        ( -- )        50 11 serial_function drop ;
  73. : get-baud    ( -- n )    -1 13 serial_function ;
  74. : set-baud    ( n -- )    dup 13 serial_function drop
  75.                 14 serial_function drop ;
  76. : get-format    ( -- n )    -1 15 serial_function ;
  77. : set-format    ( n -- )    15 serial_function drop ;
  78. : get-control    ( -- n )    -1 16 serial_function ;
  79. : set-control    ( n -- )    16 serial_function drop ;
  80. : init-driver    ( -- flag )    0 17 serial_function ;
  81. : close-driver    ( -- )        0 18 serial_function drop ;
  82. : poll-driver    ( -- )        0 19 serial_function drop ;
  83.  
  84. : 57600-baud    ( -- )        57600 set-baud ;
  85. : 38400-baud    ( -- )        38400 set-baud ;
  86. : 19200-baud    ( -- )        19200 set-baud ;
  87. : 9600-baud    ( -- )        9600  set-baud ;
  88. : 4800-baud    ( -- )        4800  set-baud ;
  89. : 2400-baud    ( -- )        2400  set-baud ;
  90.  
  91. : 1-stop-bit    ( -- )        get-format b# 111011 and  set-format ;
  92. : 2-stop-bits    ( -- )        get-format b# 111011 and  b# 000100 or  set-format ;
  93. : 8-bits    ( -- )        get-format b# 111100 and  set-format ;
  94. : 7-bits    ( -- )        get-format b# 111100 and  b# 000001 or  set-format ;
  95. : no-parity    ( -- )        get-format b# 110111 and  set-format ;
  96. : odd-parity    ( -- )        get-format b# 000111 and  b# 001000 or  set-format ;
  97. : even-parity    ( -- )        get-format b# 000111 and  b# 011000 or  set-format ;
  98.  
  99. : no-flow-control        0 set-control ;
  100. : rts/cts    ( -- )        1 set-control ;
  101. : xon/xoff    ( -- )        2 set-control ;
  102.  
  103. : rts-on    ( -- )        get-c-lines 2 or  set-c-lines ;
  104. : dtr-on    ( -- )          get-c-lines 1 or  set-c-lines ;
  105. : rts-off    ( -- )        get-c-lines [ 2 -1 xor ] literal and  set-c-lines ;
  106. : dtr-off    ( -- )        get-c-lines [ 1 -1 xor ] literal and  set-c-lines ;
  107. : ring?        ( -- f )    get-m-lines 4 and 0<> ;
  108. : dsr?        ( -- f )    get-m-lines 2 and 0<> ;
  109. : cts?        ( -- f )    get-m-lines 1 and 0<> ;
  110. : set-line    ( n -- )    ; immediate
  111.  
  112. : m-emit    ( char -- )    begin pause (m-emit?) until (m-emit) drop ;
  113. : m-key?    ( -- flag )    pause (m-key?) 0<> ;
  114. : m-key        ( -- char )    begin m-key? until (m-key) ;
  115. : m-type    ( adr len )
  116.     bounds ?do i c@ m-emit loop ;
  117. : m-expect    ( adr len -- n-read )
  118.     0 rot bounds
  119.     ?do    m-key dup carret =
  120.         if drop leave else i c! char+ then
  121.     loop ;
  122. : m-open    \ ( n -- flag ) flag:true signals an error
  123.     dup >channel @ if drop true exit then            ( n )
  124.     dup use-channel dup 2/ >driver @ swap >channel !    ( n )
  125.     init-driver dup
  126.     if channel# off else dtr-on rts-on then ;
  127.  
  128. : m-close    ( -- )
  129.     channel# @ >channel @ 0= ?exit
  130.     dtr-off rts-off close-driver
  131.     channel# @ >channel off  channel# off ;
  132. : close-drivers    ( -- )
  133.     next-driver @ 2* 2 ?do i use-channel m-close loop ;    
  134. \ tools for SerialDev following
  135. : (.serialinfo    ( n -- )
  136.     ?dup 0= ?exit
  137.     base @ swap decimal
  138.     ??cr cr ." Driver: " dup h# 80 + fstr ". dup
  139.     h# c0 +  @ ." , V. " dup h# 10 rshift . h# ffff and .
  140.     cr ." Manufacturer: " dup h# a0 + fstr ".
  141.     cr ." Speeds: " ??cr  h# 100 +
  142.     begin dup @ 0<> while dup @ 8 u.r 0 .tab 4 + repeat drop
  143.     base ! ;
  144.  
  145. only forth also definitions modem also
  146. : driver     \ name ( -- )
  147.     blword load-driver ;
  148. : .channels    ( -- )
  149.     ??cr next-driver @ 2* 2
  150.     ?do i .d i >channel @ if ." used" else ." free" then ." ,   "
  151.     loop ;
  152. : .drivers
  153.     next-driver @ 1 ?do i >driver @ (.serialinfo loop ;
  154. : (cold-hook    (cold-hook init-drivers ;     ' (cold-hook is cold-hook
  155. : (bye        close-drivers (bye ;            ' (bye is bye
  156.