home *** CD-ROM | disk | FTP | other *** search
/ Chip 1997 January / Chip_1997-01_cd.bin / ms95 / disk22 / dir02 / f014710.re_ / f014710.re
Text File  |  1996-04-02  |  10KB  |  290 lines
  1.         program externpg
  2. c
  3. c ----------------------------------------------------------------------
  4. c
  5. c  Copyright (1995) Bentley Systems, Inc., All rights reserved.
  6. c
  7. c  "MicroStation" is a registered trademark and "MDL" and "MicroCSL"
  8. c  are trademarks of Bentley Systems, Inc.
  9. c
  10. c  Limited permission is hereby granted to reproduce and modify this
  11. c  copyrighted material provided that the resulting code is used only
  12. c  in conjunction with Bentley Systems products under the terms of the
  13. c  license agreement provided therein, and that this notice is retained
  14. c  in its entirety in any such reproduction or modification.
  15. c
  16. c ----------------------------------------------------------------------
  17. c
  18. c    $Logfile:   J:/mdl/examples/externpg/extrnpgf.fov  $
  19. c   $Workfile:   extrnpgf.for  $
  20. c   $Revision:   1.2  $
  21. c       $Date:   20 Jun 1995 10:03:20  $
  22. c
  23. c ----------------------------------------------------------------------
  24. c
  25. c   extrnpgf.for --
  26. c        This is test Fortran-microstation interface.
  27. c               The following C functions from extrnpgi.c file
  28. c               are currently referenced (aside of standard
  29. c               C interface functions extprg_*)
  30. c
  31. c     (call)    c_copyToFar(BYTE farhandle(6) , character string*x )
  32. c     (call)    c_copyFromFar(character string*x, BYTE farhandle(6))
  33. c     (call)    extint_shmemAttach (BYTE farhandle(6), char* extname)
  34. c     (call)    testargs
  35. c
  36. c ----------------------------------------------------------------------
  37. c
  38.         implicit integer (a-z)
  39. c
  40.         parameter       (EXTERNPG_UPDATE=1)
  41.         parameter       (EXTERNPG_TERMINATE=2)
  42.         parameter       (EXTERNPG_ACKNOWLEDGE=4)
  43.         parameter       (EXTERNPG_DISPLAY=3)
  44. c
  45.         parameter      (extqnamesize=100)
  46.         parameter      (extmnamesize=100)
  47.         parameter      (maxmsglength=100)      ! This MUST be assigned to
  48. c
  49.         hcexternal     extprg_messageReceive   ! This declares external C
  50.         integer*4      extprg_messageReceive   !  function
  51.         hcexternal     extprg_messageSend
  52.         integer*4      extprg_messageSend
  53.         hcexternal     extprg_queueAttach      ! This declares external C
  54.         integer*4      extprg_queueAttach      !  function
  55.         logical        check48bit
  56.  
  57. c        hcexternal      c_copyToFar
  58. c        hcexternal      c_copyFromFar
  59.         hcexternal      extint_shmemAttach
  60.  
  61.         character      string*128
  62.         byte           farhandle(6)            ! shared memory handle
  63.         byte           extmname(extmnamesize)  ! name of shared memory
  64.         integer*4      ptr_msmsgqdescr         ! Queue descriptor handle
  65.         byte           extqname(extqnamesize)  ! This will be the name of queue
  66.         character      clstring*128
  67.         integer*4      mtype,msglength,sendpid,reqtype
  68.         byte           mtext(maxmsglength)
  69.         byte           ptr_externalmessage          ! Just a pointer name...
  70.         integer*4      retval
  71.         common /externalmessage/mtype,msglength,sendpid,reqtype,mtext
  72.         equivalence (mtype,ptr_externalmessage)
  73. c
  74.         print   *,'Here we start !'
  75.         call    getcl(clstring)
  76.         print   *,'Command line',clstring
  77.         if      (getargc().lt.2) then           ! Terminate
  78.             print       *,'No parameters.'
  79.             goto        1000
  80.         endif
  81.         
  82.         call getargv(extqname,1)      ! This gets 1st command line argument
  83.         ptr_msmsgqdescr=extprg_queueAttach(carg(pointer(extqname)))
  84.         if(ptr_msmsgqdescr.eq.0) then   ! ERROR
  85.             print       *,'Cannot attach queue.'
  86.             goto        1000
  87.         endif
  88.         print   *,'Queue Attached !'
  89.         
  90.         call getargv(extmname,2)
  91.         call extint_shmemAttach( carg(pointer(farhandle)),
  92.      &                                carg(pointer(extmname)) )
  93.         if(check48bit(farhandle)) then    ! ERROR
  94.             print       *,'Cannot attach shared memory...'
  95.             goto        1000
  96.         endif
  97.  
  98.         print   *,'Shared memory is here !'
  99.  
  100. c        call    testargs                ! C function to test its argv,argc
  101.         
  102.         do
  103.            print        *,'Waiting for message from Microstation'
  104.            retval=extprg_messageReceive(
  105.      &           carg(pointer(ptr_externalmessage)),
  106.      &           carg(ptr_msmsgqdescr),carg(0),carg(0))
  107.  
  108.            print        *,'Got something...'
  109.  
  110.            if(retval.ne.0) then                  ! ERROR, must be 0
  111.               print     *,'Receive returned error...'
  112.               goto      1000
  113.            endif
  114.  
  115.            print        *,'Request:',reqtype
  116.  
  117.            select case (reqtype)
  118.               case (EXTERNPG_UPDATE)
  119.                  print  *,'Received update request.'
  120.                  reqtype=EXTERNPG_ACKNOWLEDGE
  121.                  msglength=0
  122.                  retval=extprg_messageSend(
  123.      &                  carg(pointer(ptr_externalmessage)),
  124.      &                  carg(ptr_msmsgqdescr))
  125.                  if(retval.ne.0) then
  126.                     print       *,'Error returned from SENDER.'
  127.                     goto        1000
  128.                  endif
  129.               case (EXTERNPG_DISPLAY)
  130.                  print  *,'Received display update'
  131.                  
  132.                  call   c_copyFromFar(string,farhandle)
  133.                  print  *,string
  134.                  reqtype=EXTERNPG_ACKNOWLEDGE
  135.                  msglength=0
  136.                  string='Here it is...'
  137.                  call   c_copyToFar(farhandle,string)
  138.                  retval=extprg_messageSend(
  139.      &                  carg(pointer(ptr_externalmessage)),
  140.      &                  carg(ptr_msmsgqdescr))
  141.                  if(retval.ne.0) then
  142.                     print       *,'Error returned from SENDER.'
  143.                     goto        1000
  144.                  endif
  145.               case (EXTERNPG_TERMINATE)
  146.                  print  *,'Received termination request.'
  147.                  
  148.                  reqtype=EXTERNPG_ACKNOWLEDGE
  149.                  msglength=0
  150.                  string='Here it is...'
  151.                  call   c_copyToFar(farhandle,string)
  152.                  retval=extprg_messageSend(
  153.      &                  carg(pointer(ptr_externalmessage)),
  154.      &                  carg(ptr_msmsgqdescr))
  155.                  if(retval.ne.0) then
  156.                     print       *,'Error returned from SENDER.'
  157.                     goto        1000
  158.                  endif
  159.                  print  *,'OK: Terminating...'
  160.                  goto   1000                                  
  161.               case default
  162.                  print  *,'Default (terminating).'
  163.                  goto   1000
  164.            end select
  165.         end do
  166. 1000    print   *,'End...'
  167.         end
  168. c
  169. c
  170. c               Length of C representation of a string
  171. c
  172. c
  173.         integer function clen(source)
  174.         byte source(0:1000)               ! assume sensible length is
  175.         integer i                       ! ve-e-e-ry large
  176.         do 1 i=0,1000
  177.            if(source(i).eq.0) goto 2
  178. 1       continue
  179. 2       clen=i
  180.         return
  181.         end        
  182. c
  183. c               This functions gets number of arguments in command line
  184. c
  185.         integer function getargc()
  186.         integer argnum
  187.         character clstring*127
  188.         integer i,length,inword
  189.         argnum=0
  190.         call getcl(clstring)
  191.         length=len(clstring)
  192.         do 100 i=1,length                               ! scan line first
  193.            if(ichar(clstring(i:i)).lt.32) goto 1000
  194. 100     continue
  195.         inword=0
  196.         do 200 i=1,length
  197.            if(ichar(clstring(i:i)).ne.32) then
  198.               if(inword.eq.0) then
  199.                  inword=1
  200.                  argnum=argnum+1
  201.               endif
  202.            else
  203.               inword=0
  204.            endif
  205. 200     continue
  206. 1000    getargc=argnum
  207.         return
  208.         end
  209. c
  210. c           This subroutine gives C-form of i-th(st,nd,rd...) argument
  211. c
  212.         subroutine getargv(destination,number)
  213. c
  214.         byte    destination(0:128)       ! assume there is sufficient place
  215.         integer*4 number
  216.         character clstring*127
  217.         character clsubstring*127
  218.         integer*4 i,length,num
  219. c
  220.         call getcl(clstring)            ! get command line
  221. c
  222.         length=len(clstring)
  223.         num=number
  224.         clsubstring=' '(1:0)
  225.         do 1 i=1,length                 ! scan for nongraphical characters
  226.         if(ichar(clstring(i:i)).lt.32) goto 1000
  227. 1       continue
  228. 2       if(length.eq.0) goto 1000       ! check length
  229.         i=index(clstring,' ')           ! Kill leading space (if any)
  230.         if(i.eq.1) then
  231.             clstring=clstring(2:length)
  232.             length=length-1
  233.             goto 2
  234.         endif
  235.         num=num-1
  236.         if (num.gt.0) then              ! still not this argument...
  237.             if (i.eq.0) goto 1000       ! no more arguments in command line
  238.             clstring=clstring(i+1:length)
  239.             length=length-i             ! truncate line
  240.             goto 2
  241.         endif
  242.         if(i.eq.0) then
  243.             clsubstring=clstring
  244.             goto 1000
  245.         endif
  246. C        clstring=clstring(i+1:length)
  247. C        i=index(clstring,' ')
  248. C        if(i.eq.0) then
  249. C            clsubstring=clstring
  250. C        else
  251.             clsubstring=clstring(1:i-1)
  252. C        endif
  253. 1000    call fortfw(destination,clsubstring)
  254.         return
  255.         end
  256. c
  257. c               subroutine fortfw converts 1st word of source 
  258. c               fortran string to C destination
  259. c
  260.         subroutine fortfw(dest,source)
  261.         byte dest(0:1000)               ! assume sufficient space
  262.         character source*127
  263.         integer*4 length,i
  264.         length=len(source)
  265.         do 1 i=1,length
  266.         if(ichar(source(i:i)).eq.32) goto 1000
  267. 1       dest(i-1)=ichar(source(i:i))
  268. 1000    dest(i-1)=0
  269.         return
  270.         end
  271. c
  272. c       This function test 1st 6 bytes of its argument to be 0
  273. c
  274. c
  275.         logical function check48bit(testval)
  276.         byte testval(6)
  277.         integer i
  278.         logical result
  279.         result=.TRUE.
  280.         do 1 i=1,6
  281.            if(testval(i).ne.0) then
  282.                result=.FALSE.
  283.                goto 2
  284.            endif
  285. 1       continue
  286. 2       check48bit=result
  287.         return
  288.         end
  289.  
  290.