root/trunk/useful.fap

Revision 9, 22.5 kB (checked in by shai, 2 years ago)

* memlen-function imported from EXPAT/77
* Ratfor77 example added (example_ratfor.r)
* some macros for Ratfor (fortrantk.r) - allow better source readability
* makefiles fixed
Line 
1* FORTRAN/TK
2* useful functions/APIs - includes most of the platform
3* dependent functions
4* Includes FORTRAN/TK extensions
5* by Robin Haberkorn
6
7* General helpful functions:
8
9      integer function ntlen(ntstr)
10       character*(*) ntstr
11
12       ntlen = index(ntstr, char(0))-1
13      end
14
15* length of string beginning at ptr till char(0)
16      integer function memlen(ptr)
17       integer ptr, i
18       character chr*(*)
19
20       i = 0
21       loop
22        allocate(chr*1, location=ptr+i)
23        i = i + 1
24       until(chr .EQ. char(0))
25
26       memlen = i
27      end
28
29      logical function cmp(strexp)
30       character*(*) strexp
31       include       'evhnd.fi'
32
33       cmp = (cmpval .EQ. strexp)
34      end
35
36      character*256 function evname(str)
37       character*(*) str
38
39       evname = str(:index(str, ' ')-1)//char(0)
40      end
41
42      character*256 function evarg(str)
43       character*(*) str
44       integer       ntlen
45
46       evarg = str(index(str, '"')+1:ntlen(str)-1)//char(0)
47      end
48
49      character*256 function int2str(num)
50       integer num,
51     &         ntlen,
52     &         x
53
54       x = 1
55       write(int2str,*) num, char(0)
56
57       while(int2str(x:x) .EQ. ' ') x = x + 1
58       int2str = int2str(x:ntlen(int2str)+1)
59      end
60
61      character*256 function real2str(num)
62       real    num
63       integer ntlen,
64     &         x
65
66       x = 1
67       write(real2str,*) num, char(0)
68
69       while(real2str(x:x) .EQ. ' ') x = x + 1
70       real2str = real2str(x:ntlen(real2str)+1)
71      end
72
73      integer function str2int(str)
74       character*(*) str
75       integer       ntlen
76
77       read(str(:ntlen(str)),*, ERR=10) str2int
7810    end
79
80      real function str2real(str)
81       character*(*) str
82       integer       ntlen
83
84       read(str(:ntlen(str)),*, ERR=10) str2real
8510    end
86
87* File managing:
88
89* CurDir: platform dependent function
90
91c$ifdef     __OS2__
92      character*256 function GetCurDir()
93       integer  DosQueryCurrentDisk,
94     &          DosQueryCurrentDir
95       integer  disknum/0/,
96     &          lmap/0/,
97     &          rdlen
98
99       GetCurDir = char(0)
100* DosQueryCurrentDir just gets the path on the current drive -
101* not the whole path
102       if(DosQueryCurrentDisk(disknum, lmap)) return
103
104       GetCurDir = char(64 + disknum)//':\'
105       rdlen  = len(GetCurDir) - 3
106       if(DosQueryCurrentDir(0, loc(GetCurDir) + 3, rdlen))
107     &    GetCurDir = char(0)
108      end
109c$elseifdef __WIN__
110      character*256 function GetCurDir()
111       integer GetCurrentDirectoryA
112
113       if(GetCurrentDirectoryA(len(GetCurDir), GetCurDir) .EQ. 0)
114     &    GetCurDir = char(0)
115      end
116c$endif
117
118* ChangeDir: platform dependent function
119
120c$ifdef     __OS2__
121      integer function ChangeDir(dir)
122       character*(*) dir
123       integer       DosSetCurrentDir
124
125       ChangeDir = DosSetCurrentDir(dir)
126      end
127c$elseifdef __WIN__
128      integer function ChangeDir(dir)
129       character*(*) dir
130       integer       SetCurrentDirectoryA
131
132       if(SetCurrentDirectoryA(dir) .EQ. 0) ChangeDir = 1
133      end
134c$endif
135
136* CreateDir: platform dependent function
137
138c$ifdef     __OS2__
139      integer function CreateDir(dir)
140       character*(*) dir
141       integer       DosCreateDir,
142     &               ealist/0/
143
144       CreateDir = DosCreateDir(dir, ealist)
145      end
146c$elseifdef __WIN__
147      integer function CreateDir(dir)
148       character*(*) dir
149       integer       CreateDirectoryA
150
151       structure /SECURITY_ATTRIBUTES/
152        integer nLength,
153     &          lpSecurityDescriptor
154        logical bInheritHandle
155       end structure
156       record /SECURITY_ATTRIBUTES/ secattr
157
158       secattr.nLength = isizeof(secattr)
159       if(CreateDirectoryA(dir, loc(secattr)) .EQ. 0) CreateDir = 1
160      end
161c$endif
162
163* DeleteDir: platform dependent function
164
165c$ifdef     __OS2__
166      integer function DeleteDir(dir)
167       character*(*) dir
168       integer       DosDeleteDir
169
170       DeleteDir = DosDeleteDir(dir)
171      end
172c$elseifdef __WIN__
173      integer function DeleteDir(dir)
174       character*(*) dir
175       integer       RemoveDirectoryA
176
177       if(RemoveDirectoryA(dir) .EQ. 0) DeleteDir = 1
178      end
179c$endif
180
181* CreateFile: using FORTRAN
182* could be done with CreateFile-API under Windows
183
184      integer function CreateFile(file)
185       character*(*) file
186       include       'fileprop.fi'
187       character*256 GetFirstFile,
188     &               dum
189
190       dum = GetFirstFile(file, FS_ALL)
191       if(dum(1:1) .EQ. char(0)) then
192        open(999, FILE=file(:ntlen(file)), STATUS='NEW', ERR=10)
193        close(999, ERR=10)
194
195        CreateFile = 0
196
197        quit
19810      CreateFile = 1
199         else
200        CreateFile = 1
201       end if
202      end
203
204* DeleteFile: platform dependent function
205
206c$ifdef     __OS2__
207      integer function DeleteFile(file)
208       character*(*) file
209       integer       DosDelete
210
211       DeleteFile = DosDelete(file)
212      end
213c$elseifdef __WIN__
214      integer function DeleteFile(file)
215       character*(*) file
216       integer       DeleteFileA
217
218       if(DeleteFileA(file) .EQ. 0) DeleteFile = 1
219      end
220c$endif
221
222* GetFirstFile: platform dependent function
223
224c$ifdef     __OS2__
225      character*256 function GetFirstFile(pattern, attrib)
226       character*(*) pattern
227       integer       attrib
228       include       'fsos2.fi'
229       integer       DosFindFirst
230       character*256 GetNextFile
231
232       record /BUF/ buffer
233       sat = attrib
234* All attributes = FS_ALL = '00000037'x
235       findcount = 1
236       if(DosFindFirst(pattern, finddirhnd, '00000037'x, buffer,
237     &                 isizeof(buffer), findcount, 1)) then
238        GetFirstFile = char(0)
239         else
240        if(buffer.attrFile .AND. sat) then
241         GetFirstFile = buffer.achName
242          else
243         GetFirstFile = GetNextFile()
244        end if
245       end if
246      end
247c$elseifdef __WIN__
248      character*256 function GetFirstFile(pattern, attrib)
249       character*(*) pattern
250       integer       attrib
251       include       'fswin.fi'
252       character*256 GetNextFile
253       integer       FindFirstFileA,
254     &               GetFileAttrib,
255     &               x
256
257       GetFirstFile = prepos = char(0)
258       sat = attrib
259
260       finddirhnd = FindFirstFileA(pattern, loc(buffer))
261       if(finddirhnd .NE. -1) then
262        if(buffer.cFileName(1:1) .NE. char(0)) then
263
264* Parse search path
265         do x = ntlen(pattern), 1, -1 : ploop
266          if(pattern(x:x) .EQ. '\') then
267           prepos = pattern(:x)//char(0)
268           quit : ploop
269          end if
270         end do
271
272         if(GetFileAttrib(prepos(:ntlen(prepos))//
273     &                   buffer.cFileName) .AND. sat) then
274          GetFirstFile = buffer.cFileName
275           else
276          GetFirstFile = GetNextFile()
277         end if
278        end if
279       end if
280      end
281c$endif
282
283* GetNextFile: platform dependent function
284
285c$ifdef     __OS2__
286      character*256 function GetNextFile()
287       include 'fsos2.fi'
288       integer DosFindNext
289
290       record /BUF/ buffer
291       loop
292        findcount = 1
293        if(DosFindNext(finddirhnd, buffer, isizeof(buffer),
294     &                 findcount)) then
295         GetNextFile = char(0)
296         return
297        end if
298       until(buffer.attrFile .AND. sat)
299
300       GetNextFile = buffer.achName
301      end
302c$elseifdef __WIN__
303      character*256 function GetNextFile()
304       include   'fswin.fi'
305       integer   FindNextFileA,
306     &           GetFileAttrib
307
308       loop
309        buffer.cFileName = ' '
310        if((FindNextFileA(finddirhnd, loc(buffer)) .EQ. 0) .OR.
311     &     (buffer.cFileName(1:1) .EQ. char(0))) then
312         GetNextFile = char(0)
313         return
314        end if
315       until(GetFileAttrib(prepos(:ntlen(prepos))//
316     &                     buffer.cFileName) .AND. sat)
317
318       GetNextFile = buffer.cFileName
319      end
320c$endif
321
322* CloseSearch: platform dependent function
323
324c$ifdef     __OS2__
325      integer function CloseSearch()
326       include 'fsos2.fi'
327       integer DosFindClose
328
329       CloseSearch = DosFindClose(finddirhnd)
330       if(CloseSearch .EQ. 0) finddirhnd = 'FFFFFFFF'x
331      end
332c$elseifdef __WIN__
333      integer function CloseSearch()
334       include 'fswin.fi'
335       integer FindClose
336
337       if(FindClose(finddirhnd) .EQ. 0) then
338        CloseSearch = 1
339         else
340        CloseSearch = finddirhnd = 0
341       end if
342      end
343c$endif
344
345* GetFileAttrib: platform dependent function
346
347c$ifdef     __OS2__
348      integer function GetFileAttrib(file)
349       character*(*) file
350       include       'fsublib.fi'
351       include       'fsos2.fi'
352       integer       DosQueryFileInfo
353
354       record /FILESTATUS3/ buffer
355       open(999, FILE=file(:ntlen(file)), STATUS='OLD', ACTION='READ',
356     &           ERR=10)
357
358       if(DosQueryFileInfo(syshandle(999), 1,
359     &                     buffer, isizeof(buffer))) then
360        GetFileAttrib = -1
361         else
362        GetFileAttrib = buffer.attrFile
363       end if
364
365       close(999, ERR=10)
366
367       return
36810     GetFileAttrib = -1
369      end
370c$elseifdef __WIN__
371      integer function GetFileAttrib(file)
372       character*(*) file
373       integer       GetFileAttributesA
374
375       GetFileAttrib = GetFileAttributesA(file)
376       if(GetFileAttrib .EQ. 'FFFFFFFF'x) GetFileAttrib = -1
377      end
378c$endif
379
380* SetFileAttrib: platform dependent function
381
382c$ifdef     __OS2__
383      integer function SetFileAttrib(file, attrib)
384       character*(*) file
385       integer       attrib
386       include       'fsublib.fi'
387       include       'fsos2.fi'
388       integer       DosSetFileInfo
389
390       record /FILESTATUS3/ buffer
391       open(999, FILE=file(:ntlen(file)), STATUS='OLD',
392     &      ACTION='READWRITE', SHARE='DENYRW', ERR=10)
393
394       buffer.attrFile = attrib
395       SetFileAttrib = DosSetFileInfo(syshandle(999), 1,
396     &                                buffer, isizeof(buffer))
397
398       close(999, ERR=10)
399
400       return
40110     SetFileAttrib = 1
402      end
403c$elseifdef __WIN__
404      integer function SetFileAttrib(file, attrib)
405       character*(*) file
406       integer       attrib
407       integer       SetFileAttributesA
408
409       if(SetFileAttributesA(file, attrib)) then
410        SetFileAttrib = 0
411         else
412        SetFileAttrib = 1
413       end if
414      end
415c$endif
416
417* LoadModule: platform dependent function
418
419c$ifdef     __OS2__
420      integer function LoadModule(lib)
421       character*(*) lib
422       integer       DosLoadModule
423       character*256 buffer
424
425       if(DosLoadModule(buffer, len(buffer),
426     &                  lib, LoadModule)) LoadModule = 0
427      end
428c$elseifdef __WIN__
429      integer function LoadModule(lib)
430       character*(*) lib
431       integer       LoadLibraryA
432
433       LoadModule = LoadLibraryA(lib)
434      end
435c$endif
436
437* FreeModule: platform dependent function
438
439c$ifdef     __OS2__
440      integer function FreeModule(handle)
441       integer handle
442       integer DosFreeModule
443
444       FreeModule = DosFreeModule(handle)
445      end
446c$elseifdef __WIN__
447      integer function FreeModule(handle)
448       integer handle
449       integer FreeLibrary
450
451       while(FreeLibrary(handle)) continue
452       FreeModule = 0
453      end
454c$endif
455
456* DllGetAddress: platform dependent function
457
458c$ifdef     __OS2__
459      integer function DllGetAddress(handle, fncname)
460       integer       handle
461       character*(*) fncname
462       integer       DosQueryProcAddr
463
464       if(DosQueryProcAddr(handle, 0, fncname, DllGetAddress) .NE. 0)
465     &    DllGetAddress = 0
466      end
467c$elseifdef __WIN__
468      integer function DllGetAddress(handle, fncname)
469       integer       handle
470       character*(*) fncname
471       integer       GetProcAddress
472
473       DllGetAddress = GetProcAddress(handle, fncname)
474      end
475c$endif
476
477* GetResource: platform dependent function
478* including EXtended version: GetResourceEx
479
480c$ifdef     __OS2__
481      character*256 function GetResource(modu, type, id)
482       integer modu,
483     &         type,
484     &         id
485       integer DosQueryResourceSize,
486     &         DosGetResource,
487     &         DosFreeResource
488       integer ptr,
489     &         size
490       character buf*(*)
491
492       if((DosQueryResourceSize(modu, type, id, size) .EQ. 0) .AND.
493     &    (size .LT. 256) .AND.
494     &    (DosGetResource(modu, type, id, ptr) .EQ. 0)) then
495        allocate(buf*size, location=ptr)
496        GetResource = buf
497        GetResource(size+1:size+1) = char(0)
498        deallocate(buf)
499        call DosFreeResource(ptr)
500         else
501        GetResource = char(0)
502       end if
503      end
504
505      record /RXSTRING/ function GetResourceEx(modu, type, id)
506       integer modu,
507     &         type,
508     &         id
509       integer DosQueryResourceSize,
510     &         DosGetResource
511       integer ptr,
512     &         size
513
514       structure /RXSTRING/
515        integer*4 strlength,
516     &            strptr
517       end structure
518
519       if((DosQueryResourceSize(modu, type, id, size) .EQ. 0) .AND.
520     &    (DosGetResource(modu, type, id, ptr) .EQ. 0)) then
521        GetResourceEx.strlength = size
522        GetResourceEx.strptr    = ptr
523        ! You must free the resource with CloseResource
524         else
525        GetResourceEx.strlength = GetResourceEx.strptr = 0
526       end if
527      end
528c$elseifdef __WIN__
529      character*256 function GetResource(modu, type, id)
530       integer modu,
531     &         type,
532     &         id
533       integer FindResourceA,
534     &         SizeofResource,
535     &         LoadResource,
536     &         LockResource
537       integer rib,
538     &         hnd,
539     &         ptr,
540     &         size
541       character buf*(*)
542
543       GetResource = char(0)
544
545       rib = FindResourceA(modu, id, type)
546       if(rib) then
547        hnd = LoadResource(modu, rib)
548        if(hnd) then
549         ptr = LockResource(hnd)
550         if(ptr) then
551          size = SizeofResource(modu, rib)
552          if(size .LT. 256) then
553           allocate(buf*size, location=ptr)
554           GetResource = buf
555           GetResource(size+1:size+1) = char(0)
556           deallocate(buf)
557          end if
558         end if
559        end if
560       end if
561      end
562
563      record /RXSTRING/ function GetResourceEx(modu, type, id)
564       integer modu,
565     &         type,
566     &         id
567       integer FindResourceA,
568     &         SizeofResource,
569     &         LoadResource,
570     &         LockResource
571       integer rib,
572     &         hnd
573
574       structure /RXSTRING/
575        integer*4 strlength,
576     &            strptr
577       end structure
578
579       GetResourceEx.strlength = GetResourceEx.strptr = 0
580
581       rib = FindResourceA(modu, id, type)
582       if(rib) then
583        hnd = LoadResource(modu, rib)
584        if(hnd) then
585         GetResourceEx.strptr    = LockResource(hnd)
586         GetResourceEx.strlength = SizeofResource(modu, rib)
587        end if
588       end if
589      end
590c$endif
591
592* CloseResource: platform independent function
593* Only necessary with the GetResourceEx function under OS/2
594
595c$ifdef     __OS2__
596      integer function CloseResource(hnd)
597       integer hnd
598       integer DosFreeResource
599
600       if(DosFreeResource(hnd)) then
601        CloseResource = 1
602         else
603        CloseResource = 0
604       end if
605      end
606c$elseifdef __WIN__
607* Dummy function - not necessary under Windows!
608      integer function CloseResource(hnd)
609       integer hnd
610       CloseResource = 0
611      end
612c$endif
613
614* GetClipboard: platform dependent function
615* including EXtended version: GetClipboardEx
616
617c$ifdef     __OS2__
618      character*256 function GetClipboard()
619       integer       WinOpenClipbrd,
620     &               WinQueryClipbrdData,
621     &               WinCloseClipbrd,
622     &               ntlen,
623     &               hab,
624     &               addr
625       character*(*) buffer
626
627       integer       CF_TEXT
628       parameter    (CF_TEXT = 1)
629
630       GetClipboard = char(0)
631
632       if(WinOpenClipbrd(hab) .NE. 0) then
633        addr = WinQueryClipbrdData(hab, CF_TEXT)
634        if(addr .NE. 0) then
635         allocate(buffer*256, location=addr)
636
637         if(ntlen(buffer) .NE. -1)
638     &    GetClipboard = buffer(:ntlen(buffer)+1)
639        end if
640
641        call WinCloseClipbrd(hab)
642       end if
643      end
644
645      record /RXSTRING/ function GetClipboardEx(size)
646       integer       size
647       include       'cbrdhnd.fi'
648       integer       WinOpenClipbrd,
649     &               WinQueryClipbrdData,
650     &               ntlen,
651     &               addr
652       character*(*) buffer
653
654       structure /RXSTRING/
655        integer*4 strlength,
656     &            strptr
657       end structure
658
659       integer       CF_TEXT
660       parameter    (CF_TEXT = 1)
661
662       GetClipboardEx.strlength = GetClipboardEx.strptr = 0
663
664       if(WinOpenClipbrd(hab) .NE. 0) then
665        addr = WinQueryClipbrdData(hab, CF_TEXT)
666        if(addr .NE. 0) then
667         allocate(buffer*size, location=addr)
668
669         if(ntlen(buffer) .NE. -1) then
670          GetClipboardEx.strlength = ntlen(buffer)+1
671          GetClipboardEx.strptr    = addr
672         end if
673        end if
674
675*       HANDLE MUST BE CLOSED LATER (CloseClipbrd)
676       end if
677      end
678c$elseifdef __WIN__
679      character*256 function GetClipboard()
680       integer       OpenClipboard,
681     &               GetClipboardData,
682     &               CloseClipboard,
683     &               ntlen,
684     &               addr
685       character*(*) buffer
686
687       integer       CF_TEXT
688       parameter    (CF_TEXT = 1)
689
690       GetClipboard = char(0)
691
692       if(OpenClipboard(0) .NE. 0) then
693        addr = GetClipboardData(CF_TEXT)
694        if(addr .NE. 0) then
695        allocate(buffer*256, location=addr)
696
697         if(ntlen(buffer) .NE. -1)
698     &    GetClipboard = buffer(:ntlen(buffer)+1)
699        end if
700
701        call CloseClipboard()
702       end if
703      end
704
705      record /RXSTRING/ function GetClipboardEx(size)
706       integer       size
707       integer       OpenClipboard,
708     &               GetClipboardData,
709     &               ntlen,
710     &               addr
711       character*(*) buffer
712
713       structure /RXSTRING/
714        integer*4 strlength,
715     &            strptr
716       end structure
717
718       integer       CF_TEXT
719       parameter    (CF_TEXT = 1)
720
721       GetClipboardEx.strlength = GetClipboardEx.strptr = 0
722
723       if(OpenClipboard(0) .NE. 0) then
724        addr = GetClipboardData(CF_TEXT)
725        if(addr .NE. 0) then
726         allocate(buffer*size, location=addr)
727
728         if(ntlen(buffer) .NE. -1) then
729          GetClipboardEx.strlength = ntlen(buffer)+1
730          GetClipboardEx.strptr    = addr
731         end if
732        end if
733
734*       HANDLE MUST BE CLOSED LATER (CloseClipbrd)
735       end if
736      end
737c$endif
738
739* SetClipboard: platform dependent function
740
741c$ifdef     __OS2__
742      integer function SetClipboard(text)
743       character*(*) text
744       integer       WinOpenClipbrd,
745     &               WinSetClipbrdData,
746     &               WinCloseClipbrd,
747     &               WinEmptyClipbrd,
748     &               DosAllocSharedMem,
749     &               addr,
750     &               hab
751       character*(*) buffer
752
753       integer       OBJ_GIVEABLE,
754     &               PAG_READ,
755     &               PAG_WRITE,
756     &               PAG_COMMIT,
757     &               CF_TEXT,
758     &               CFI_POINTER
759       parameter    (OBJ_GIVEABLE = '00000200'x,
760     &               PAG_READ     = '00000001'x,
761     &               PAG_WRITE    = '00000002'x,
762     &               PAG_COMMIT   = '00000010'x,
763     &               CF_TEXT      = 1,
764     &               CFI_POINTER  = '00000400'x)
765
766       SetClipboard = 1
767
768       if(WinOpenClipbrd(hab) .EQ. 0) return
769       guess
770        if(WinEmptyClipbrd(hab) .EQ. 0) quit
771
772        if(DosAllocSharedMem(addr, 0, 256,
773     &                       OBJ_GIVEABLE .OR. PAG_READ .OR.
774     &                       PAG_WRITE .OR. PAG_COMMIT) .EQ. 0) then
775         allocate(buffer*256, location=addr)
776         buffer = text
777
778         if(WinSetClipbrdData(hab, addr, CF_TEXT, CFI_POINTER))
779     &      SetClipboard = 0
780        end if
781       end guess
782
783       call WinCloseClipbrd(hab)
784      end
785c$elseifdef __WIN__
786      integer function SetClipboard(text)
787       character*(*) text
788       integer       OpenClipboard,
789     &               SetClipboardData,
790     &               CloseClipboard,
791     &               EmptyClipboard,
792     &               GlobalAlloc,
793     &               GlobalLock,
794     &               GlobalUnlock,
795     &               hmem,
796     &               addr
797       character*(*) buffer
798
799       integer       GMEM_MOVEABLE,
800     &               GMEM_DDESHARE,
801     &               CF_TEXT
802       parameter    (GMEM_MOVEABLE = 2,
803     &               GMEM_DDESHARE = 8192,
804     &               CF_TEXT       = 1)
805
806       SetClipboard = 1
807       if(OpenClipboard(0) .EQ. 0) return
808       guess
809        if(EmptyClipboard() .EQ. 0) quit
810
811        hmem = GlobalAlloc(GMEM_MOVEABLE .OR. GMEM_DDESHARE,
812     &                     256)
813        if(hmem) then
814         addr = GlobalLock(hmem)
815         if(addr .EQ. 0) quit
816
817         allocate(buffer*256, location=addr)
818         buffer = text
819
820         if(GlobalUnlock(hmem)) quit
821
822         if(SetClipboardData(CF_TEXT, hmem)) SetClipboard = 0
823        end if
824       end guess
825
826       call CloseClipboard()
827      end
828c$endif
829
830* CloseClipboard: platform dependet function
831* just useful for GetClipboardEx (handle should be closed later)
832
833c$ifdef     __OS2__
834      integer function CloseClipbrd()
835       include 'cbrdhnd.fi'
836       integer WinCloseClipbrd
837
838       if(WinCloseClipbrd(hab)) then
839        CloseClipbrd = 0
840         else
841        CloseClipbrd = 1
842       end if
843      end
844c$elseifdef __WIN__
845      integer function CloseClipbrd()
846       integer CloseClipboard
847
848       if(CloseClipboard()) then
849        CloseClipbrd = 0
850         else
851        CloseClipbrd = 1
852       end if
853      end
854c$endif
855
856* MessageBeep: platform dependent function
857
858c$ifdef     __OS2__
859      integer function MessageBeep(freq, dur)
860       integer freq,
861     &         dur
862       integer DosBeep
863
864       MessageBeep = DosBeep(freq, dur)
865      end
866c$elseifdef __WIN__
867      integer function MessageBeep(freq, dur)
868       integer freq,
869     &         dur
870       integer Beep
871
872       if(Beep(freq, dur)) then
873        MessageBeep = 0
874         else
875        MessageBeep = 1
876       end if
877      end
878c$endif
Note: See TracBrowser for help on using the browser.