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