home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Carousel Volume 2 #1
/
carousel.iso
/
mactosh
/
lang
/
fortran_.sou
< prev
next >
Wrap
Text File
|
1988-10-27
|
9KB
|
316 lines
30-Aug-86 09:32:18-PDT,9262;000000000001
Return-Path: <bouldin@ceee-sed.ARPA>
Received: from ceee-sed.ARPA by SUMEX-AIM.ARPA with TCP; Sat 30 Aug 86 09:31:32-PDT
Date: 30 Aug 86 12:22:00 EDT
From: <bouldin@ceee-sed.ARPA>
Subject: scroll example for absoft fortran
To: "info-mac" <info-mac@sumex-aim.arpa>
Reply-To: <bouldin@ceee-sed.ARPA>
* This program demonstrates the use of the assembly language module
* ctlprc.sub to create toolbox callable procedure from FORT
RAN
* subroutines. This procedure is used as follows:
*
* Title: ctlprc.sub - Toolbox Control/Filter glue procedure.
*
* P
urpose: To interface MacFortran with the Macintosh's Toolbox.
*
* Notes: ctlprc.sub takes a FORTRAN procedure as an argument a
nd returns
* a pointer to a procedure that can be called by the Macintosh
* toolbox. This is used to allow control tracking a
nd filter procedures
* to be written in FORTRAN.
*
* Warnings/Limitations: This procedure locks itself into the FORTRAN heap
* when it is called for the first time. Since it returns pointers
* to locations within itself, it must never move. This me
ans that this
* routine should be called to set up all filter procedures before
* any files are opened, any dynamic subroutine
s are called, or
* any local common blocks are allocated. It is best to call it
* as the first executable statements of the m
ain program.
*
* Calling sequence:
* CALL CTLPRC(<filter proc>, <argument byte count>)
* where
* <filter proc> is the nam
e of the FORTRAN procedure to be called
* from the toolbox. This should be a procedure with a single
* integer parameter, w
hich on entry will contain a pointer to
* the arguments from the toolbox as they appear on the stack.
* This must be declare
d as EXTERNAL in the program unit where
* CTLPRC is used; this will usually be the main program.
* <argument byte count> is t
he total number of bytes of arguments that
* the toolbox will push on the stack for the type of filter
* procedure that this
FORTRAN procedure will be used for.
* For example, if the procudure is to be used to track a scroll
* bar, the toolbox will
pass 2 parameters on the stack; the
* control handle (4 bytes) and the part code (2 bytes), for
* a total of 6 bytes. The
track procdure should be initialized
* with
* INTEGER TRACK
* .
* .
* .
* TRACK = CTLPRC(FTRACK, 6)
* where
FTRACK is the FORTRAN procedure name. The integer
* variable TRACK will contain the address of a toolbox callable
* procedu
re.
*
* ctlprc.sub can be used to create toolbox callable procedures for a
* number of toolbox functions which take procedu
re pointers as
* parameters, such as TrackControl and ModalDialog. This program
* demonstrates its use with TrackControl, bri
nging up a scroll bar
* and manipulating its value from within a FORTRAN actionProc.
* For more details regarding the use of t
he actionProc parameter,
* see 'The Control Manager' in 'Inside Macintosh'.
program scroll
implicit none ! Declare all
variables.
* Get toolbox definitions.
include hfs volume:fortran 2.2:include files:toolbx.par
include hfs volume:fortran
2.2:include files:event.inc
* Declare external functions.
integer toolbx ! Toolbox access.
integer ctlprc ! Create too
lbox callable procs.
integer track ! Address of the track proc.
integer ftrack ! This keeps IMPLICIT NONE happy.
* De
clare ftrack as a subroutine.
external ftrack
integer window ! A window pointer.
integer scroll ! A scroll bar handle.
integer*2 bounds(4) ! Scroll bar bounds rect.
character*80 title ! Scroll bar title.
logical visible ! Scroll bar visibl
ity flag.
* The current, minimum, and maximum value of the scroll bar.
integer value, minval, maxval
integer procid !
Control type (scroll = 16)
integer refcon ! User data for scroll bar.
integer mouseloc ! Current mouse location.
intege
r part ! Scroll bar part code.
equivalence (eventrecord(1),what)
equivalence (eventrecord(2),message)
equivalence (eventrecord(4),when)
equivalence (eventrecord(6),where(1))
equivalence (eventrecord(8),modifi
ers)
* Get a pointer to a toolbox callable version of the FORTRAN
* actionProc ftrack. This pointer is what we will actua
lly
* send to the toolbox; the toolbox will then call ftrack.
track = ctlprc(ftrack,6)
*
* Set up the event manager mask
(you should accept responsibility for all
* events to insure that the event queue is flushed; some calls such as
* MENUSEL
ECT will not work properly if there are extra mouse up events
* lying around):
*
eventmask = -1
* Get a pointer to the d
efault FORTRAN window.
window= toolbx(FRONTWINDOW)
* Define the shape of the scroll bar. This is a vertical
* scroll bar.
bounds(1) = 20
bounds(2) = 20
bounds(3) = 36
bounds(4) = 200
* Set up the scroll bar title (actually never used).
title = char(10) // "scroll bar"
visible = .true.
value = 0 ! Initial value.
minval = 0 ! Minimum value.
maxval =
100 ! Maximum value.
procid = 16 ! Scroll bar.
refcon = 0 ! User data.
* Create and display the scroll bar.
scrol
l = toolbx(NEWCONTROL, window, bounds,
+ title, visible, value, minval, maxval,
+ procid, refcon)
* Process
events. All we are interested in here are mouse down
* events in the content region of the default window. If the
* mouse i
s down in the scroll bar, we call TrackControl to
* modify its value. If it is down anywhere else in the window,
* we exit th
e program.
do
if (toolbx(GETNEXTEVENT,eventmask,eventrecord)) then
select case (what)
case (1) ! mouse down
mouseloc = toolbx(FINDWINDOW,where,window)
* Down in the content region of a window (of which
there is
* only one).
if (mouseloc=3) then
call toolbx(GLOBALTOLOCAL, where)
part = toolbx(FINDCONTRO
L, where,
+ window, scroll)
if (part .eq. 129) then
* In the thumb. There is no need for an actionProc t
o move the
* thumb, so nil (zero) is passed instead.
part = toolbx(TRACKCONTROL, scroll,
+ where, 0)
elseif (part .ne. 0) then
* In some other part of the scroll bar. Call TrackControl
* with the actionProc set u
p by ctlprc. The toolbox will
* call the actionProc repeatedly as long as the mouse button
* is held down.
p
art = toolbx(TRACKCONTROL, scroll,
+ where, track)
else
* Part was zero, so the mouse was not down in the
scroll bar.
* Exit.
stop
endif
end if
case default ! Ignore all other even
ts.
end select
end if
repeat
end
* This is the actionProc for the scroll bar defined in the
* main program. An actionProc is defined in 'Inside Macintosh'
* as
* Procedure MyAction (theControl : ControlHandle;
* p
artCode : INTEGER);
* A pointer to the arguments passed to this
* routine by the toolbox is passed in argptr. This is done
*
since the glue routine used by ctlprc to interface the
* toolbox to FORTRAN has no way of knowing what kind of
* procedure th
is is (control actionProc, dialog filterProc,
* etc.), and therefore no way of knowing how many parameters
* to expect. argpt
r points to the last argument (partCode)
* as pushed on
* the stack by the toolbox; preceding arguments are at
* higher addre
sses.
subroutine ftrack(argptr)
implicit none ! Declare all variables.
integer argptr ! Pointer to arguments.
include hfs volume:fortran 2.2:include files:toolbx.par
integer toolbx ! Declare external function.
integer
thecontrol ! Control handle.
integer partcode ! Part code.
integer value ! Current scroll value.
p
artcode = word(argptr) ! Get the last arg.
thecontrol = long(argptr+2) ! Get the first arg.
* Get the current value o
f the scroll bar.
value = toolbx(GETCTLVALUE, thecontrol)
* Determine part selected. Decrese the value to the minimum
* zero for the up arrow and page up parts; Increse the value
* to the maximum 100 for the down arrow and page down parts.
select case (partcode)
case (20) ! Up arrow.
value = value - 1
case (21) ! Down arrow.
v
alue = value + 1
case (22) ! Page up.
value = value - 5
case (23) ! Page down.
value = value
+ 5
case default
end select
* Limit the value to be between the minimum and maximum.
if (value < 0) val
ue = 0
if (value > 100) value = 100
* Set the new value and display the new thumb position.
call toolbx(SETCTLVALUE,
thecontrol, value)
return
end
new value and display the new thumb position.
call toolbx(SETCTLVALUE,
------