home *** CD-ROM | disk | FTP | other *** search
/ Carousel Volume 2 #1 / carousel.iso / mactosh / lang / fortran_.sou < prev    next >
Encoding:
Text File  |  1988-10-27  |  8.5 KB  |  316 lines
  1. 30-Aug-86 09:32:18-PDT,9262;000000000001
  2. Return-Path: <bouldin@ceee-sed.ARPA>
  3. Received: from ceee-sed.ARPA by SUMEX-AIM.ARPA with TCP; Sat 30 Aug 86 09:31:32-PDT
  4. Date: 30 Aug 86 12:22:00 EDT
  5. From: <bouldin@ceee-sed.ARPA>
  6. Subject: scroll example for absoft fortran 
  7. To: "info-mac" <info-mac@sumex-aim.arpa>
  8. Reply-To: <bouldin@ceee-sed.ARPA>
  9.  
  10. * This program demonstrates the use of the assembly language module
  11. * ctlprc.sub to create toolbox callable procedure from FORT
  12. RAN
  13. * subroutines.  This procedure is used as follows:
  14. *
  15. * Title: ctlprc.sub - Toolbox Control/Filter glue procedure.
  16. *
  17. * P
  18. urpose: To interface MacFortran with the Macintosh's Toolbox.
  19. *
  20. * Notes: ctlprc.sub takes a FORTRAN procedure as an argument a
  21. nd returns
  22. *    a pointer to a procedure that can be called by the Macintosh
  23. *    toolbox.  This is used to allow control tracking a
  24. nd filter procedures
  25. *    to be written in FORTRAN.
  26. *
  27. * Warnings/Limitations:  This procedure locks itself into the FORTRAN heap
  28.  
  29. *    when it is called for the first time.  Since it returns pointers
  30. *    to locations within itself, it must never move.  This me
  31. ans that this
  32. *    routine should be called to set up all filter procedures before
  33. *    any files are opened, any dynamic subroutine
  34. s are called, or
  35. *    any local common blocks are allocated.  It is best to call it
  36. *    as the first executable statements of the m
  37. ain program.
  38. *
  39. * Calling sequence:
  40. *    CALL CTLPRC(<filter proc>, <argument byte count>)
  41. *   where
  42. *    <filter proc> is the nam
  43. e of the FORTRAN procedure to be called
  44. *        from the toolbox.  This should be a procedure with a single
  45. *        integer parameter, w
  46. hich on entry will contain a pointer to
  47. *        the arguments from the toolbox as they appear on the stack.
  48. *        This must be declare
  49. d as EXTERNAL in the program unit where
  50. *        CTLPRC is used; this will usually be the main program.
  51. *    <argument byte count> is t
  52. he total number of bytes of arguments that
  53. *        the toolbox will push on the stack for the type of filter
  54. *        procedure that this
  55.  FORTRAN procedure will be used for.
  56. *        For example, if the procudure is to be used to track a scroll
  57. *        bar, the toolbox will
  58.  pass 2 parameters on the stack; the 
  59. *        control handle (4 bytes) and the part code (2 bytes), for
  60. *        a total of 6 bytes.  The
  61.  track procdure should be initialized
  62. *        with
  63. *            INTEGER TRACK
  64. *            .
  65. *            .
  66. *            .
  67. *            TRACK = CTLPRC(FTRACK, 6)
  68. *        where 
  69. FTRACK is the FORTRAN procedure name.  The integer
  70. *        variable TRACK will contain the address of a toolbox callable
  71. *        procedu
  72. re.
  73. *
  74.  
  75. * ctlprc.sub can be used to create toolbox callable procedures for a
  76. * number of toolbox functions which take procedu
  77. re pointers as
  78. * parameters, such as TrackControl and ModalDialog.  This program
  79. * demonstrates its use with TrackControl, bri
  80. nging up a scroll bar
  81. * and manipulating its value from within a FORTRAN actionProc.
  82. * For more details regarding the use of t
  83. he actionProc parameter,
  84. * see 'The Control Manager' in 'Inside Macintosh'.
  85.  
  86.     program scroll
  87.  
  88.     implicit none        ! Declare all
  89.  variables.
  90.  
  91. * Get toolbox definitions.
  92.     include hfs volume:fortran 2.2:include files:toolbx.par
  93.     include hfs volume:fortran
  94.  2.2:include files:event.inc
  95.  
  96. * Declare external functions.
  97.     integer toolbx        ! Toolbox access.
  98.     integer ctlprc        ! Create too
  99. lbox callable procs.
  100.  
  101.     integer track        ! Address of the track proc.
  102.     integer ftrack        ! This keeps IMPLICIT NONE happy.
  103.  
  104. * De
  105. clare ftrack as a subroutine.
  106.     external ftrack
  107.  
  108.     integer window        ! A window pointer.
  109.     integer scroll        ! A scroll bar handle.
  110.  
  111.     integer*2 bounds(4)    ! Scroll bar bounds rect.
  112.     character*80 title    ! Scroll bar title.
  113.     logical visible        ! Scroll bar visibl
  114. ity flag.
  115.  
  116. * The current, minimum, and maximum value of the scroll bar.
  117.     integer value, minval, maxval
  118.  
  119.     integer procid        ! 
  120. Control type (scroll = 16)
  121.     integer refcon        ! User data for scroll bar.
  122.  
  123.     integer mouseloc    ! Current mouse location.
  124.     intege
  125. r part        ! Scroll bar part code.
  126.  
  127.         equivalence (eventrecord(1),what)
  128.         equivalence (eventrecord(2),message)
  129.     
  130.     equivalence (eventrecord(4),when)
  131.         equivalence (eventrecord(6),where(1))
  132.         equivalence (eventrecord(8),modifi
  133. ers)
  134.  
  135.  
  136. * Get a pointer to a toolbox callable version of the FORTRAN
  137. * actionProc ftrack.  This pointer is what we will actua
  138. lly
  139. * send to the toolbox; the toolbox will then call ftrack.
  140.     track = ctlprc(ftrack,6)
  141.  
  142. *
  143. *  Set up the event manager mask
  144.  (you should accept responsibility for all
  145. *  events to insure that the event queue is flushed; some calls such as 
  146. *  MENUSEL
  147. ECT will not work properly if there are extra mouse up events
  148. *  lying around):
  149. *
  150.     eventmask = -1
  151.  
  152. * Get a pointer to the d
  153. efault FORTRAN window.
  154.     window= toolbx(FRONTWINDOW)
  155.  
  156. * Define the shape of the scroll bar.  This is a vertical
  157. * scroll bar.
  158.  
  159.     bounds(1) = 20
  160.     bounds(2) = 20
  161.     bounds(3) = 36
  162.     bounds(4) = 200
  163.  
  164. * Set up the scroll bar title (actually never used).
  165.     
  166. title = char(10) // "scroll bar"
  167.  
  168.     visible = .true.
  169.     value = 0            ! Initial value.
  170.     minval = 0            ! Minimum value.
  171.     maxval = 
  172. 100            ! Maximum value.
  173.     procid = 16            ! Scroll bar.
  174.     refcon = 0            ! User data.
  175.  
  176. * Create and display the scroll bar.
  177.     scrol
  178. l = toolbx(NEWCONTROL, window, bounds,
  179.      +       title, visible, value, minval, maxval,
  180.      +       procid, refcon)
  181.  
  182. * Process
  183.  events.  All we are interested in here are mouse down
  184. * events in the content region of the default window.  If the
  185. * mouse i
  186. s down in the scroll bar, we call TrackControl to
  187. * modify its value.  If it is down anywhere else in the window,
  188. * we exit th
  189. e program.
  190.       do
  191.         if (toolbx(GETNEXTEVENT,eventmask,eventrecord)) then
  192.         
  193.           select case (what)
  194.           
  195.           
  196.   case (1)        ! mouse down
  197.  
  198.           mouseloc = toolbx(FINDWINDOW,where,window)
  199.  
  200. * Down in the content region of a window (of which
  201.  there is
  202. * only one).
  203.             if (mouseloc=3) then
  204.               call toolbx(GLOBALTOLOCAL, where)
  205.               part = toolbx(FINDCONTRO
  206. L, where,
  207.      +            window, scroll)
  208.                    if (part .eq. 129) then
  209. * In the thumb.  There is no need for an actionProc t
  210. o move the 
  211. * thumb, so nil (zero) is passed instead.
  212.                       part = toolbx(TRACKCONTROL, scroll,
  213.      +            where, 0)
  214.  
  215.                    elseif (part .ne. 0) then
  216. * In some other part of the scroll bar.  Call TrackControl
  217. * with the actionProc set u
  218. p by ctlprc.  The toolbox will
  219. * call the actionProc repeatedly as long as the mouse button
  220. * is held down.
  221.                       p
  222. art = toolbx(TRACKCONTROL, scroll,
  223.      +            where, track)
  224.                    else
  225. * Part was zero, so the mouse was not down in the
  226.  scroll bar.
  227. * Exit.
  228.                       stop
  229.                    endif
  230.             end if
  231.     
  232.             case default        ! Ignore all other even
  233. ts.
  234.           end select
  235.           
  236.         end if
  237.       repeat
  238.          end
  239.  
  240. * This is the actionProc for the scroll bar defined in the
  241.  
  242. * main program.  An actionProc is defined in 'Inside Macintosh'
  243. * as
  244. *    Procedure MyAction (theControl : ControlHandle;
  245. *        p
  246. artCode : INTEGER);
  247. * A pointer to the arguments passed to this
  248. * routine by the toolbox is passed in argptr.  This is done
  249. *
  250.  since the glue routine used by ctlprc to interface the
  251. * toolbox to FORTRAN has no way of knowing what kind of
  252. * procedure th
  253. is is (control actionProc, dialog filterProc,
  254. * etc.), and therefore no way of knowing how many parameters
  255. * to expect.  argpt
  256. r points to the last argument (partCode)
  257. * as pushed on
  258. * the stack by the toolbox; preceding arguments are at
  259. * higher addre
  260. sses.
  261.          subroutine ftrack(argptr)
  262.  
  263.     implicit none            ! Declare all variables.
  264.     integer argptr            ! Pointer to arguments.
  265.     include hfs volume:fortran 2.2:include files:toolbx.par
  266.  
  267.          integer toolbx            ! Declare external function.
  268.  
  269.          integer
  270.  thecontrol        ! Control handle.
  271.          integer partcode        ! Part code.
  272.  
  273.          integer value            ! Current scroll value.
  274.  
  275.          p
  276. artcode = word(argptr)        ! Get the last arg.
  277.          thecontrol = long(argptr+2)    ! Get the first arg.
  278.  
  279. * Get the current value o
  280. f the scroll bar.
  281.          value = toolbx(GETCTLVALUE, thecontrol)
  282.  
  283. * Determine part selected.  Decrese the value to the minimum
  284.  
  285. * zero for the up arrow and page up parts; Increse the value
  286. * to the maximum 100 for the down arrow and page down parts.
  287.   
  288.        select case (partcode)
  289.          case (20)            ! Up arrow.
  290.            value = value - 1
  291.          case (21)            ! Down arrow.
  292.            v
  293. alue = value + 1
  294.          case (22)            ! Page up.
  295.            value = value - 5
  296.          case (23)            ! Page down.
  297.            value = value
  298.  + 5
  299.          case default
  300.          end select
  301.  
  302. * Limit the value to be between the minimum and maximum.
  303.          if (value < 0) val
  304. ue = 0
  305.          if (value > 100) value = 100
  306.  
  307. * Set the new value and display the new thumb position.
  308.     call toolbx(SETCTLVALUE,
  309.  thecontrol, value)
  310.  
  311.          return
  312.          end
  313.           new value and display the new thumb position.
  314.     call toolbx(SETCTLVALUE,
  315. ------
  316.