2 * This is an example for using GCI. Enjoy, copy and paste!
3 * We have three different execution paths for Unix, Win32 and OS/2.
4 * For some interpreters, most notable the builtin interpreter of OS/2, you
5 * have to rename this file to gci-try.cmd
8 say "Your REXX interpreter is" version
10 /******************************************************************************
11 * Try to detect the system to show several things.
13 parse var version "REXX-"ipret
"_".
15 if ipret
= "Regina" then do
18 options NOEXT_COMMANDS_AS_FUNCS
21 parse source system
. source
23 system
= translate(system
)
24 if left(system
, 3) = "WIN" then do
29 else if system
= "OS/2" then do
37 "test `uname -s` = 'SunOS'"
43 if IsRegina
& Left(uname
, 6) = 'CYGWIN' then do
45 MathLib
= "cygwin1.dll"
56 * Check for a builtin RxFuncDefine. Call it with errorneous arguments and
57 * expect a simple error if installed and a syntax signal if unknown.
60 signal on syntax name NotInstalled
63 h
= RxFuncDefine
(x
,x
,x
,x
)
64 if h \
= 0 & h \
= 10005 & DataType(h
, "NUM") then
70 if \InternalGCI
then do
72 * The DLL may have been loaded already. Prevent bugs at this stage.
74 call RxFuncDrop RxFuncDefine
75 call RxFuncDrop GciPrefixChar
76 call RxFuncDrop GciFuncDrop
77 if RxFuncadd(RxFuncDefine
, "gci", "RxFuncDefine") \
= 0 then do
78 msg = "Can't load RxFuncDefine of" library
80 msg = msg || ":" RxFuncErrMsg
()
84 if RxFuncadd(GciFuncDrop
, "gci", "GciFuncDrop") \
= 0 then do
85 msg = "Can't load GciFuncDrop of" library
87 msg = msg || ":" RxFuncErrMsg
()
91 call RxFuncadd GciPrefixChar
, "gci", "GciPrefixChar"
92 say "Your interpreter has no internal support of GCI"
95 say "Your interpreter has internal support of GCI"
99 /******************************************************************************
100 * After the prelimnaries try to use the GCI.
102 if system
= "OS/2" then signal useOS2
104 say "Trying to copy string 'hello' to a string 'world' using the C library"
105 stem
.calltype
= cdecl
107 stem
.1.name = "Target"
108 stem
.1.type
= indirect string80
109 stem
.2.name = "Source"
110 stem
.2.type
= indirect string80
111 stem
.return.type
= "" /* We are not interested in the return value */
113 call funcDefine strcpy
, CLib
, "strcpy", stem
115 stem
.1.name = "Target"
116 stem
.1.value = "world"
117 stem
.2.name = "Source"
118 stem
.2.value = "hello"
120 say stem
.1.name"="stem
.1.value stem
.2.name"="stem
.2.value
124 /******************************************************************************
125 * Check if v1.1 GciPrefixChar works.
129 signal on syntax name v1
.0
130 say "Trying to detect and use v1.1 features (same result as above expected)"
131 oldChar
= GciPrefixChar
('!')
133 stem
.!calltype
= cdecl
135 stem
.1.!name = "Target"
136 stem
.1.!type
= indirect string80
137 stem
.2.!name = "Source"
138 stem
.2.!type
= indirect string80
139 stem
.!return.!type
= ""
141 call funcDefine strcpy
, CLib
, "strcpy", stem
143 stem
.1.!name = "Target"
144 stem
.1.!value = "world"
145 stem
.2.!name = "Source"
146 stem
.2.!value = "hello"
148 say stem
.1.!name"="stem
.1.!value stem
.2.name"="stem
.2.!value
152 call GciPrefixChar oldChar
156 /******************************************************************************
157 * Use the "as function" feature
159 say "Trying to find the last occurcance of '.' in 'James F. Cooper' using the C"
160 say "library using the 'as function' feature"
161 stem
.calltype
= cdecl as function
163 stem
.1.name = "String"
164 stem
.1.type
= indirect string80
165 stem
.2.name = "Character"
167 stem
.return.type
= indirect string80
169 call funcDefine strrchr
, CLib
, "strrchr", stem
171 stem
.1.name = "Target"
172 stem
.1.value = "James F. Cooper"
173 stem
.2.name = "Character"
175 say "The last dot starts at '" || strrchr
( stem
) || "'"
177 say "Trying to find the last occurcance of '.' in 'James Cooper' using the C lib"
178 say "We expect a NULL pointer which leads to a dropped value which becomes ''"
179 say "for a return value."
181 stem
.1.name = "Target"
182 stem
.1.value = "James Cooper"
183 say "The last dot starts at '" || strrchr
( stem
) || "'"
185 call funcDrop strrchr
187 /******************************************************************************
188 * Use the "with parameters as function" feature.
189 * Note that you must omit "as function" if the return value doesn't exist.
190 * We use separate functions for Windows and unix.
192 if system
= "WIN" then signal useWindows
194 say "Trying to use the math library to compute some natural logarithms"
195 stem
.calltype
= cdecl
with parameters as function
198 stem
.1.type
= float128
199 stem
.return.type
= float128
200 call RxFuncDefine logl
, MathLib
, "logl", stem
201 if RESULT \
= 0 then do
202 stem
.1.type
= float96
203 stem
.return.type
= float96
204 call RxFuncDefine logl
, MathLib
, "logl", stem
206 if RESULT \
= 0 then do
207 stem
.1.type
= float64
208 stem
.return.type
= float64
209 call RxFuncDefine logl
, MathLib
, "log", stem
211 if RESULT \
= 0 then do
212 if IsRegina
& InternalGCI
then
213 say "Error, code" RESULT || ":" RxFuncErrMsg
()
215 say "Error, code" RESULT || ":" GCI_RC
219 say "some logarithms"
221 say "log("i
")="logl
(i
)
226 /*******************************/
227 say "Using a structure and checking the file system's size."
228 say "You may look into the source."
230 * This examples has removed all unnecessary stuff.
232 stem
.calltype
= cdecl as function
234 stem
.1.type
= indirect string256
235 stem
.2.type
= indirect container
236 stem
.2.0 = 10 /* statvfs64 */
237 stem
.2.1.type
= unsigned
/* bsize */
238 stem
.2.2.type
= unsigned
/* frsize */
239 stem
.2.3.type
= unsigned64
/* blocks */
240 stem
.2.4.type
= unsigned64
/* bfree */
241 stem
.2.5.type
= unsigned64
/* bavail */
242 stem
.2.6.type
= unsigned64
/* files */
243 stem
.2.7.type
= unsigned64
/* ffree */
244 stem
.2.8.type
= unsigned64
/* favail */
245 stem
.2.9.type
= unsigned
/* fsid */
246 stem
.2.10.type
= string256
/* indifferent between unices */
247 stem
.return.type
= integer
249 call funcDefine statvfs
, CLib
, "statvfs64", stem
252 args
.1.value = source
253 args
.2.value = 10 /* otherwise the argument becomes NULL */
254 if statvfs
( args
) \
= -1 then do
255 say "statvfs-info of" source
256 say "block size =" args
.2.1.value "byte"
257 size = trunc(args
.2.3.value * args
.2.1.value / (1024 * 1024))
258 avail
= trunc(args
.2.5.value * args
.2.1.value / (1024 * 1024))
259 say "file system size =" size"MB, available =" avail
"MB"
260 say "file nodes =" args
.2.6.value "available =" args
.2.8.value
261 say "sid =" args
.2.9.value
264 say "Sorry, '"source"' not found."
266 call funcDrop statvfs
268 /*******************************/
270 say "We use qsort of the C library for sorting some strings using arrays."
272 * This examples has removed all unnecessary stuff.
273 * We need a sorting routine. Without callbacks we have to use one of a
274 * library. "strcmp" is a good example. We have to play with the dynamic
277 * Load the loader functions (dlopen, dlsym, dlclose)
278 * Load the compare routine (strcmp) using the loader functions
279 * Load the sorting routine (qsort) and do the sort
280 * Additional sort operations may have to redefine qsort only.
282 stem
.calltype
= cdecl
with parameters as function
284 stem
.1.type
= indirect string256
285 stem
.2.type
= integer
286 stem
.return.type
= integer
/* handle, but who cares? */
287 call funcDefine dlopen
, "dl", "dlopen", stem
289 stem
.calltype
= cdecl
with parameters as function
291 stem
.1.type
= integer
/* handle */
292 stem
.2.type
= indirect string256
293 stem
.return.type
= integer
/* entry point address, but who cares? */
294 call funcDefine dlsym
, "dl", "dlsym", stem
296 stem
.calltype
= cdecl
with parameters as function
298 stem
.1.type
= integer
/* handle */
299 stem
.return.type
= integer
300 call funcDefine dlclose
, "dl", "dlclose", stem
302 CLibHandle
= dlopen
( CLib
, 1 /* RTLD_LAZY */ )
303 if CLibHandle
= 0 then do
304 say "dlopen() can't load" CLib
308 strcmp
= dlsym
( CLibHandle
, "strcmp" )
309 if strcmp
= 0 then do
310 say "dlsym() can't relocate strcmp()"
314 stem
.calltype
= cdecl
316 stem
.1.type
= indirect
array
318 stem
.1.1.type
= string95
319 stem
.2.type
= integer
320 stem
.3.type
= integer
321 stem
.4.type
= integer
322 stem
.return.type
= ""
323 call funcDefine qsort10
, CLib
, "qsort", stem
327 args
.1.1.value = "Ann"
328 args
.1.2.value = "Charles"
329 args
.1.3.value = "Betty"
332 args
.4.value = strcmp
333 say "Sorting (" args
.1.1.value args
.1.2.value args
.1.3.value ") ..."
335 say "Sorted values are (" args
.1.1.value args
.1.2.value args
.1.3.value ")"
337 call dlclose CLibHandle
339 call funcDrop dlclose
347 /***************************************************/
349 stem
.calltype
= stdcall
with parameters as function
352 stem
.1.type
= unsigned
354 stem
.2.type
= indirect string1024
355 stem
.3.name = "Caption"
356 stem
.3.type
= indirect string1024
358 stem
.4.type
= unsigned
359 stem
.return.type
= integer
361 call funcDefine messagebox
, "user32", "MessageBoxA", stem
363 MB_YESNO_INFO
= x2d(44)
364 if messagebox
( 0, "Do you love this rocking GCI?", "GCI", MB_YESNO_INFO
) = 6 then
365 say "Yes, you're right, GCI is cool."
367 say "No, you're kidding! GCI is cool."
369 call funcDrop messagebox
371 /*******************************/
372 say "We operate on containers and check this file's date."
373 say "You may look into the source."
375 * This examples has removed all unnecessary stuff.
377 stem
.calltype
= stdcall as function
379 stem
.1.type
= indirect string256
380 stem
.2.type
= indirect container
381 stem
.2.0 = 8 /* WIN32_FIND_DATA */
382 stem
.2.1.type
= unsigned
/* FileAttributes */
383 stem
.2.2.type
= unsigned64
/* Creation */
384 stem
.2.3.type
= unsigned64
/* Access */
385 stem
.2.4.type
= unsigned64
/* Write */
386 stem
.2.5.type
= unsigned64
/* Size */
387 stem
.2.6.type
= unsigned64
/* Reserved */
388 stem
.2.7.type
= string259
/* FileName */
389 stem
.2.8.type
= string13
/* AlternateFileName */
390 stem
.return.type
= integer
392 stem2
.calltype
= stdcall
with parameters
394 stem2
.1
.type
= integer
395 stem2
.return.type
= ""
397 call funcDefine findfirstfile
, "kernel32", "FindFirstFileA", stem
399 call funcDefine findclose
, "kernel32", "FindClose", stem2
402 args
.1.value = source
403 args
.2.value = 8 /* otherwise the argument becomes NULL */
404 handle = findfirstfile
( args
)
405 if handle \
= -1 then do
406 say "argument's name="source
407 say "filename="args
.2.7.value
408 say "8.3-name="args
.2.8.value
410 filetime
= args
.2.4.value
411 d
= /*second*/ 1000*1000*10 * /*seconds per day*/ 60*60*24
412 daypart
= trunc(filetime
/ d
)
413 date = date( 'N', daypart
+ date('B', 16010101, 'S'), 'B')
414 ns
= filetime
- daypart
* d
415 secs
= ns
% (10*1000*1000)
416 fract
= ns
// (10*1000*1000)
417 time = time('N', secs
, 'S') || "." || right(fract
, 7, '0')
418 say "ns from 1.1.1601="filetime
"= GMT," date || "," time
420 call findclose
handle
423 say "Sorry, '"source"' not found."
425 call funcDrop findfirstfile
426 call funcDrop findclose
432 /***************************************************/
433 accessStructTm: procedure expose IsRegina InternalGCI CLib
version
434 if version < 1.1 then
436 say "Finally, we use the LIKE keyword and check the number of the week."
437 say "You may look into the source, we use a PROCEDURE and v1.1 specific code."
439 * This examples has removed all unnecessary stuff.
442 tm
.1.type
= integer
/* tm_sec */
443 tm
.2.type
= integer
/* tm_min */
444 tm
.3.type
= integer
/* tm_hour */
445 tm
.4.type
= integer
/* tm_mday */
446 tm
.5.type
= integer
/* tm_mon */
447 tm
.6.type
= integer
/* tm_year */
448 tm
.7.type
= integer
/* tm_wday */
449 tm
.8.type
= integer
/* tm_yday */
450 tm
.9.type
= integer
/* tm_isdst */
451 tm
.10.type
= string
32 /* reserved stuff sometimes used by the OS */
454 time_t
.1.type
= integer64
/* SURPRISE! some systems may use 64 bit data types
455 * already. We don't have problems with this,
456 * because we use double buffering.
459 stem
.calltype
= cdecl
461 stem
.1.type
= indirect container like time_t
462 stem
.return.type
= ""
463 call funcDefine _time
, CLib
, "time", stem
465 stem
.calltype
= cdecl
467 stem
.1.type
= indirect container like time_t
468 stem
.return.type
= indirect container like tm
469 call funcDefine localtime
, CLib
, "localtime", stem
471 stem
.calltype
= cdecl
473 stem
.1.type
= indirect string256
/* dest */
474 stem
.2.type
= unsigned
/* size(dest) */
475 stem
.3.type
= indirect string256
/* template */
476 stem
.4.type
= indirect container like tm
477 stem
.return.type
= unsigned
478 call funcDefine strftime
, CLib
, "strftime", stem
481 time_val
.1.1.value = 1
485 lct
.1.1.value = time_val
.1.1.value
491 strf
.4.value = lct
.return.value
493 strf
.4.i
.value = lct
.return.i
.value
496 dayname
= strf
.1.value
500 monthname
= strf
.1.value
504 week
!Sun
= strf
.1.value
508 week
!Mon
= strf
.1.value
510 if week
!Mon
= week
!Sun
then
513 add
= " if you count Monday as the first day of the week. Otherwise it " ||,
514 "is the" week
!Sun
|| ". week."
515 say "Today is a" dayname
"in" monthname
|| ". We have the" week
!Mon
|| ". week" || add
517 call funcDrop strftime
518 call funcDrop localtime
523 /***************************************************/
525 say "Checking the high precision system timer."
526 stem
.calltype
= stdcall
528 stem
.1.name = "Frequency"
529 stem
.1.type
= indirect unsigned
530 stem
.return.type
= "unsigned"
532 call funcDefine DosTmrQueryFreq
, "doscalls", "#362", stem
534 stem
.1.name = "Frequency"
535 stem
.1.value = 0 /* don't raise NOVALUE */
537 call DosTmrQueryFreq stem
538 if stem
.return.value \
= 0 then
539 say "Error" stem
.return.value "while using DosTmrQueryFreq."
541 say "The timer has a frequency of" stem
.1.value "Hz"
543 call funcDrop DosTmrQueryFreq
545 /*******************************/
546 say "You should hear your beeper."
548 * Use the "with parameters" feature.
550 stem
.calltype
= stdcall
with parameters
552 stem
.1.name = "Frequency"
553 stem
.1.type
= unsigned
554 stem
.2.name = "Duration"
555 stem
.2.type
= unsigned
556 stem
.return.type
= "" /* We are not interested in the return value */
558 call funcDefine DosBeep
, "doscalls", "#286", stem
560 do i
= 500 to 3000 by 100
564 call funcDrop DosBeep
566 /*******************************/
567 say "Checking the installed codepages."
569 * Use the "as function" feature.
571 stem
.calltype
= stdcall as function
574 stem
.1.type
= unsigned
576 stem
.2.type
= indirect
array
578 stem
.2.1.type
= unsigned
580 stem
.3.type
= indirect unsigned
581 stem
.return.type
= "unsigned"
583 call funcDefine DosQueryCp
, "doscalls", "#291", stem
586 stem
. = 0 /* NOVALUE should not happen */
593 if DosQueryCp
( stem
) = 0 then do
594 say "current codepage:" stem
.2.1.value
595 do i
= 2 to stem
.3.value / 4
596 say "prepared codepage:" stem
.2.i
.value
600 say "Error calling DosQueryCp."
602 call funcDrop DosQueryCp
604 /*******************************/
605 say "Examining the file system on" left( source, 2 )
607 * Use the "as function" feature.
609 stem
.calltype
= stdcall as function
611 stem
.1.name = "disknum"
612 stem
.1.type
= unsigned
613 stem
.2.name = "infolevel"
614 stem
.2.type
= unsigned
616 stem
.3.type
= indirect container
618 stem
.3.1.name = "idFileSystem"
619 stem
.3.1.type
= unsigned
620 stem
.3.2.name = "cSectorUnit"
621 stem
.3.2.type
= unsigned
622 stem
.3.3.name = "cUnit"
623 stem
.3.3.type
= unsigned
624 stem
.3.4.name = "cUnitAvail"
625 stem
.3.4.type
= unsigned
626 stem
.3.5.name = "cbSector"
627 stem
.3.5.type
= unsigned16
628 stem
.4.name = "cbBuf"
629 stem
.4.type
= unsigned
630 stem
.return.type
= "unsigned"
632 call funcDefine DosQueryFSInfo
, "doscalls", "#278", stem
635 stem
. = 0 /* NOVALUE should not happen */
637 stem
.1.name = "disknum"
638 stem
.1.value = c2d( translate( left( source, 1 ) ) ) - c2d( 'A' ) + 1
639 stem
.2.name = "infolevel"
643 stem
.4.name = "cbBuf"
645 if DosQueryFSInfo
( stem
) = 0 then do
646 cluster
= stem
.3.2.value * stem
.3.5.value
647 say "Total size:" showFileSize
( cluster
*stem
.3.3.value )
648 say "Free size:" showFileSize
( cluster
*stem
.3.4.value )
651 say "Error calling DosQueryFSInfo."
653 call funcDrop DosQueryFSInfo
658 showFileSize: procedure
661 suffixes
= "KB MB GB TB"
662 do i
= 1 to words( suffixes
)
665 suffix
= word( suffixes
, i
)
669 size = format( size, , 0 )
670 else if size >= 10 then
671 size = format( size, , 1 )
673 size = format( size, , 2 )
676 /*****************************************************************************/
679 * Not all interpreters are ANSI compatible.
684 if datatype( SIGL_FUNCDEFINE
, "W" ) then
685 SIGL = SIGL_FUNCDEFINE
686 say "Error" code
"in line" SIGL || ":" condition('D')
687 say "GCI_RC=" || GCI_RC
690 /*****************************************************************************/
693 * Drops one defined function depending on whether is is defined in the
694 * lightweight library or in the interpreter's kernel.
697 call RxFuncDrop arg(1)
699 call GciFuncDrop
arg(1)
702 /*****************************************************************************/
705 * Defines a new subroutine as RxFuncDefine does, additionally it undefines
706 * (drops) the subroutine in front and it shows the error messages.
707 * Finally it terminates the process is an error occurs.
709 _SIGL_FUNCDEFINE
= SIGL
712 SIGL_FUNCDEFINE
= _SIGL_FUNCDEFINE
713 call RxFuncDefine
arg(1), arg(2), arg(3), arg(4)
714 drop SIGL_FUNCDEFINE _SIGL_FUNCDEFINE
717 if IsRegina
& InternalGCI
then
718 errAdd
= ":" RxFuncErrMsg
()
720 if GCI_RC \
= "GCI_RC" then
725 say "Error defining '" || arg(1) || "', code" RESULT || errAdd